Ignore:
Timestamp:
Jun 27, 2008, 6:28:43 PM (11 years ago)
Author:
gz
Message:

Made loading a file not forget encapsulations. (The old behavior can be
restored by setting ccl::*loading-removes-encapsulation* to true).

Added new keyword arg to ADVISE - :dynamic-extent-arglist, if true, declares the
advised arglist to be dynamic-extent, this can be used to minimize runtime
consing when the advice form doesn't save the arglist outside the dynamic extent
of the invocation.

Changed how encapsulation (i.e. tracing and advising) of generic functions
works. Before, the encapsulating function would be installed as the dcode and
then try to guess what the gf code used to do in order to invoke the original
dcode. Now, we just save a copy of the original gf code and jump to it. This
way encapsulation is isolated from having to know details of how the dcode and
the gf interact.

Made (setf %gf-dcode) also update the GF function code to match the dcode. This
is now the only place that has knowledge of how to do that.

register-dcode-proto for %%1st-arg-dcode and %%nth-arg-dcode, since *gf-proto*
is no longer the default.

Also while in there, I consolidated and rearranged some of the encapsulation
recording, hopefully without introducing too many bugs (or at least none that
will be hard to fix).

File:
1 edited

Legend:

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

    r9837 r9844  
    540540;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    541541
    542 (%fhave 'function-encapsulation ;Redefined in encapsulate
    543         (qlfun bootstrapping-function-encapsulation (name)
    544           (declare (ignore name))
    545           nil))
    546 
    547542(%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate
    548543        (qlfun boot-%move-method-encapsulations-maybe (m1 m2)
     
    550545          nil))
    551546
    552 
    553547(%fhave 'find-unencapsulated-definition  ;Redefined in encapsulate
    554         (qlfun bootstrapping-unenecapsulated-def (spec)
    555           (values
    556            (typecase spec
    557              (symbol (fboundp spec))
    558              (method (%method-function spec))
    559              (t spec))
    560            spec)))
     548        (qlfun bootstrapping-find-unencapsulated-definition (fn)
     549          fn))
     550
     551(%fhave 'function-encapsulated-p  ;Redefined in encapsulate
     552        (qlfun bootstrapping-function-encapsulated-p (fn)
     553          (declare (ignore fn))
     554          nil))
    561555
    562556(let* ((class-wrapper-random-state (make-random-state))
     
    570564
    571565(defun %inner-method-function (method)
    572   (let ((f (%method-function method)))
    573     (when (function-encapsulation f)
    574       (setq f (find-unencapsulated-definition f)))
    575     (closure-function f)))
    576 
     566  (closure-function
     567   (find-unencapsulated-definition
     568    (%method-function method))))
    577569
    578570(defun copy-method-function-bits (from to)
     
    711703       
    712704
    713 (defun forget-encapsulations (name)
    714   (declare (ignore name))
    715   nil)
    716 
    717705(defun %anonymous-method (function specializers qualifiers  lambda-list &optional documentation
    718706                                   &aux name method-class)
     
    779767  (setq method-function
    780768        (closure-function
    781          (if (function-encapsulation method-function)
    782            (find-unencapsulated-definition method-function)
    783            method-function)))
     769         (find-unencapsulated-definition method-function)))
    784770  (setq method-function (require-type method-function 'method-function))
    785771  (lfun-name method-function))
     
    10961082                  multi-method-index)
    10971083                0))
    1098         (let* ((old-dcode (%gf-dcode gf))
    1099                (encapsulated-dcode-cons (and (combined-method-p old-dcode)
    1100                                              (eq '%%call-gf-encapsulation
    1101                                                  (function-name (%combined-method-dcode old-dcode)))
    1102                                              (cdr (%combined-method-methods old-dcode)))))
    1103           (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
     1084        (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf))))
     1085          (when (or non-dt
     1086                    (neq dcode old-dcode)
    11041087                    (neq multi-method-index (%gf-dispatch-table-argnum dt)))
    1105             (let* ((proto (if non-dt
    1106                             #'funcallable-trampoline
    1107                             (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*))))
    1108               (clear-gf-dispatch-table dt)
    1109               (setf (%gf-dispatch-table-argnum dt) multi-method-index)
    1110               (if encapsulated-dcode-cons ; and more?
    1111                 (let ((old-gf (car encapsulated-dcode-cons)))
    1112                   (if (not (typep old-gf 'generic-function))
    1113                     (error "Confused"))
    1114                   ;(setf (uvref old-gf 0)(uvref proto 0))
    1115                   (setf (cdr encapsulated-dcode-cons) dcode))
    1116                 (progn
    1117                   (setf (%gf-dcode gf) dcode)
    1118                   (replace-function-code gf proto))))))
     1088            (clear-gf-dispatch-table dt)
     1089            (setf (%gf-dispatch-table-argnum dt) multi-method-index)
     1090            (if (function-encapsulated-p gf)
     1091              (%set-encapsulated-gf-dcode gf dcode)
     1092              (setf (%gf-dcode gf) dcode))))
    11191093        (values dcode multi-method-index)))))
    11201094
Note: See TracChangeset for help on using the changeset viewer.