Changeset 14860 for trunk/source/level-1


Ignore:
Timestamp:
Jul 2, 2011, 10:37:33 AM (8 years ago)
Author:
gb
Message:

In CLEAR-GF-CACHE, don't do anything if the dispatch table's
ARGNUM slot has a negative value.

In %SNAP-READER-METHOD, if the gf's dispatch table's argnum
is non-negative, complement it and store the gf's dcode in
the dt's GENERIC-FUNCTION slot.

In PESSIMIZE-CLOS, if a GF's dispatch-table's argnum is negative,
complement it and set the gf's dcode to the value saved in the
dispatch-table's GENERIC-FUNCTION slot. (We can't use COMPUTE-DCODE
to restore the GF's dcode, since it calls slot accessors, possibly
including the one that we're modifying in a non-atomic way.)

It's not clear that PESSIMIZE-CLOS has to deal with anything but
snapped reader methods; DCODE-FOR-UNIVERSALLY-APPLICABLE-SINGLETON
looks like it was half-finished. If we do things like that, we may
need to adopt and follow similar conventions to allow it to be undone,

Location:
trunk/source/level-1
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-clos.lisp

    r14558 r14860  
    21372137                        do (note-class-dependent c f)))
    21382138                (clear-gf-dispatch-table dt)
    2139                 (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
     2139                (let* ((argnum (%gf-dispatch-table-argnum dt)))
     2140                  (unless (< argnum 0)
     2141                    (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
     2142                          (%gf-dispatch-table-gf dt) (%gf-dcode f))))
     2143                   
    21402144                (cond ((null (cdr alist))
    21412145                       ;; Method is only applicable to a single class.
     
    25312535  ;; Un-snap reader methods, undo other GF optimizations.
    25322536  (dolist (f (population-data %all-gfs%))
    2533     (let* ((dt (%gf-dispatch-table f)))
    2534       (clear-gf-dispatch-table dt)
    2535       (compute-dcode f))))
     2537    (let* ((dt (%gf-dispatch-table f))
     2538           (argnum (%gf-dispatch-table-argnum dt)))
     2539      (when (< argnum 0)
     2540        (let* ((dcode (%gf-dispatch-table-gf dt)))
     2541          (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
     2542                (%gf-dispatch-table-gf dt) f
     2543                (%gf-dcode f) dcode)
     2544        (clear-gf-dispatch-table dt))))))
    25362545
    25372546;;; If there's a single method (with standard method combination) on
  • trunk/source/level-1/l1-dcode.lisp

    r14558 r14860  
    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.