Changeset 14864


Ignore:
Timestamp:
Jul 7, 2011, 4:11:40 PM (8 years ago)
Author:
rme
Message:

Reader method optimization/pessimization fixes from trunk.

Location:
release/1.6/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/1.6/source

  • release/1.6/source/level-0/l0-misc.lisp

    • Property svn:mergeinfo changed (with no actual effect on merging)
  • release/1.6/source/level-1/l1-clos.lisp

    r14119 r14864  
    307307        do (etypecase obj
    308308             (standard-generic-function
    309               (clear-gf-dispatch-table (%gf-dispatch-table obj))
    310               (compute-dcode obj)))))
     309              (let* ((dt (%gf-dispatch-table obj))
     310                     (argnum (%gf-dispatch-table-argnum dt)))
     311                (when (< argnum 0)
     312                  (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
     313                        (%gf-dcode obj) (%gf-dispatch-table-gf dt)
     314                        (%gf-dispatch-table-gf dt) obj)
     315                  (clear-gf-dispatch-table dt)))))))
    311316
    312317(defun update-slots (class eslotds)
     
    21372142                        do (note-class-dependent c f)))
    21382143                (clear-gf-dispatch-table dt)
    2139                 (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
     2144                (let* ((argnum (%gf-dispatch-table-argnum dt)))
     2145                  (unless (< argnum 0)
     2146                    (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
     2147                          (%gf-dispatch-table-gf dt) (%gf-dcode f))))
     2148                   
    21402149                (cond ((null (cdr alist))
    21412150                       ;; Method is only applicable to a single class.
     
    25312540  ;; Un-snap reader methods, undo other GF optimizations.
    25322541  (dolist (f (population-data %all-gfs%))
    2533     (let* ((dt (%gf-dispatch-table f)))
    2534       (clear-gf-dispatch-table dt)
    2535       (compute-dcode f))))
     2542    (let* ((dt (%gf-dispatch-table f))
     2543           (argnum (%gf-dispatch-table-argnum dt)))
     2544      (when (< argnum 0)
     2545        (let* ((dcode (%gf-dispatch-table-gf dt)))
     2546          (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
     2547                (%gf-dispatch-table-gf dt) f
     2548                (%gf-dcode f) dcode)
     2549        (clear-gf-dispatch-table dt))))))
    25362550
    25372551;;; If there's a single method (with standard method combination) on
  • release/1.6/source/level-1/l1-dcode.lisp

    r14119 r14864  
    182182(defun clear-gf-cache (gf)
    183183  #-bccl (unless t (typep gf 'standard-generic-function)
    184            (report-bad-arg gf 'standard-generic-function))
     184                 (report-bad-arg gf 'standard-generic-function))
    185185  (let ((dt (%gf-dispatch-table gf)))
    186     (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*)
    187       (clear-gf-dispatch-table dt)
    188       (let ((new (make-gf-dispatch-table)))
    189         (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt))
    190         (setf (%gf-dispatch-table-precedence-list new)
    191               (%gf-dispatch-table-precedence-list dt))
    192         (setf (%gf-dispatch-table-gf new) gf)
    193         (setf (%gf-dispatch-table-keyvect new)
    194               (%gf-dispatch-table-keyvect dt))
    195         (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt))
    196         (setf (%gf-dispatch-table gf) new)))))
     186    (unless (< (%gf-dispatch-table-argnum dt) 0) ;reader-method optimization
     187      (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*)
     188        (clear-gf-dispatch-table dt)
     189        (let ((new (make-gf-dispatch-table)))
     190          (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt))
     191          (setf (%gf-dispatch-table-precedence-list new)
     192                (%gf-dispatch-table-precedence-list dt))
     193          (setf (%gf-dispatch-table-gf new) gf)
     194          (setf (%gf-dispatch-table-keyvect new)
     195                (%gf-dispatch-table-keyvect dt))
     196          (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt))
     197          (setf (%gf-dispatch-table gf) new))))))
    197198
    198199(defun %gf-dispatch-table-store-conditional (dt index new)
Note: See TracChangeset for help on using the changeset viewer.