Changeset 9702


Ignore:
Timestamp:
Jun 9, 2008, 1:08:40 AM (11 years ago)
Author:
gb
Message:

Propagate decl changes from working-0711.
READ-CHAR: try the obviously BASIC-STREAM case earlier.

Location:
branches/working-0711-perf/ccl/lib
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/lib/ccl-export-syms.lisp

    r9577 r9702  
    2323     local
    2424     set-local
     25     @
    2526     *elements-per-buffer*
    2627     save-application
  • branches/working-0711-perf/ccl/lib/describe.lisp

    r7624 r9702  
    17521752
    17531753(defvar *inspector-ui* ())
     1754(defvar *previous-inspector-ui* nil)
    17541755
    17551756(defclass inspector-ui ()
     
    18011802(ccl::define-toplevel-command
    18021803    :tty-inspect pop ()
    1803     "exit current inspector"
     1804    "exit current inspector level"
    18041805    (invoke-restart 'exit-inspector))
     1806
     1807(ccl::define-toplevel-command
     1808    :tty-inspect q ()
     1809    "exit inspector"
     1810  (invoke-restart 'end-inspect))
     1811
    18051812
    18061813(ccl::define-toplevel-command
    18071814    :tty-inspect show ()
    1808     "re-show currently inspected object"
     1815    "re-show currently inspected object (the value of CCL:@)"
    18091816    (ui-present *inspector-ui*))
    18101817
     
    18511858
    18521859(defmethod ui-interact ((ui inspector-tty-ui))
    1853   (let* ((level (inspector-ui-level ui)))
     1860  (let* ((level (inspector-ui-level ui))
     1861         (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui))))))
     1862    (declare (special ccl::*default-integer-command*))
    18541863    (restart-case
    18551864     (ccl:with-terminal-input
     
    18601869                                   (format stream "~&Inspect> ")
    18611870                                   (format stream "~&Inspect ~d> " level))))))
    1862      (exit-inspector () (terpri *debug-io*)))))
     1871      (exit-inspector () ;
     1872        (if *previous-inspector-ui*
     1873          (ui-present *previous-inspector-ui*)
     1874          (terpri *debug-io*))))))
    18631875
    18641876(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
     
    18781890
    18791891(defmethod inspector-ui-inspect ((ui inspector-ui))
    1880   (let* ((*inspector-ui* ui))
     1892  (let* ((*previous-inspector-ui* *inspector-ui*)
     1893         (*inspector-ui* ui))
    18811894    (ui-initialize ui)
    18821895    (ui-present ui)
     
    18891902                                         :level 0)))
    18901903
    1891 (defglobal *default-inspector-ui-creation-function* 'tty-inspect)
     1904(defparameter *default-inspector-ui-creation-function* 'tty-inspect)
    18921905       
    18931906
    18941907(defun inspect (thing)
    18951908  (let* ((ccl::@ thing))
    1896     (funcall *default-inspector-ui-creation-function* thing)))
    1897 
     1909    (restart-case (funcall *default-inspector-ui-creation-function* thing)
     1910      (end-inspect () thing))))
  • branches/working-0711-perf/ccl/lib/dumplisp.lisp

    r8931 r9702  
    6464                         )
    6565  (declare (ignore toplevel-function error-handler application-class
    66                    resources clear-clos-caches init-file impurify
     66                   clear-clos-caches init-file impurify
    6767                   mode prepend-kernel))
    6868  (unless (probe-file (make-pathname :defaults nil
  • branches/working-0711-perf/ccl/lib/macros.lisp

    r9525 r9702  
    20492049;;; which tests *print-escape* ?  Scary if so ...
    20502050
    2051 (defmacro define-condition (name (&rest supers) &optional ((&rest slots)) &body options)
     2051(defmacro define-condition (name (&rest supers) (&rest slots) &body options)
    20522052  "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
    20532053   Define NAME as a condition type. This new type inherits slots and its
     
    23362336  (setq mname (require-type mname 'symbol))
    23372337  (let ((state (make-symbol "WITH-PACKAGE-ITERATOR_STATE")))
    2338     (declare (fixnum types))
    23392338    (dolist (type (push first-type other-types))
    23402339      (ecase type
  • branches/working-0711-perf/ccl/lib/number-case-macro.lisp

    r2325 r9702  
    7070                       (append compound selectors-so-far))
    7171                 compound))))
    72       (declare (dynamic-extent maybe-compound))
     72      (declare (dynamic-extent #'maybe-compound))
    7373      `(block ,block
    7474         (tagbody
  • branches/working-0711-perf/ccl/lib/sequences.lisp

    r9438 r9702  
    718718         (maxcnt (seq-dispatch result-sequence (length result-sequence) (array-total-size result-sequence)))
    719719         (rseq result-sequence))
    720     (declare (fixnum cnt nargs maxcnt))
     720    (declare (fixnum nargs maxcnt))
    721721    (declare (dynamic-extent temp))
    722722    ; this declaration is maybe bogus
     
    17121712        (count 0))
    17131713       ((= index end) count)
    1714     (declare (fixnum index count limit))
     1714    (declare (fixnum index count))
    17151715    (when (funcall test item  (funcall key (aref sequence index)))
    17161716      (incf count))))
     
    17311731        (count 0))
    17321732       ((= index end) count)
    1733     (declare (fixnum index count limit))
     1733    (declare (fixnum index count))
    17341734    (unless (funcall test-not item (funcall key (aref sequence index)))
    17351735      (incf count))))
  • branches/working-0711-perf/ccl/lib/setf.lisp

    r2711 r9702  
    8484                    (vals nil))
    8585                (dolist (x (cdr form))
     86                  ;; Rebinding defeats optimizations, so avoid it if can.
     87                  (if (constantp x environment)
     88                    (push x args)
    8689                    (let ((var (gensym)))
    8790                      (push var vars)
    8891                      (push var args)
    89                       (push x vals)))
     92                      (push x vals))))
    9093                (setq args (nreverse args))
    9194                (values (nreverse vars)
     
    480483    ;; Make sure the place is one that we can handle.
    481484    ;;Mainly to insure against cases of ldb and mask-field and such creeping in.
    482     (cond ((and (eq (car (last args)) (car (last vals)))
    483                 (eq (car (last getter)) (car (last dummies)))
    484                 newval
    485                 (null (cdr newval))
    486                 (eq (car (last setter)) (car newval))
    487                 (eq (car (last setter 2)) (car (last dummies))))
    488            ; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
    489            (values dummies vals newval
    490                    `(apply+ (function ,(car setter))
    491                             ,@(butlast dummies)
    492                             ,@(last dummies)
    493                             ,(car newval))
    494                    `(apply (function ,(car getter)) ,@(cdr getter))))
    495           ((and (eq (car (last args)) (car (last vals)))
    496                 (eq (car (last getter)) (car (last dummies)))
    497                 newval
    498                 (null (cdr newval))
    499                 (eq (car setter) 'funcall)
    500                 (eq (third setter) (car newval))
    501                 (eq (car (last setter)) (car (last dummies))))
    502            ; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
    503            (values dummies vals newval
    504                    `(apply ,@(cdr setter))
    505                    `(apply (function ,(car getter)) ,@(cdr getter))))
    506           (t (error "Apply of ~S is not understood as a location for Setf."
    507                     function)))))
     485    (let* ((last-arg (car (last args)))
     486           (last-val (car (last vals)))
     487           (last-dummy (car (last dummies)))
     488           (last-getter (car (last getter)))
     489           (last2-setter (car (last setter 2)))
     490           (last-setter (car (last setter))))
     491      (cond ((and (or (and (eq last-arg last-val)
     492                           (eq last-getter last-dummy))
     493                      (eq last-arg last-getter))
     494                  newval
     495                  (null (cdr newval))
     496                  (eq last-setter (car newval))
     497                  (or (and (eq last-arg last-val)
     498                           (eq last2-setter last-dummy))
     499                      (eq last-arg last2-setter)))
     500             ;; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
     501             (values dummies vals newval
     502                     `(apply+ (function ,(car setter)) ,@(cdr setter))
     503                     `(apply (function ,(car getter)) ,@(cdr getter))))
     504            ((and (or (and (eq last-arg last-val)
     505                           (eq last-getter last-dummy))
     506                      (eq last-arg last-getter))
     507                  newval
     508                  (null (cdr newval))
     509                  (eq (car setter) 'funcall)
     510                  (eq (third setter) (car newval))
     511                  (or (and (eq last-arg last-val)
     512                           (eq last-setter last-dummy))
     513                      (eq last-arg last-setter)))
     514             ;; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
     515             (values dummies vals newval
     516                     `(apply ,@(cdr setter))
     517                     `(apply (function ,(car getter)) ,@(cdr getter))))
     518            (t (error "Apply of ~S is not understood as a location for Setf."
     519                      function))))))
    508520
    509521;;These are the supporting functions for the am-style hard-cases of setf.
  • branches/working-0711-perf/ccl/lib/source-files.lisp

    r9439 r9702  
    437437
    438438      (typecase thing
    439         (function  (collect-def 'function (function-name thing)))
     439        (function  (if (getf (%lfun-info thing) 'function-source-note)
     440                     (let* ((function-source-note (getf (%lfun-info thing) 'function-source-note)))
     441                       (list (%make-source-note :start-pos (getf function-source-note :start)
     442                                                :end-pos (getf function-source-note :end)
     443                                                :source (%fast-uncompact (getf function-source-note :%text  ))
     444                                                :file-name (getf function-source-note :file-name))))
     445                     (collect-def 'function (function-name thing))))
    440446        (class     (collect-def 'class (class-name thing)))
    441447        (method    (collect-def 'method thing))
  • branches/working-0711-perf/ccl/lib/streams.lisp

    r6205 r9702  
    5454  (declare (ignore recursive-p)
    5555           (optimize (speed 3) (space 0)))
    56   (setq input-stream (designated-input-stream input-stream))
    57   (if (typep input-stream 'basic-stream)
    58     (let* ((ioblock (basic-stream-ioblock input-stream)))
    59       (check-eof
    60        (funcall (ioblock-read-char-function ioblock) ioblock)
    61        input-stream eof-error-p eof-value))
    62     (check-eof (stream-read-char input-stream)
    63                input-stream
    64                eof-error-p
    65                eof-value)))
     56  (check-eof
     57   (if (or (typep input-stream 'basic-stream)
     58           (typep (setq input-stream (designated-input-stream input-stream))
     59                  'basic-stream))
     60     (let* ((ioblock (basic-stream-ioblock input-stream)))
     61       (funcall (ioblock-read-char-function ioblock) ioblock))
     62     (stream-read-char input-stream))
     63   input-stream eof-error-p eof-value))
    6664
    6765(defun unread-char (char &optional input-stream)
  • branches/working-0711-perf/ccl/lib/x86-backtrace.lisp

    r8037 r9702  
    219219             (p (- (%fixnum-ref fp target::xcf.backptr)
    220220                   (* target::node-size numinh))))
    221         (declare (fixnum numing nargs p))
     221        (declare (fixnum numinh nargs p))
    222222        (collect ((args))
    223223          (dotimes (i nargs (args))
     
    374374                       (ash 1 x8664::save2)
    375375                       (ash 1 x8664::save3))))
    376     (declare (fixnum have need)
     376    (declare (fixnum need)
    377377             (dynamic-extent locations))
    378378    (do* ((parent frame child)
Note: See TracChangeset for help on using the changeset viewer.