Changeset 9847


Ignore:
Timestamp:
Jun 29, 2008, 1:53:46 AM (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.

Made untrace/unadvise more tolerant of bindings changing behind their backs.

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.

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).

Location:
branches/working-0711/ccl
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/PPC/ppc-def.lisp

    r9365 r9847  
    12381238    (%copy-gvector-to-gvector proto 0 newv 0 uvsize)))
    12391239
     1240(defun %copy-function (proto &optional target)
     1241  (let* ((total-size (uvsize proto))
     1242         (new (or target (allocate-typed-vector :function total-size))))
     1243    (declare (fixnum total-size))
     1244    (when target
     1245      (unless (eql total-size (uvsize target))
     1246        (error "Wrong size target ~s" target)))
     1247    (%copy-gvector-to-gvector proto 0 new 0 total-size)
     1248    new))
     1249
    12401250(defun replace-function-code (target-fn proto-fn)
    12411251  (if (typep target-fn 'function)
  • branches/working-0711/ccl/level-0/X86/x86-def.lisp

    r9578 r9847  
    113113      (setf (%svref newv k) (car imms)))))
    114114
    115 (defun %copy-function (proto)
     115(defun %copy-function (proto &optional target)
    116116  (let* ((protov (%function-to-function-vector proto))
    117117         (code-words (%function-code-words proto))
    118          (uvsize (uvsize protov))
    119          (newv (allocate-typed-vector :function uvsize)))
    120     (declare (fixnum code-words uvsize))
     118         (total-words (uvsize protov))
     119         (newv (if target
     120                 (%function-to-function-vector target)
     121                 (allocate-typed-vector :function total-words))))
     122    (declare (fixnum code-words total-words))
     123    (when target
     124      (unless (and (eql code-words (%function-code-words target))
     125                   (eql total-words (uvsize newv)))
     126        (error "Wrong size target ~s" target)))
    121127    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
    122     (loop for k fixnum from code-words below uvsize
    123           do (setf (%svref newv k) (%svref protov k)))
     128    (loop for k fixnum from code-words below total-words
     129      do (setf (%svref newv k) (%svref protov k)))
    124130    (%function-vector-to-function newv)))
    125131
  • branches/working-0711/ccl/level-0/l0-def.lisp

    r8867 r9847  
    7979(%fhave 'encapsulated-function-name  ;Redefined in encapsulate - used in l1-io
    8080        (qlfun bootstrapping-encapsulated-function-name (fn)
    81           (declare (ignore fn))
    82           nil))
    83 
    84 (%fhave '%traced-p  ;Redefined in encapsulate - used in l1-io
    85         (qlfun bootstrapping-%traced-p (fn)
    86           (declare (ignore fn))
    87           nil))
    88 
    89 (%fhave '%advised-p  ;Redefined in encapsulate used in l1-io
    90         (qlfun bootstrapping-%advised-p (fn)
    9181          (declare (ignore fn))
    9282          nil))
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r9830 r9847  
    575575;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    576576
    577 (%fhave 'function-encapsulation ;Redefined in encapsulate
    578         (qlfun bootstrapping-function-encapsulation (name)
    579           (declare (ignore name))
    580           nil))
    581 
    582577(%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate
    583578        (qlfun boot-%move-method-encapsulations-maybe (m1 m2)
     
    585580          nil))
    586581
    587 
    588582(%fhave 'find-unencapsulated-definition  ;Redefined in encapsulate
    589         (qlfun bootstrapping-unenecapsulated-def (spec)
    590           (values
    591            (typecase spec
    592              (symbol (fboundp spec))
    593              (method (%method-function spec))
    594              (t spec))
    595            spec)))
     583        (qlfun bootstrapping-find-unencapsulated-definition (fn)
     584          fn))
     585
     586(%fhave 'function-encapsulated-p  ;Redefined in encapsulate
     587        (qlfun bootstrapping-function-encapsulated-p (fn)
     588          (declare (ignore fn))
     589          nil))
    596590
    597591(defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil
     
    600594   profiling")
    601595
    602 
    603596(let* ((class-wrapper-random-state (make-random-state))
    604597       (class-wrapper-random-state-lock (make-lock)))
     
    611604
    612605(defun %inner-method-function (method)
    613   (let ((f (%method-function method)))
    614     (when (function-encapsulation f)
    615       (setq f (find-unencapsulated-definition f)))
    616     (closure-function f)))
    617 
     606  (closure-function
     607   (find-unencapsulated-definition
     608    (%method-function method))))
    618609
    619610(defun copy-method-function-bits (from to)
     
    757748       
    758749
    759 (defun forget-encapsulations (name)
    760   (declare (ignore name))
    761   nil)
    762 
    763750(defun %anonymous-method (function specializers qualifiers  lambda-list &optional documentation
    764751                                   &aux name method-class)
     
    825812  (setq method-function
    826813        (closure-function
    827          (if (function-encapsulation method-function)
    828            (find-unencapsulated-definition method-function)
    829            method-function)))
     814         (find-unencapsulated-definition method-function)))
    830815  (setq method-function (require-type method-function 'method-function))
    831816  (lfun-name method-function))
     
    11521137                  multi-method-index)
    11531138                0))
    1154         (let* ((old-dcode (%gf-dcode gf))
    1155                (encapsulated-dcode-cons (and (combined-method-p old-dcode)
    1156                                              (eq '%%call-gf-encapsulation
    1157                                                  (function-name (%combined-method-dcode old-dcode)))
    1158                                              (cdr (%combined-method-methods old-dcode)))))
    1159           (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
     1139        (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf))))
     1140          (when (or non-dt
     1141                    (neq dcode old-dcode)
    11601142                    (neq multi-method-index (%gf-dispatch-table-argnum dt)))
    1161             (let* ((proto (if non-dt
    1162                             #'funcallable-trampoline
    1163                             (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*))))
    1164               (clear-gf-dispatch-table dt)
    1165               (setf (%gf-dispatch-table-argnum dt) multi-method-index)
    1166               (if encapsulated-dcode-cons ; and more?
    1167                 (let ((old-gf (car encapsulated-dcode-cons)))
    1168                   (if (not (typep old-gf 'generic-function))
    1169                     (error "Confused"))
    1170                                         ;(setf (uvref old-gf 0)(uvref proto 0))
    1171                   (setf (cdr encapsulated-dcode-cons) dcode))
    1172                 (progn
    1173                   (setf (%gf-dcode gf) (dcode-for-gf gf dcode))
    1174                   (replace-function-code gf proto))))))
     1143            (clear-gf-dispatch-table dt)
     1144            (setf (%gf-dispatch-table-argnum dt) multi-method-index)
     1145            (if (function-encapsulated-p gf)
     1146              (%set-encapsulated-gf-dcode gf dcode)
     1147              (setf (%gf-dcode gf) dcode))))
    11751148        (values dcode multi-method-index)))))
    11761149
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r9775 r9847  
    14651465(defmethod initialize-instance :before ((instance generic-function)
    14661466                                       &key &allow-other-keys)
    1467 
    1468   (replace-function-code instance *gf-proto*)
    1469   (setf (gf.dcode instance) (dcode-for-gf instance #'%%0-arg-dcode)))
    1470        
    1471                                        
     1467  (setf (%gf-dcode instance)  #'%%0-arg-dcode))
    14721468
    14731469(defmethod initialize-instance :after ((gf standard-generic-function)
     
    17341730  (unless (functionp function)
    17351731    (error "~S is not a function" function))
    1736   (replace-function-code funcallable-instance #'funcallable-trampoline)
    1737   (setf (gf.dcode funcallable-instance) function))
     1732  (setf (%gf-dcode funcallable-instance) function))
    17381733
    17391734(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys)
     
    21082103                              (t
    21092104                               #'%%1st-arg-eql-method-hack-dcode))))))
    2110  
    2111  
    2112 
    21132105
    21142106(defun maybe-hack-eql-methods (gf)
  • branches/working-0711/ccl/level-1/l1-dcode.lisp

    r9578 r9847  
    488488  (gf.dcode gf))
    489489
    490 (defun %set-gf-dcode (gf val)
    491   (setf (gf.dcode gf) val))
     490(defun %set-gf-dcode (gf dcode)
     491  (let ((gf (require-type gf 'funcallable-standard-object))
     492        (dcode (require-type dcode 'function)))
     493    (replace-function-code gf (or (cdr (assq dcode dcode-proto-alist))
     494                                  #'funcallable-trampoline))
     495    (setf (gf.dcode gf) dcode)))
    492496
    493497(defun %set-gf-dispatch-table (gf val)
    494498  (setf (gf.dispatch-table gf) val))
    495 
    496499
    497500(defun %combined-method-methods  (cm)
     
    832835        (%apply-lexpr-tail-wise method args)))))
    833836(register-dcode-proto #'%%nth-arg-dcode *gf-proto*)
    834 
    835837
    836838(defun 0-arg-combined-method-trap (gf)
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r8867 r9847  
    234234  "This function simply returns what was passed to it."
    235235  x)
    236 
    237 (%fhave 'find-unencapsulated-definition #'identity)
    238236
    239237(defun coerce-to-function (arg)
  • branches/working-0711/ccl/lib/edit-callers.lisp

    r4123 r9847  
    135135      (pascal-function-p function)
    136136      (let ((name (function-name function)))
    137         (and name (function-encapsulation name) name))
     137        (and name (function-encapsulated-p name) name))
    138138      (let ((caller function) next)
    139139        (loop
    140140          (setq next (gethash caller *function-parent-table*))
    141           (if  next           
     141          (if  next
    142142            (cond ((consp next)
    143143                   (when (null the-list)(push function the-list))
  • branches/working-0711/ccl/lib/encapsulate.lisp

    r9578 r9847  
    1717(in-package "CCL")
    1818
    19 ;; Lets try encapsulations
    20 ;; trace is here too
    21 ;; Make trace like 1.3, trace methods, trace (setf car)
    22 
    23 
    24 (defvar *trace-alist* nil)
     19(defvar *loading-removes-encapsulation* nil
     20  "If true, loading a new method definition from a file will remove any tracing and advice on the method")
     21
    2522(defvar *trace-pfun-list* nil)
    2623(defvar *trace-enable* t)
     
    3532(defvar *trace-print-hook* nil)
    3633
    37 
    38 (defvar *advise-alist* nil)
     34;;;
     35;;;  We support encapsulating three types of objects, i.e. modifying their definition
     36;;;  without changing their identity:
     37;;;    1. symbol - via the symbol-function slot
     38;;;    2. method - via the %method-function slot
     39;;;    3. standard-generic-function - via the %gf-dcode slot
     40;;;
     41;;; Encapsulation is effected by creating a new compiled function and storing it in the
     42;;; slot above. The new function references a gensym fbound to the original definition
     43;;; (except in the case of a gf, the gensym is fbound to a copy of the gf which in
     44;;; turn contains the original dcode, since we can't invoke the dcode directly).
     45;;; In addition, an ENCAPSULATION struct describing the encapsulation is created and
     46;;; stored in the *encapsulation-table* with the new compiled function as the key.
     47;;;
     48;;;
    3949
    4050(defparameter *encapsulation-table*
    41   (make-hash-table :test #'eq :rehash-size 2 :size 2))
     51  (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t))
    4252
    4353(defstruct (encapsulation)
     
    4757  advice-name    ; optional
    4858  advice-when    ; :before, :after, :around
    49   owner          ; where encapsulation is installed
     59  owner          ; where encapsulation is installed (can change)
    5060)
     61
     62(defun encapsulation-old-def (cap)
     63  (fboundp (encapsulation-symbol cap)))
    5164
    5265(defun setf-function-spec-name (spec)
     
    5669    spec))
    5770
    58 
    5971(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*)))
    6072  (fresh-line *trace-output*)
     
    6274    (declare (fixnum i))
    6375    (write-char (if (and *trace-bar-frequency*
    64                         (eq 0 (mod i *trace-bar-frequency*)))
    65                   #\| #\Space) *trace-output*))
     76                        (eq 0 (mod i *trace-bar-frequency*)))
     77                  #\| #\Space) *trace-output*))
    6678  (if (eq direction :in)
    6779    (format *trace-output* "~d> " (1- *trace-level*))
     
    98110    (format t "~%... Untracing ~a" name)
    99111    (%untrace-1 name))
    100   (when (%advised-p name nil nil t)
     112  (when (%advised-p name)
    101113    (format t "~%... Unadvising ~a" name)
    102     (unadvise-1 name))
     114    (%unadvise-1 name))
    103115  nil)
    104116
    105117(defun function-encapsulated-p (fn-or-method)
    106   (typecase fn-or-method
    107     ((or method symbol cons)(function-encapsulation fn-or-method))
    108     (function
    109      (or (function-traced-p fn-or-method)
    110          (function-advised-p fn-or-method )))))
    111 
    112 (defun function-traced-p (fn)
    113   (%function-in-alist fn *trace-alist*))
    114 
    115 (defun function-advised-p (fn)
    116   (%function-in-alist fn *advise-alist*))                           
    117 
    118 (defun %function-in-alist (def list)
    119   (dolist (cap list)
    120     (let ((symbol (encapsulation-owner cap)))
    121       (typecase symbol
    122         (symbol (when (eq (fboundp symbol) def)
    123                   (return cap)))
    124         (method (when (eq (%method-function symbol) def)
    125                   (return cap)))
    126         (standard-generic-function
    127          (when (eq symbol def) (return cap)))))))
    128 
    129 (defun function-encapsulation (spec)
    130   (typecase spec
    131     ((or symbol method)
    132      (gethash spec *encapsulation-table*))
    133     (function (function-encapsulated-p spec))
    134     (cons (gethash (setf-function-spec-name spec) *encapsulation-table*))))
    135 ;; i.e. old 68K clos - vs 68K target with new clos
    136 
    137 
    138 
    139 
    140 ; she works now - does the equivalent of the original gf - called from traced def
    141 (defun %%call-encapsulated-gf (thing args)
    142   ;; (print 'one)(print thing)(print args)
    143   ;; thing is gf . %%1st-arg-dcode
    144   ;; args is ok
    145   (let* ((dcode (cdr thing))
    146          (proto (cdr (assq dcode dcode-proto-alist))))  ; <<
    147     ;; There are only 3 trampoline prototypes that pass a dispatch
    148     ;; table; of these, *GF-PROTO* passes the dispatch table and
    149     ;; args (lexpr or list), while the other two pass the dispatch
    150     ;; table and either 1 or 2 additional args.
    151     (if proto
    152       ;; If the dcode has an entry on dcode-proto-alist, assume
    153       ;; that it wants the dispatch table as its first arg.
    154       (let* ((dt (%gf-dispatch-table (car thing))))
    155         (if (eq proto *gf-proto*)
    156           ;; The dcode wants all of the args that the gf was called
    157           ;; with all incoming args collected into a list or lexpr, as
    158           ;; well as the dt.
    159           (funcall dcode dt args)
    160           ;; The one-arg or two-arg trampoline would have already
    161           ;; ensured that the GF was called with the right number
    162           ;; of fixed args, but we haven't been down that path yet.
    163           ;; There are only the 1-arg and 2-arg cases to check.
    164           (let* ((nargs (if (listp args) (length args) (%lexpr-count args))))
    165             (declare (fixnum nargs))
    166             (if (eq proto *gf-proto-one-arg*)
    167               (if (= nargs 1)
    168                 (funcall dcode dt (if (listp args) (car args) (%lexpr-ref args 1 0)))
    169                 (error (if (< nargs 1) 'too-few-arguments 'too-many-arguments)
    170                        :nargs nargs
    171                        :fn (%gf-dispatch-table-gf dt)))
    172               (if (= nargs 2)
    173                 (funcall dcode
    174                          dt
    175                          (if (listp args) (car args) (%lexpr-ref args 2 0))
    176                          (if (listp args) (cadr args) (%lexpr-ref args 2 1)))
    177 
    178                 (error (if (< nargs 2) 'too-few-arguments 'too-many-arguments)
    179                        :nargs nargs
    180                        :fn (%gf-dispatch-table-gf dt)))))))
    181       (if (listp args)
    182         (apply dcode args)
    183         (%apply-lexpr dcode args)))))
    184    
    185 
    186 
    187 ;; the dcode function of the original gf has been bashed with a combined method whose
    188 ;; dcode function is this. So the combined method is called with 2 args (dispatch-table
    189 ;; and args to the gf). The combined method in turn makes a lexpr of those 2 args.
    190 
    191 (defun %%call-gf-encapsulation (thing args)
    192   ; (print 'two)(print thing)(print (if (listp args) args (collect-lexpr-args args 0)))
    193   ; thing traced-blitz  gf-blitz . %%1st-arg-dcode 
    194   ; args = dispatch-table . original-args
    195   ;  dont need dispatch-table - its just there as a side effect
    196   (if (listp args)  ; this probably never happens
    197     (let ((orig-args (cadr args)))
    198       (if (listp orig-args)
    199         (apply (car thing) orig-args)
    200         (%apply-lexpr (car thing) orig-args)))
    201     (let* ((orig-args (%lexpr-ref args (%lexpr-count args) 1)))
    202       (if (listp orig-args)
    203         (apply (car thing) orig-args)
    204         ; knee deep in lexprs
    205         (%apply-lexpr (car thing) orig-args)))))
    206    
    207 
    208 (defun encapsulate (fn-spec old-def type trace-spec newsym
    209                             &optional advice-name advice-when)
    210   (let ((capsule (function-encapsulation fn-spec))
    211         gf-dcode old-encapsulation)
    212     (%fhave newsym
    213             (if (standard-generic-function-p old-def)
    214               (let ((dcode (%gf-dcode old-def)))
    215                 (setq gf-dcode
    216                       (if (and (combined-method-p dcode)
    217                                (eq '%%call-gf-encapsulation
    218                                    (function-name (%combined-method-dcode dcode))))
    219                         (let ((stuff (%combined-method-methods dcode)))
    220                           (setq old-encapsulation (car stuff))
    221                           (cdr stuff))
    222                         (cons old-def dcode)))
    223                 (replace-function-code old-def *gf-proto*)  ; <<  gotta remember to fix it
    224                 (or old-encapsulation
    225                     (%cons-combined-method old-def gf-dcode #'%%call-encapsulated-gf)))
    226               old-def))                 ; make new symbol call old definition
    227     ;; move the encapsulation from fn-spec to sym   
    228     (cond (capsule (put-encapsulation newsym capsule)))   
    229     (put-encapsulation fn-spec
    230                        (make-encapsulation
    231                         :symbol newsym
    232                         :type type
    233                         :spec trace-spec
    234                         :advice-name advice-name
    235                         :advice-when advice-when))
    236     (values newsym gf-dcode)))
    237  
    238 
    239 ;; call with cap nil to remove - for symbol anyway
    240 ;; maybe advising methods is silly - just define a before method
    241 
    242 (defun put-encapsulation (spec cap)
    243   (when cap
    244     (setf (encapsulation-owner cap) spec)
    245     (record-encapsulation cap)
    246     )
    247   (let ((key (typecase spec
    248                ((or symbol method standard-generic-function) spec)
    249                (cons (setf-function-spec-name spec))
    250                (t (report-bad-arg spec '(or symbol method cons))))))
    251     (if cap
    252       (setf (gethash key *encapsulation-table*) cap)
    253       (remhash key *encapsulation-table*)))
    254   cap)
    255 
    256 (defun remove-encapsulation (capsule &optional dont-replace)
    257   ; optional don't replace is for unadvising, tracing all on a method
    258   (let (spec nextsym newdef def)
    259     (setq spec (encapsulation-owner capsule))
    260     (setq def (typecase spec
    261                 (symbol (fboundp spec))
    262                 (method spec)))
    263     (setq nextsym (encapsulation-symbol capsule))
    264     (setq newdef (fboundp nextsym))
    265     (without-interrupts
    266      (if (standard-generic-function-p def)
    267        (if (and (combined-method-p newdef)
    268                 (eq '%%call-encapsulated-gf (function-name (%combined-method-dcode newdef))))
    269          (let* ((orig-decode (require-type (cdr (%combined-method-methods newdef)) 'function))
    270                 (proto (cdr (assq orig-decode dcode-proto-alist)))
    271                 ) ; <<
    272            (setf (%gf-dcode def) orig-decode)
    273            (replace-function-code def (or proto #'funcallable-trampoline)))
    274          (setf (car (%combined-method-methods (%gf-dcode def))) newdef))
    275        (typecase spec
    276          (symbol (%fhave spec newdef))
    277          (method (setf (%method-function spec) newdef)
    278                  (remove-obsoleted-combined-methods spec)
    279                  newdef)))
    280      (put-encapsulation spec
    281                         (if (null dont-replace)
    282                           (function-encapsulation nextsym)))
    283      (put-encapsulation nextsym nil)
    284      (unrecord-encapsulation capsule)
    285      )))
    286 
    287 
    288 (defun record-encapsulation (capsule)
    289   (ecase (encapsulation-type capsule)
    290     (trace
    291      (when (not (memq capsule *trace-alist*))
    292        (push capsule *trace-alist*)))
    293     (advice
    294      (when (not (memq capsule *advise-alist*))
    295        (push capsule *advise-alist*)))))
    296 
    297 (defun unrecord-encapsulation (capsule)
    298   (ecase (encapsulation-type capsule)
    299     (trace
    300       (setq *trace-alist* (delq capsule *trace-alist*)))
    301     (advice
    302      (setq *advise-alist* (delq capsule *advise-alist*)))))
    303 
    304 
    305 (defun find-unencapsulated-definition (spec)
    306   ;; spec is a symbol, function, or method object
    307   ;; returns a raw function ??
    308   (let (foo)
    309     (while (setq foo (function-encapsulation spec))
    310       (setq spec (encapsulation-symbol foo)))
    311     (values
    312     (typecase spec
    313       (symbol (fboundp spec))
    314       (method (%method-function spec))
    315       (t spec))
    316     spec)))
    317 
    318 (defun %trace-fboundp (spec)
    319   (typecase spec
    320     (symbol (fboundp spec))
    321     (method (%method-function spec))))
    322 
    323 
    324 (defun %trace-function-spec-p (spec &optional define-if-not undefined-ok (error-p t))
    325   ;; weed out macros and special-forms
     118  (get-encapsulation fn-or-method))
     119
     120(defun %encap-fboundp (thing)
     121  (etypecase thing
     122    (symbol (fboundp thing))
     123    (method (%method-function thing))))
     124 
     125(defun %encap-binding (thing)
     126  (require-type (etypecase thing
     127                  (symbol (fboundp thing))
     128                  (method (%method-function thing)))
     129                'function))
     130
     131(defun get-encapsulation (spec)
     132  (let* ((key (typecase spec
     133                (symbol (let* ((def (fboundp spec)))
     134                          (if (generic-function-p def)
     135                            (%gf-dcode def)
     136                            def)))
     137                (method (%method-function spec))
     138                (standard-generic-function (%gf-dcode spec))
     139                (function spec)))
     140         (cap (gethash key *encapsulation-table*)))
     141    #+gz (assert (or (null cap)
     142                     (let ((fn (%encap-binding (encapsulation-owner cap))))
     143                       (eq (if (standard-generic-function-p fn) (%gf-dcode fn) fn) key))))
     144    cap))
     145
     146(defun set-encapsulation-owner (fn owner)
     147  (let ((cap (get-encapsulation fn)))
     148    (when cap
     149      (setf (encapsulation-owner cap) owner))))
     150
     151(defun put-encapsulation (fn cap)
     152  (let* ((owner (encapsulation-owner cap))
     153         (old-def (%encap-binding owner))
     154         (newsym (encapsulation-symbol cap)))
     155    (setf (gethash fn *encapsulation-table*) cap)
     156    (set-encapsulation-owner old-def newsym)
     157    (etypecase owner
     158      (symbol
     159       (cond ((standard-generic-function-p old-def)
     160              (%fhave newsym (%copy-function old-def))
     161              (setf (%gf-dcode old-def) fn))
     162             (t
     163              (%fhave newsym old-def)
     164              (%fhave owner fn))))
     165      (method
     166       (%fhave newsym old-def)
     167       (setf (%method-function owner) fn)
     168       (remove-obsoleted-combined-methods owner)))))
     169
     170(defun remove-encapsulation (cap)
     171  (let* ((owner (encapsulation-owner cap))
     172         (cur-def (%encap-fboundp owner))
     173         (old-def (encapsulation-old-def cap)))
     174    (typecase owner
     175      (symbol
     176       (cond ((or (null cur-def)
     177                  (not (eq cap (get-encapsulation cur-def))))
     178              ;; rebound behind our back, oh well.
     179              nil)
     180             ((standard-generic-function-p cur-def)
     181              (remhash (%gf-dcode cur-def) *encapsulation-table*)
     182              (set-encapsulation-owner old-def owner)
     183              (setf (%gf-dcode cur-def) (%gf-dcode old-def)))
     184             (t
     185              (remhash cur-def *encapsulation-table*)
     186              (set-encapsulation-owner old-def owner)
     187              (%fhave owner old-def))))
     188      (method
     189       (remhash cur-def *encapsulation-table*)
     190       (set-encapsulation-owner old-def owner)
     191       (setf (%method-function owner) old-def)
     192       (remove-obsoleted-combined-methods owner)))))
     193
     194
     195(defun encapsulate (owner newdef type trace-spec newsym &optional advice-name advice-when)
     196  (let ((cap (make-encapsulation
     197              :owner owner
     198              :symbol newsym
     199              :type type
     200              :spec trace-spec
     201              :advice-name advice-name
     202              :advice-when advice-when)))
     203    (put-encapsulation newdef cap)
     204    cap))
     205
     206(defun find-unencapsulated-definition (fn)
     207  (when fn
     208    (loop for cap = (get-encapsulation fn) while cap
     209      do (setq fn (encapsulation-old-def cap)))
     210    fn))
     211
     212(defun set-unencapsulated-definition (cap newdef)
     213  (loop for owner = (encapsulation-symbol cap)
     214    do (setq cap (get-encapsulation owner)) while cap
     215    finally (%fhave owner newdef)))
     216
     217(defun %encapsulation-thing (spec &optional define-if-not (error-p t))
     218  ;; Returns either an fboundp symbol or a method, or nil.
    326219  (typecase spec
    327220    (symbol
    328      (if (or (null spec)(special-operator-p spec)(macro-function spec))
     221     ;; weed out macros and special-forms
     222     (if (or (null spec) (special-operator-p spec) (macro-function spec))
    329223       (if error-p
    330          (error "Cannot trace or advise ~S" spec)
    331          (values nil nil))
    332        (let ((res (or (fboundp spec)(and define-if-not
    333                                          (progn (warn "~S was undefined" spec)
    334                                                 (%fhave spec (%function 'trace-null-def)))))))
    335          (if res
    336            (values res spec)
    337            (if undefined-ok
    338              (values nil spec)
    339              (if error-p
    340                (error "~S is undefined." spec)
    341                (values nil nil)))))))
    342     (method
    343      (values (%method-function spec) spec))
     224         (error "Cannot trace or advise ~a~S" spec
     225                (cond ((null spec) "")
     226                      ((special-operator-p spec) "special operator ")
     227                      (t "macro ")))
     228         nil)
     229       (if (or (fboundp spec)
     230               (and define-if-not
     231                    (progn
     232                      (warn "~S was undefined" spec)
     233                      (%fhave spec (%function 'trace-null-def))
     234                      t)))
     235         spec
     236         (if error-p
     237           (error "~S is undefined." spec)
     238           nil))))
     239    (method spec)
    344240    (cons
    345241     (case (car spec)
     
    354250            (cond ((setq method
    355251                         (find-method-by-names gf qualifiers specializers))
    356                    (return (values (%method-function method) method)))
     252                   (return method))
    357253                  (define-if-not
    358254                    (when (define-undefined-method spec gf qualifiers specializers)
    359255                      (go AGN)))
    360256                  (t (if error-p
    361                        (error "Method ~s qualifiers ~s specializers ~s not found."
    362                               gf qualifiers specializers)
    363                        (return (values nil nil))))))))
     257                       (error "Method ~s qualifiers ~s specializers ~s not found."
     258                              gf qualifiers specializers)
     259                       (return nil)))))))
    364260       (setf
    365261        (let ((name-or-fn (setf-function-spec-name spec)))
    366           (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn))
     262          (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
    367263                ((functionp name-or-fn) ; it's anonymous - give it a name
    368264                 (let ((newname (gensym)))
    369265                   (%fhave newname name-or-fn)
    370266                   (store-setf-method (cadr spec) newname)
    371                    (values name-or-fn newname))))))))
     267                   newname)))))))
    372268    (t (if error-p
    373          (error "Invalid trace spec ~s" spec)
    374          (values nil nil)))))
    375    
     269         (error "Invalid trace spec ~s" spec)
     270         nil))))
    376271
    377272(defun trace-null-def (&rest ignore)
     
    406301    (when (eq (symbol-package sym) pkg)
    407302      (when (traceable-symbol-p sym)
    408         (apply #'trace-function sym args))
     303        (apply #'trace-function sym args))
    409304      (when (or (%setf-method sym)
    410                 ;; Not really right.  Should construct the name if doesn't exist.
    411                 ;; But that would create a lot of garbage for little gain...
    412                 (let ((name (existing-setf-function-name sym)))
     305                ;; Not really right.  Should construct the name if doesn't exist.
     306                ;; But that would create a lot of garbage for little gain...
     307                (let ((name (existing-setf-function-name sym)))
    413308                  (traceable-symbol-p name)))
    414         (apply #'trace-function `(setf ,sym) args)))))
     309        (apply #'trace-function `(setf ,sym) args)))))
    415310
    416311(defun trace-print-body (print-form)
     
    418313    (if (and (consp print-form) (eq (car print-form) 'values))
    419314      `((mapcar #'(lambda (name object)
    420                     (trace-tab :in)
    421                     (format *trace-output* "~s = ~s" name object))
    422         ',(cdr print-form)
    423         (list ,@(cdr print-form))))
     315                    (trace-tab :in)
     316                    (format *trace-output* "~s = ~s" name object))
     317        ',(cdr print-form)
     318        (list ,@(cdr print-form))))
    424319      `((let ((objects (multiple-value-list ,print-form))
    425               (i -1))
    426           (if (and objects (not (cdr objects)))
    427             (progn
    428               (trace-tab :in)
    429               (format *trace-output* "~s = ~s" ',print-form (car objects)))
    430             (dolist (object objects)
    431               (trace-tab :in)
    432               (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
     320              (i -1))
     321          (if (and objects (not (cdr objects)))
     322            (progn
     323              (trace-tab :in)
     324              (format *trace-output* "~s = ~s" ',print-form (car objects)))
     325            (dolist (object objects)
     326              (trace-tab :in)
     327              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
    433328
    434329(defun trace-backtrace-body (test-form)
    435330  (when test-form
    436331    `((let ((test ,test-form))
    437         (when test
    438           (multiple-value-bind (detailed-p count)
    439               (cond ((memq test '(:detailed :verbose :full))
    440                      (values t nil))
    441                     ((integerp test)
    442                      (values nil test))
    443                     ((and (consp test)
    444                           (keywordp (car test))
    445                           (consp (cdr test))
    446                           (null (cddr test)))
    447                      (values (memq (car test) '(:detailed :verbose :full))
    448                              (and (integerp (cadr test)) (cadr test))))
    449                     (t (values nil nil)))
    450             (let ((*debug-io* *trace-output*))
    451               (print-call-history :detailed-p detailed-p
    452                                   :count (or count most-positive-fixnum))
    453               (terpri *trace-output*))))))))
     332        (when test
     333          (multiple-value-bind (detailed-p count)
     334              (cond ((memq test '(:detailed :verbose :full))
     335                     (values t nil))
     336                    ((integerp test)
     337                     (values nil test))
     338                    ((and (consp test)
     339                          (keywordp (car test))
     340                          (consp (cdr test))
     341                          (null (cddr test)))
     342                     (values (memq (car test) '(:detailed :verbose :full))
     343                             (and (integerp (cadr test)) (cadr test))))
     344                    (t (values nil nil)))
     345            (let ((*debug-io* *trace-output*))
     346              (print-call-history :detailed-p detailed-p
     347                                  :count (or count most-positive-fixnum))
     348              (terpri *trace-output*))))))))
    454349
    455350(defun trace-inside-frame-p (name)
     
    465360                           (when (and sym (eq (symbol-package sym) name))
    466361                             (return-from trace-inside-frame-p t)))))
    467     (let ((fn (typecase name
    468                 (symbol (fboundp name))
    469                 (method (%method-function name)))))
     362    (let ((fn (%encap-binding name)))
    470363      (when fn
    471364        (map-call-frames #'(lambda (p)
     
    524417  (when break
    525418    (setq break-before (if break-before
    526                         `(and ,break ,break-before)
    527                         break))
     419                        `(and ,break ,break-before)
     420                        break))
    528421    (setq break-after (if break-after
    529                         `(and ,break ,break-after)
    530                         break)))
     422                        `(and ,break ,break-after)
     423                        break)))
    531424  (unless backtrace-before
    532425    (setq backtrace-before backtrace))
     
    554447  (when inside
    555448    (let ((tests (loop for spec in inside
    556                        as name = (or (trace-package-spec spec)
    557                                      (nth-value 1 (%trace-function-spec-p spec nil nil nil))
    558                                      (error "Cannot trace inside ~s" spec))
    559                        collect `(trace-inside-frame-p ',name))))
     449                       as name = (or (trace-package-spec spec)
     450                                     (%encapsulation-thing spec nil nil)
     451                                     (error "Cannot trace inside ~s" spec))
     452                       collect `(trace-inside-frame-p ',name))))
    560453      (setq if `(and ,if (or ,@tests)))))
    561454
    562455  (setq eval-before `(,@(trace-print-body print-before)
    563                       ,@(trace-print-body print)
    564                       ,@(and eval-before `(,eval-before))
    565                       ,@(and eval `(,eval))
    566                       ,@(and before `((apply ,before ',spec args)))
    567                       ,@(trace-backtrace-body backtrace-before)
    568                       ,@(and break-before `((when ,break-before
    569                                               (force-output *trace-output*)
    570                                               (break "~s trace entry: ~s" ',spec args))))))
     456                      ,@(trace-print-body print)
     457                      ,@(and eval-before `(,eval-before))
     458                      ,@(and eval `(,eval))
     459                      ,@(and before `((apply ,before ',spec args)))
     460                      ,@(trace-backtrace-body backtrace-before)
     461                      ,@(and break-before `((when ,break-before
     462                                              (force-output *trace-output*)
     463                                              (break "~s trace entry: ~s" ',spec args))))))
    571464  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
    572                      ,@(and after `((apply ,after ',spec vals)))
    573                      ,@(and eval `(,eval))
    574                      ,@(and eval-after `(,eval-after))
    575                      ,@(trace-print-body print)
    576                      ,@(trace-print-body print-after)
    577                      ,@(and break-after `((when ,break-after
    578                                             (force-output *trace-output*)
    579                                             (break "~s trace exit: ~s" ',spec vals))))))
     465                     ,@(and after `((apply ,after ',spec vals)))
     466                     ,@(and eval `(,eval))
     467                     ,@(and eval-after `(,eval-after))
     468                     ,@(trace-print-body print)
     469                     ,@(trace-print-body print-after)
     470                     ,@(and break-after `((when ,break-after
     471                                            (force-output *trace-output*)
     472                                            (break "~s trace exit: ~s" ',spec vals))))))
    580473
    581474  (prog1
    582475      (block %trace-block
    583         ;;
    584         ;; see if we're a callback
    585         ;;
    586         (when (and (typep spec 'symbol)
    587                    (boundp spec)
    588                    (macptrp (symbol-value spec)))
    589           (let ((len (length %pascal-functions%))
    590                 (sym-name (symbol-name spec)))
    591             (declare (fixnum len))
    592             (dotimes (i len)
    593               (let ((pfe (%svref %pascal-functions% i)))
    594                 (when (and (vectorp pfe)
    595                            (string= sym-name (symbol-name (pfe.sym pfe))))
    596                   (when backtrace
    597                     (if (null before)
    598                       (setq before :print)))
    599                   (setf (pfe.trace-p pfe)
    600                         `(,@(if before `((:before . ,before)))
    601                           ,@(if after `((:after . ,after)))
    602                           ,@(if backtrace `((:backtrace . ,backtrace)))))
    603                   (push spec *trace-pfun-list*)))))
    604           (return-from %trace-block))
    605         ;;
    606         ;; now look for tracible methods.
    607         ;; It's possible, but not likely, that we will be both
    608         ;; a callback and a function or method, if so we trace both.
    609         ;; This isn't possible.
    610         ;; If we're neither, signal an error.
    611         ;;
    612         (multiple-value-bind (def trace-thing)
    613             (%trace-function-spec-p spec define-if-not)
    614           (when (null def)
    615             (return-from trace-function
    616               (warn "Trace does not understand ~S, ignored." spec)))
    617           (when (%traced-p trace-thing)
    618             (%untrace-1 trace-thing)
    619             (setq def (%trace-fboundp trace-thing)))
    620           (when (and methods (typep def 'standard-generic-function))
    621             (dolist (m (%gf-methods def))
    622               (apply #'trace-function m args)))
    623           #+old
    624           (when step               ; just check if has interpreted def
    625             (if (typep def 'standard-generic-function)
    626               (let ((methods (%gf-methods def)))
    627                                         ; should we complain if no methods? naah
    628                 (dolist (m methods) ; stick :step-gf in advice-when slot
    629                   (%trace m :step t)
    630                   (let ((e (function-encapsulation m)))
    631                     (when e (setf (encapsulation-advice-when e) :step-gf))))
    632                                         ; we choose to believe that before and after are intended for the gf
    633                 (if  (or before after)
    634                   (setq step nil)               
    635                   (return-from %trace-block)))
    636               #|(uncompile-for-stepping trace-thing nil t)|#))
    637           (let* ((newsym (gensym "TRACE"))
    638                  (method-p (typep trace-thing 'method))
    639                  (newdef (trace-global-def
    640                           spec newsym if before-if eval-before after-if eval-after method-p)))
    641             (when method-p
    642               (copy-method-function-bits def newdef))
    643             (without-interrupts
    644               (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace spec newsym)
    645                 (declare (ignore ignore))
    646                 (cond (gf-dcode
    647                        (setf (%gf-dcode def)
    648                              (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
    649                       ((symbolp trace-thing) (%fhave trace-thing newdef))
    650                       ((typep trace-thing 'method)
    651                        (setf (%method-function trace-thing) newdef)
    652                        (remove-obsoleted-combined-methods trace-thing)
    653                        newdef)))))))
     476        ;;
     477        ;; see if we're a callback
     478        ;;
     479        (when (and (typep spec 'symbol)
     480                   (boundp spec)
     481                   (macptrp (symbol-value spec)))
     482          (let ((len (length %pascal-functions%))
     483                (sym-name (symbol-name spec)))
     484            (declare (fixnum len))
     485            (dotimes (i len)
     486              (let ((pfe (%svref %pascal-functions% i)))
     487                (when (and (vectorp pfe)
     488                           (string= sym-name (symbol-name (pfe.sym pfe))))
     489                  (when backtrace
     490                    (if (null before)
     491                      (setq before :print)))
     492                  (setf (pfe.trace-p pfe)
     493                        `(,@(if before `((:before . ,before)))
     494                          ,@(if after `((:after . ,after)))
     495                          ,@(if backtrace `((:backtrace . ,backtrace)))))
     496                  (push spec *trace-pfun-list*)))))
     497          (return-from %trace-block))
     498        ;;
     499        ;; now look for traceable methods.
     500        ;; It's possible, but not likely, that we will be both
     501        ;; a callback and a function or method, if so we trace both.
     502        ;; This isn't possible.
     503        ;; If we're neither, signal an error.
     504        ;;
     505        (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def)
     506          (%untrace-1 trace-thing)
     507          (setq def (%encap-binding trace-thing))
     508          (when (and methods (typep def 'standard-generic-function))
     509            (dolist (m (%gf-methods def))
     510              (apply #'trace-function m args)))
     511          #+old
     512          (when step               ; just check if has interpreted def
     513            (if (typep def 'standard-generic-function)
     514              (let ((methods (%gf-methods def)))
     515                ; should we complain if no methods? naah
     516                (dolist (m methods) ; stick :step-gf in advice-when slot
     517                  (%trace m :step t)
     518                  (let ((e (function-encapsulation m)))
     519                    (when e (setf (encapsulation-advice-when e) :step-gf))))
     520                ; we choose to believe that before and after are intended for the gf
     521                (if  (or before after)
     522                  (setq step nil)               
     523                  (return-from %trace-block)))
     524              #|(uncompile-for-stepping trace-thing nil t)|#))
     525          (let* ((newsym (gensym "TRACE"))
     526                 (method-p (typep trace-thing 'method))
     527                 (newdef (trace-global-def
     528                          spec newsym if before-if eval-before after-if eval-after method-p)))
     529            (when method-p
     530              (copy-method-function-bits def newdef))
     531            (encapsulate trace-thing newdef 'trace spec newsym))))
    654532    (when *trace-hook*
    655533      (apply *trace-hook* spec args))))
    656534
    657535
    658 ;; sym is either a symbol or a method
    659 
    660 (defun %traced-p (sym)
    661   (let ((foo (function-encapsulation sym)))
    662     (and foo (eq (encapsulation-type foo) 'trace))))
     536(defun %traced-p (thing)
     537  (let ((cap (get-encapsulation thing)))
     538    (and cap (eq (encapsulation-type cap) 'trace))))
    663539
    664540(defmacro untrace (&rest syms)
     
    676552    val))
    677553
    678 
    679 (defun %untrace (sym)
     554(defun %untrace-all ()
     555  (dolist (pfun *trace-pfun-list*)
     556    (%untrace pfun)
     557    (when *untrace-hook*
     558      (funcall *untrace-hook* pfun)))
     559  (loop for cap being the hash-value of *encapsulation-table*
     560    when (eq (encapsulation-type cap) 'trace)
     561    collect (let ((spec (encapsulation-spec cap)))
     562              (remove-encapsulation cap)
     563              (when *untrace-hook*
     564                (funcall *untrace-hook* spec))
     565              spec)))
     566
     567(defun %untrace (sym &aux val)
    680568  (when (and (consp sym)(consp (car sym)))
    681569    (setq sym (car sym)))
    682570  (cond
    683     ((and (typep sym 'symbol)
    684         (boundp sym)
    685         (macptrp (symbol-value sym)))
    686      (%untrace-pfun sym))
    687     (t
    688      (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
    689        (let (val)
    690          (when (typep def 'standard-generic-function)
    691            (let ((methods (%gf-methods def)))
    692              (dolist (m methods)
    693                (let ((e (function-encapsulation m)))
    694                  (when (and e (eq (encapsulation-advice-when e) :step-gf))
    695                    (remove-encapsulation e)
    696                    (push m  val))))))
    697                                         ; gf could have first been traced :step, and then just plain traced
    698                                         ; maybe the latter trace should undo the stepping??
    699          (when (%traced-p trace-thing)
    700            (%untrace-1 trace-thing)
    701            (push trace-thing val))
    702          (if (null (cdr val))(car val) val)))))
     571   ((and (typep sym 'symbol)
     572         (boundp sym)
     573         (macptrp (symbol-value sym)))
     574    (%untrace-pfun sym))
     575   (t
     576    (let* ((trace-thing (%encapsulation-thing sym))
     577           (def (%encap-binding trace-thing)))
     578      (when (typep def 'standard-generic-function)
     579        (let ((methods (%gf-methods def)))
     580          (dolist (m methods)
     581            (let ((cap (get-encapsulation m)))
     582              (when (and cap (eq (encapsulation-advice-when cap) :step-gf))
     583                (remove-encapsulation cap)
     584                (push m val))))))
     585      ; gf could have first been traced :step, and then just plain traced
     586      ; maybe the latter trace should undo the stepping??
     587      (let ((spec (%untrace-1 trace-thing)))
     588        (when spec
     589          (push spec val))))))
    703590  (when *untrace-hook*
    704     (funcall *untrace-hook* sym)))
    705 
    706 (defun %untrace-all ()
    707   (let ((val nil))
    708     (dolist (cap *trace-alist*)
    709       (push (encapsulation-spec cap) val)
    710        (remove-encapsulation cap)
    711        (when *untrace-hook*
    712        (funcall *untrace-hook* (encapsulation-spec cap))))
    713      (dolist (pfun *trace-pfun-list*)
    714        (%untrace pfun)
    715        (when *untrace-hook*
    716        (funcall *untrace-hook* pfun)))
    717     val))
     591    (funcall *untrace-hook* sym))
     592  (if (null (cdr val)) (car val) val))
    718593
    719594;; thing is a symbol or method - def is current definition
    720595;; we already know its traced
    721596(defun %untrace-1 (thing)
    722   (let (capsule)
    723     (setq capsule (function-encapsulation thing))
    724     ;; trace encapsulations must be first     
    725     (when (neq (encapsulation-type capsule) 'trace)
    726       (error "~S was not traced." thing))
    727     (remove-encapsulation capsule)
    728     (encapsulation-spec capsule)))
     597  (let ((cap (get-encapsulation thing)))
     598    (when (and cap (eq (encapsulation-type cap) 'trace))
     599      (remove-encapsulation cap)
     600      (encapsulation-spec cap))))
    729601
    730602(defun %untrace-pfun (sym)
    731603  (let ((len (length %pascal-functions%))
    732         (sym-name (symbol-name sym)))
     604        (sym-name (symbol-name sym)))
    733605    (declare (fixnum len))
    734606    (dotimes (i len)
    735607      (let ((pfe (%svref %pascal-functions% i)))
    736         (when (and (vectorp pfe)
    737                    (string= sym-name (symbol-name (pfe.sym pfe))))
    738           (setf (pfe.trace-p pfe) nil
    739                 *trace-pfun-list* (remove sym *trace-pfun-list*))
    740           (return-from %untrace-pfun sym))))
     608        (when (and (vectorp pfe)
     609                   (string= sym-name (symbol-name (pfe.sym pfe))))
     610          (setf (pfe.trace-p pfe) nil
     611                *trace-pfun-list* (remove sym *trace-pfun-list*))
     612          (return-from %untrace-pfun sym))))
    741613    nil))
    742614
     
    750622  (if syms
    751623    (let ((options (loop while (keywordp (car syms))
    752                      nconc (list (pop syms) (pop syms)))))
     624                     nconc (list (pop syms) (pop syms)))))
    753625      `(%trace-0 ',syms ',options))
    754626    `(%trace-list)))
     
    767639(defun %trace-list ()
    768640  (let (res)
    769     (dolist (x *trace-alist*)
    770       (push (encapsulation-spec x) res))
     641    (loop for x being the hash-value of *encapsulation-table*
     642         when (eq (encapsulation-type x) 'trace)
     643         do (push (encapsulation-spec x) res))
    771644    (dolist (x *trace-pfun-list*)
    772645      (push x res))
     
    787660(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
    788661  (let ((saved-method-var (gensym))
    789         (enable (gensym))
    790         do-it)
     662        (enable (gensym))
     663        do-it)
    791664    (setq do-it
    792665          (cond #+old (step
    793                        (setq step-it           
    794                              `(step-apply-simple ',def args))
    795                        (if (eq step t)
    796                         step-it
    797                         `(if (apply ',step ',sym args) ; gaak
    798                            ,step-it
    799                            ,(if (and before method-p)
    800                                 `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    801                                 `(apply ',def args)))))
     666                       (setq step-it           
     667                             `(step-apply-simple ',def args))
     668                       (if (eq step t)
     669                        step-it
     670                        `(if (apply ',step ',sym args) ; gaak
     671                           ,step-it
     672                           ,(if (and before method-p)
     673                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
     674                                `(apply ',def args)))))
    802675                (t (if (and eval-before method-p)
    803676                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
     
    805678    (compile-named-function-warn
    806679     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
    807                &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
     680               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
    808681       (declare (dynamic-extent args))
    809682       (let ((*trace-level* (1+ *trace-level*))
    810              (,enable ,if))
    811         (declare (special *trace-enable* *trace-level*))
    812         ,(when eval-before
    813            `(when (and ,enable ,before-if *trace-enable*)
    814              (when *trace-print-hook*
    815                (funcall *trace-print-hook* ',sym t))
    816              (let* ((*trace-enable* nil))
    817                ,@eval-before)
    818              (when *trace-print-hook*
    819                (funcall *trace-print-hook* ',sym nil))))
    820         ,(if eval-after
    821            `(let ((vals (multiple-value-list ,do-it)))
    822              (when (and ,enable ,after-if *trace-enable*)
    823                (when *trace-print-hook*
    824                 (funcall *trace-print-hook* ',sym t))
    825                (let* ((*trace-enable* nil))
    826                 ,@eval-after)
    827                (when *trace-print-hook*
    828                 (funcall *trace-print-hook* ',sym nil)))
    829              (values-list vals))
    830            do-it)))
     683             (,enable ,if))
     684        (declare (special *trace-enable* *trace-level*))
     685        ,(when eval-before
     686           `(when (and ,enable ,before-if *trace-enable*)
     687             (when *trace-print-hook*
     688               (funcall *trace-print-hook* ',sym t))
     689             (let* ((*trace-enable* nil))
     690               ,@eval-before)
     691             (when *trace-print-hook*
     692               (funcall *trace-print-hook* ',sym nil))))
     693        ,(if eval-after
     694           `(let ((vals (multiple-value-list ,do-it)))
     695             (when (and ,enable ,after-if *trace-enable*)
     696               (when *trace-print-hook*
     697                (funcall *trace-print-hook* ',sym t))
     698               (let* ((*trace-enable* nil))
     699                ,@eval-after)
     700               (when *trace-print-hook*
     701                (funcall *trace-print-hook* ',sym nil)))
     702             (values-list vals))
     703           do-it)))
    831704     `(traced ,sym))))
    832705
    833706; &method var tells compiler to bind var to contents of next-method-context
    834 (defun advise-global-def (function-spec def when stuff &optional method-p)
    835   (declare (ignore function-spec))
     707(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
    836708  (let* ((saved-method-var (gensym)))
    837709    `(lambda (,@(if (and method-p (neq when :after))
    838710                  `(&method ,saved-method-var))
    839711              &rest arglist)
    840       ;(declare (dynamic-extent arglist))
     712       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
    841713       (let ()
    842714         ,(ecase
     
    879751    result))
    880752
    881 ;; want to look like
    882 ;; (setq values (multiple-value-list (progn ,@frob)))
    883      
    884753       
    885 (defun %advised-p (thing &optional when advice-name quick)
    886   ;; thing is a symbol, result is list of encapsulations
    887   ;; Quick when used as a simple predicate
    888   (let ((nx thing) cap val)
    889     (while (setq cap (function-encapsulation nx))
    890       (when (eq (encapsulation-type cap) 'advice)
    891         (if quick (return-from %advised-p cap))
    892         (when (or (and (null when)(null advice-name))
    893                   (and (eq when (encapsulation-advice-when cap))
    894                        (equal advice-name (encapsulation-advice-name cap))))
    895           (push cap val)))
    896       (setq nx (encapsulation-symbol cap)))
    897     val)) 
    898 
     754(defun %advised-p (thing)
     755  (loop for nx = thing then (encapsulation-symbol cap)
     756    as cap = (get-encapsulation nx) while cap
     757    thereis (eq (encapsulation-type cap) 'advice)))
     758
     759(defun %advice-encapsulations (thing when advice-name)
     760  (loop for nx = thing then (encapsulation-symbol cap)
     761    as cap = (get-encapsulation nx) while cap
     762    when (and (eq (encapsulation-type cap) 'advice)
     763              (or (null when) (eq when (encapsulation-advice-when cap)))
     764              (or (null advice-name) (equal advice-name (encapsulation-advice-name cap))))
     765    collect cap))
    899766
    900767(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
    901   (let (advise-thing def orig-sym orig-def)
    902     (multiple-value-setq (def advise-thing)
    903       (%trace-function-spec-p function-spec define-if-not))
    904     (when (not def)(error "Advise does not understand ~s." function-spec))
     768  (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
     769         orig-sym)
     770    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
     771      (when capsules
     772        (unadvise-capsules capsules)))
    905773    (when (%traced-p advise-thing)
     774      ; make traced call advised
    906775      (setq orig-sym
    907             (encapsulation-symbol (function-encapsulation advise-thing)))
    908       (setq orig-def (fboundp orig-sym)))
    909     (let ((capsules (%advised-p advise-thing when advice-name)))
    910       (when capsules
    911         (unadvise-capsules capsules)
    912         ; get the right def you fool!
    913         (setq def (%trace-function-spec-p function-spec))))
    914     (without-interrupts
    915      (multiple-value-bind (ignore gf-dcode)
    916                           (encapsulate (or orig-sym advise-thing) (or orig-def def)
    917                                        'advice function-spec newsym
    918                                        advice-name when)
    919        (declare (ignore ignore))
    920        (lfun-name newdef `(advised ',function-spec))
    921        (if method-p (copy-method-function-bits def newdef))
    922        (if gf-dcode (setq newdef (%cons-combined-method def (cons newdef gf-dcode)
    923                                                         #'%%call-gf-encapsulation)))                     
    924        (cond (orig-sym
    925               (%fhave orig-sym newdef))  ; make traced call advised
    926              (t  (cond (gf-dcode (setf (%gf-dcode def) newdef))
    927                        ((symbolp advise-thing)
    928                         (%fhave advise-thing newdef))
    929                        ((typep advise-thing 'method)
    930                         (progn
    931                           (setf (%method-function advise-thing) newdef)
    932                           (remove-obsoleted-combined-methods advise-thing)
    933                           newdef)))))))))
    934 
    935 (defmacro advise (function form &key (when :before) name define-if-not)
     776            (encapsulation-symbol (get-encapsulation advise-thing))))
     777    (lfun-name newdef `(advised ',function-spec))
     778    (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef))
     779    (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when)
     780    newdef))
     781
     782(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist)
    936783  (let* ((newsym (gensym "ADVICE"))
    937784         ; WAS typep advise-thing 'method
    938785         (method-p (or (typep function 'method) ; can this happen?
    939786                       (and (consp function)(eq (car function) :method))))
    940          (newdef (advise-global-def function newsym when form method-p)))
     787         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
    941788      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
    942789                 ,define-if-not)))
     
    945792  `(advisedp-1 ',function-spec ',when ',name))
    946793
     794(defun encapsulation-advice-spec (cap)
     795  (list (encapsulation-spec cap)
     796        (encapsulation-advice-when cap)
     797        (encapsulation-advice-name cap)))
     798 
    947799(defun advisedp-1 (function-spec when name)
    948   (let (val)
    949     (flet ((xtract-capsule (c)
    950              (list (encapsulation-spec c)
    951                    (encapsulation-advice-when c)
    952                    (encapsulation-advice-name c))))
    953       (cond ((eq t function-spec)
    954              (dolist (c *advise-alist*)
    955                (when (and
    956                       (or (null when)(eq when (encapsulation-advice-when c)))
    957                       (or (null name)(equal name (encapsulation-advice-name c))))
    958                  (push (xtract-capsule c) val))))
    959             (t (let* ((advise-thing (nth-value 1  (%trace-function-spec-p function-spec)))
    960                       (capsules (%advised-p advise-thing when name)))
    961                  (dolist (capsule capsules)
    962                    (push (xtract-capsule capsule) val)))))
    963       val)))               
    964 
    965 
    966 (defun unadvise-1 (function-spec &optional when advice-name ignore)
     800  (cond ((eq t function-spec)
     801         (loop for c being the hash-value of *encapsulation-table*
     802           when (and (eq (encapsulation-type c) 'advice)
     803                     (or (null when)(eq when (encapsulation-advice-when c)))
     804                     (or (null name)(equal name (encapsulation-advice-name c))))
     805           collect (encapsulation-advice-spec c)))
     806        (t (let* ((advise-thing (%encapsulation-thing function-spec))
     807                  (capsules (%advice-encapsulations advise-thing when name)))
     808             (mapcar #'encapsulation-advice-spec capsules)))))
     809
     810(defun %unadvise-1 (function-spec &optional when advice-name ignore)
    967811  (declare (ignore ignore))
    968   (let ((advise-thing (nth-value 1 (%trace-function-spec-p function-spec))))
    969     (let ((capsules (%advised-p advise-thing when advice-name)))
     812  (let ((advise-thing (%encapsulation-thing function-spec)))
     813    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
    970814      (when capsules (unadvise-capsules capsules)))))
    971815
     
    973817  (let (val)
    974818    (dolist (capsule capsules)
    975         (push (list (encapsulation-spec capsule)
    976                     (encapsulation-advice-when capsule)
    977                     (encapsulation-advice-name capsule))
    978               val)
     819        (push (encapsulation-advice-spec capsule) val)
    979820        (remove-encapsulation capsule))
    980821    val))
     
    982823(defmacro unadvise (function &key when name)
    983824  (cond ((neq function t)
    984          `(unadvise-1 ',function ',when ',name))
     825         `(%unadvise-1 ',function ',when ',name))
    985826        (t '(%unadvise-all))))
    986827
    987828(defun %unadvise-all ()
    988   (unadvise-capsules *advise-alist*))
    989 
    990 (defun %set-unencapsulated-definition (spec newdef)
    991   (let (foo)
    992     (while (setq foo (function-encapsulation spec))
    993       (setq spec (encapsulation-symbol foo)))
    994     (typecase spec
    995       (symbol
    996        (%fhave spec newdef)) ;; or fset ?? 
    997       (method
    998        (setf (%method-function spec) newdef)
    999        (remove-obsoleted-combined-methods spec)
    1000        newdef))))
    1001 
    1002 
    1003 ;; return t if we defined it, nil otherwise
    1004 
     829  (loop for cap being the hash-value of *encapsulation-table*
     830    when (eq (encapsulation-type cap) 'advice)
     831    collect (progn
     832              (remove-encapsulation cap)
     833              (encapsulation-advice-spec cap))))
     834
     835;; Called from %defun. Return t if we defined it, nil otherwise
    1005836(defun %defun-encapsulated-maybe (name newdef)
    1006   (let ((def (fboundp name)))
    1007     (when (and def (function-encapsulated-p name))
    1008       (cond ((or *loading-files* (typep def 'standard-generic-function))
     837  (assert (not (get-encapsulation newdef)))
     838  (let ((old-def (fboundp name)) cap)
     839    (when (and old-def (setq cap (get-encapsulation name)))
     840      (cond ((or (and *loading-files* *loading-removes-encapsulation*)
     841                 ;; redefining a gf as a fn.
     842                 (typep old-def 'standard-generic-function))
    1009843             (forget-encapsulations name)
    1010844             nil)
    1011             (t (%set-unencapsulated-definition name newdef)
     845            (t (set-unencapsulated-definition cap newdef)
    1012846               T)))))
    1013847
    1014 (defun %move-method-encapsulations-maybe (oldmethod newmethod)
    1015   ;; deal with method redefinition
    1016   (let (cap newdef olddef old-inner-def)
    1017     (when (and (setq cap (function-encapsulation oldmethod))
    1018                (neq oldmethod newmethod))     
    1019       (cond (*loading-files*
    1020              (when (%traced-p oldmethod)
    1021                (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
    1022              (when (%advised-p oldmethod nil nil t)
    1023                (format t "~%... Unadvising ~s" (unadvise-1 oldmethod))))
    1024             (t (setq newdef (%method-function newmethod))
    1025                (setq olddef (%method-function oldmethod))
    1026                (setq old-inner-def (find-unencapsulated-definition oldmethod))
    1027                ;; make last encapsulation call new definition           
    1028                (%set-unencapsulated-definition oldmethod newdef)
    1029                (setf (%method-function newmethod) olddef)
    1030                (remove-encapsulation cap t)
    1031                (put-encapsulation newmethod cap)
    1032                (setf (%method-function oldmethod) old-inner-def)
    1033                (advise-set-method-bits newmethod newdef)
    1034                )))))
    1035 
    1036 (defun advise-set-method-bits (spec newdef)
    1037   ;; spec is a symbol, function, or method object
    1038   (let (foo)
    1039     (while (setq foo (function-encapsulation spec))     
    1040       (let ((def (typecase spec
    1041                    (symbol (fboundp spec))
    1042                    (method (%method-function spec))
    1043                    (t nil))))
    1044         (if def
    1045           (copy-method-function-bits newdef def)
    1046           (error "whats going on here anyway")))
    1047       (setq spec (encapsulation-symbol foo)))))
    1048 
     848;; Called from clos when change dcode
     849(defun %set-encapsulated-gf-dcode (gf new-dcode)
     850  (loop with cap = (get-encapsulation gf)
     851    for gf-copy = (encapsulation-old-def cap)
     852    as cur-dcode = (%gf-dcode gf-copy)
     853    do (setq cap (get-encapsulation cur-dcode))
     854    ;; refresh all the gf copies, in case other info in gf changed
     855    do (%copy-function gf gf-copy)
     856    do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
     857    while cap))
     858
     859;; Called from clos when oldmethod is being replaced by newmethod in a gf.
     860(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
     861  (unless (eq oldmethod newmethod)
     862    (cond ((and *loading-removes-encapsulation* *loading-files*)
     863           (when (%traced-p oldmethod)
     864             (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
     865           (when (%advised-p oldmethod)
     866             (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
     867          (t (when (setq cap (get-encapsulation oldmethod))
     868               (let* ((old-inner-def (find-unencapsulated-definition oldmethod))
     869                      (newdef (%method-function newmethod))
     870                      (olddef (%method-function oldmethod)))
     871                 ;; make last encapsulation call new definition
     872                 (set-unencapsulated-definition cap newdef)
     873                 (setf (%method-function newmethod) olddef)
     874                 (set-encapsulation-owner olddef newmethod)
     875                 (setf (%method-function oldmethod) old-inner-def)
     876                 (loop
     877                   for def = olddef then (encapsulation-old-def cap)
     878                   for cap = (get-encapsulation def) while cap
     879                   do (copy-method-function-bits newdef def))))))))
    1049880
    1050881#|
    1051         Change History (most recent last):
    1052         2       12/29/94        akh     merge with d13
     882        Change History (most recent last):
     883        2       12/29/94        akh     merge with d13
    1053884|# ;(do not edit past this line!!)
Note: See TracChangeset for help on using the changeset viewer.