source: trunk/source/lib/encapsulate.lisp @ 9844

Last change on this file since 9844 was 9844, checked in by gz, 13 years ago

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

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
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
22(defvar *trace-pfun-list* nil)
23(defvar *trace-enable* t)
24(defvar *trace-level* 0)
25(defparameter *trace-max-indent* 40)
26(defvar *trace-print-level* nil)
27(defvar *trace-print-length* nil)
28;(defparameter *trace-define-if-undefined* nil)
29(defparameter *trace-bar-frequency* nil)
30(defvar *trace-hook* nil)
31(defvar *untrace-hook* nil)
32(defvar *trace-print-hook* nil)
33
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;;;
49
50(defparameter *encapsulation-table*
51  (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t))
52
53(defstruct (encapsulation)
54  symbol         ; the uninterned name containing original def
55  type           ; trace or advise
56  spec           ; the original function spec
57  advice-name    ; optional
58  advice-when    ; :before, :after, :around
59  owner          ; where encapsulation is installed (can change)
60)
61
62(defun encapsulation-old-def (cap)
63  (fboundp (encapsulation-symbol cap)))
64
65(defun setf-function-spec-name (spec)
66  (if (and (consp spec) (eq (car spec) 'setf))
67    (or (%setf-method (cadr spec)) ; this can be an anonymous function
68        (setf-function-name (cadr spec)))
69    spec))
70
71(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*)))
72  (fresh-line *trace-output*)
73  (dotimes (i (1- n))
74    (declare (fixnum i))
75    (write-char (if (and *trace-bar-frequency* 
76                         (eq 0 (mod i *trace-bar-frequency*)))
77                  #\| #\Space) *trace-output*))
78  (if (eq direction :in)
79    (format *trace-output* "~d> " (1- *trace-level*))
80    (format *trace-output* "<~d " (1- *trace-level*))))
81
82(defun trace-before  (&rest args)
83  (declare (dynamic-extent args))
84  (trace-tab :in)
85  (let* ((*print-level* *trace-print-level*)
86         (*print-length* *trace-print-length*)
87         (*print-readably* nil))
88    (format *trace-output* "Calling ~S ~%" args)
89    (force-output *trace-output*)))
90
91(defun trace-after (sym &rest args &aux (n (length args)))
92  (declare (dynamic-extent args))
93  (let* ((*print-level* *trace-print-level*)
94         (*print-length* *trace-print-length*)
95         (*print-readably* nil))
96    (if (eq n 1)
97      (progn
98        (trace-tab :out)
99        (format *trace-output* "~S returned ~S~%" sym (%car args)))
100      (progn
101        (trace-tab :out)
102        (format *trace-output* "~S returned ~S values :" sym n)
103        (dolist (val args)
104          (trace-tab :out)
105          (format *trace-output* "     ~S" val))))
106    (force-output *trace-output*)))
107
108(defun forget-encapsulations (name)
109  (when (%traced-p name)
110    (format t "~%... Untracing ~a" name) 
111    (%untrace-1 name))
112  (when (%advised-p name)
113    (format t "~%... Unadvising ~a" name) 
114    (%unadvise-1 name))
115  nil)
116
117(defun function-encapsulated-p (fn-or-method)
118  (get-encapsulation fn-or-method))
119
120(defun %encap-binding (thing)
121  (require-type (etypecase thing
122                  (symbol (fboundp thing))
123                  (method (%method-function thing)))
124                'function))
125
126(defun get-encapsulation (spec)
127  (let* ((key (typecase spec
128                (symbol (let* ((def (fboundp spec)))
129                          (if (generic-function-p def)
130                            (%gf-dcode def)
131                            def)))
132                (method (%method-function spec))
133                (standard-generic-function (%gf-dcode spec))
134                (function spec)))
135         (cap (gethash key *encapsulation-table*)))
136    #+gz (assert (or (null cap)
137                     (let ((fn (%encap-binding (encapsulation-owner cap))))
138                       (eq (if (standard-generic-function-p fn) (%gf-dcode fn) fn) key))))
139    cap))
140
141(defun set-encapsulation-owner (fn owner)
142  (let ((cap (get-encapsulation fn)))
143    (when cap
144      (setf (encapsulation-owner cap) owner))))
145
146(defun put-encapsulation (fn cap)
147  (let* ((owner (encapsulation-owner cap))
148         (old-def (%encap-binding owner))
149         (newsym (encapsulation-symbol cap)))
150    (setf (gethash fn *encapsulation-table*) cap)
151    (set-encapsulation-owner old-def newsym)
152    (etypecase owner
153      (symbol
154       (cond ((standard-generic-function-p old-def)
155              (%fhave newsym (%copy-function old-def))
156              (setf (%gf-dcode old-def) fn))
157             (t
158              (%fhave newsym old-def)
159              (%fhave owner fn))))
160      (method
161       (%fhave newsym old-def)
162       (setf (%method-function owner) fn)
163       (remove-obsoleted-combined-methods owner)))))
164
165(defun remove-encapsulation (cap)
166  (let* ((owner (encapsulation-owner cap))
167         (cur-def (%encap-binding owner))
168         (old-def (encapsulation-old-def cap)))
169    (assert (eq cap (get-encapsulation cur-def)))
170    (set-encapsulation-owner old-def owner)
171    (typecase owner
172      (symbol
173       (cond ((standard-generic-function-p cur-def)
174              (remhash (%gf-dcode cur-def) *encapsulation-table*)
175              (setf (%gf-dcode cur-def) (%gf-dcode old-def)))
176             (t
177              (remhash cur-def *encapsulation-table*)
178              (%fhave owner old-def))))
179      (method
180       (remhash cur-def *encapsulation-table*)
181       (setf (%method-function owner) old-def)
182       (remove-obsoleted-combined-methods owner)))))
183
184
185(defun encapsulate (owner newdef type trace-spec newsym &optional advice-name advice-when)
186  (let ((cap (make-encapsulation
187              :owner owner
188              :symbol newsym
189              :type type
190              :spec trace-spec
191              :advice-name advice-name
192              :advice-when advice-when)))
193    (put-encapsulation newdef cap)
194    cap))
195
196(defun find-unencapsulated-definition (fn)
197  (when fn
198    (loop for cap = (get-encapsulation fn) while cap
199      do (setq fn (encapsulation-old-def cap)))
200    fn))
201
202(defun set-unencapsulated-definition (cap newdef)
203  (loop for owner = (encapsulation-symbol cap)
204    do (setq cap (get-encapsulation owner)) while cap
205    finally (%fhave owner newdef)))
206
207(defun %encapsulation-thing (spec &optional define-if-not (error-p t))
208  ;; Returns either an fboundp symbol or a method, or nil.
209  (typecase spec
210    (symbol
211     ;; weed out macros and special-forms
212     (if (or (null spec) (special-operator-p spec) (macro-function spec))
213       (if error-p
214         (error "Cannot trace or advise ~a~S" spec
215                (cond ((null spec) "")
216                      ((special-operator-p spec) "special operator ")
217                      (t "macro ")))
218         nil)
219       (if (or (fboundp spec)
220               (and define-if-not
221                    (progn
222                      (warn "~S was undefined" spec)
223                      (%fhave spec (%function 'trace-null-def))
224                      t)))
225         spec
226         (if error-p
227           (error "~S is undefined." spec)
228           nil))))
229    (method spec)
230    (cons
231     (case (car spec)
232       (:method 
233        (let ((gf (cadr spec))
234              (qualifiers (butlast (cddr spec)))
235              (specializers (car (last (cddr spec))))
236              method)
237          (setq specializers (require-type specializers 'list))
238          (prog ()
239            AGN
240            (cond ((setq method
241                         (find-method-by-names gf qualifiers specializers))
242                   (return method))
243                  (define-if-not
244                    (when (define-undefined-method spec gf qualifiers specializers)
245                      (go AGN)))
246                  (t (if error-p
247                       (error "Method ~s qualifiers ~s specializers ~s not found."
248                              gf qualifiers specializers)
249                       (return nil)))))))
250       (setf
251        (let ((name-or-fn (setf-function-spec-name spec)))
252          (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
253                ((functionp name-or-fn) ; it's anonymous - give it a name
254                 (let ((newname (gensym)))
255                   (%fhave newname name-or-fn)
256                   (store-setf-method (cadr spec) newname)
257                   newname)))))))
258    (t (if error-p
259         (error "Invalid trace spec ~s" spec)
260         nil))))
261
262(defun trace-null-def (&rest ignore)
263  (declare (ignore ignore)))
264
265(defun define-undefined-method (spec gf qualifiers specializers)
266  (let (vars def)   
267    (flet ((blob (e)
268                 (let ((v (gensym)))
269                   (push v vars)
270                   (list v e))))
271      (declare (dynamic-extent #'blob))
272      (setq def
273            (let ((lambda-list (mapcar #' blob specializers)))
274              (eval
275               `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore)
276                  (declare (ignore ignore ,@vars))))))
277      (when def (warn "~S was undefined" spec))
278      def)))
279
280(defun traceable-symbol-p (sym)
281  (and sym
282       (not (special-operator-p sym))
283       (not (macro-function sym))
284       (fboundp sym)))
285
286(defun %trace-package (pkg &rest args)
287  (declare (dynamic-extent args))
288  (do-present-symbols (sym pkg)
289    ;; Don't auto-trace imported symbols, because too often these are imported
290    ;; system functions...
291    (when (eq (symbol-package sym) pkg)
292      (when (traceable-symbol-p sym)
293        (apply #'trace-function sym args))
294      (when (or (%setf-method sym)
295                ;; Not really right.  Should construct the name if doesn't exist.
296                ;; But that would create a lot of garbage for little gain...
297                (let ((name (existing-setf-function-name sym)))
298                  (traceable-symbol-p name)))
299        (apply #'trace-function `(setf ,sym) args)))))
300
301(defun trace-print-body (print-form)
302  (when print-form
303    (if (and (consp print-form) (eq (car print-form) 'values))
304      `((mapcar #'(lambda (name object)
305                    (trace-tab :in)
306                    (format *trace-output* "~s = ~s" name object))
307         ',(cdr print-form)
308         (list ,@(cdr print-form))))
309      `((let ((objects (multiple-value-list ,print-form))
310              (i -1))
311          (if (and objects (not (cdr objects)))
312            (progn
313              (trace-tab :in)
314              (format *trace-output* "~s = ~s" ',print-form (car objects)))
315            (dolist (object objects)
316              (trace-tab :in)
317              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
318
319(defun trace-backtrace-body (test-form)
320  (when test-form
321    `((let ((test ,test-form))
322        (when test
323          (multiple-value-bind (detailed-p count)
324              (cond ((memq test '(:detailed :verbose :full))
325                     (values t nil))
326                    ((integerp test)
327                     (values nil test))
328                    ((and (consp test)
329                          (keywordp (car test))
330                          (consp (cdr test))
331                          (null (cddr test)))
332                     (values (memq (car test) '(:detailed :verbose :full))
333                             (and (integerp (cadr test)) (cadr test))))
334                    (t (values nil nil)))
335            (let ((*debug-io* *trace-output*))
336              (print-call-history :detailed-p detailed-p
337                                  :count (or count most-positive-fixnum))
338              (terpri *trace-output*))))))))
339
340(defun trace-inside-frame-p (name)
341  (if (packagep name)
342    (map-call-frames #'(lambda (p)
343                         (let* ((fn (cfp-lfun p))
344                                (fname (and fn (function-name fn)))
345                                (sym (typecase fname
346                                       (method (method-name fname))
347                                       (cons (and (setf-function-name-p fname) (cadr fname)))
348                                       (symbol fname)
349                                       (t nil))))
350                           (when (and sym (eq (symbol-package sym) name))
351                             (return-from trace-inside-frame-p t)))))
352    (let ((fn (%encap-binding name)))
353      (when fn
354        (map-call-frames #'(lambda (p)
355                             (when (eq (cfp-lfun p) fn)
356                               (return-from trace-inside-frame-p t))))))))
357
358(defun trace-package-spec (spec)
359  (when (or (stringp spec)
360            (packagep spec)
361            (and (consp spec) (eq (car spec) :package)))
362    (let ((pkg (if (consp spec)
363                 (destructuring-bind (pkg) (cdr spec) pkg)
364                 spec)))
365      (pkg-arg pkg))))
366
367(defun trace-function (spec &rest args &key before after methods
368                            (if t) (before-if t) (after-if t)
369                            print print-before print-after
370                            eval eval-before eval-after
371                            break break-before break-after
372                            backtrace backtrace-before backtrace-after
373                            inside
374                            define-if-not
375                            ;; Some synonyms, just to be nice
376                            (condition t) (if-before t) (if-after t) (wherein nil))
377
378  (declare (dynamic-extent args))
379  (let ((pkg (trace-package-spec spec)))
380    (when pkg
381      (return-from trace-function (apply #'%trace-package pkg args))))
382
383  ;; A little bit of dwim, after all this _is_ an interactive tool...
384  (unless (eq condition t)
385    (setq if (if (eq if t) condition `(and ,if ,condition))))
386  (unless (eq if-before t)
387    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
388  (unless (eq if-after t)
389    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
390  (when (and inside (trace-spec-p inside))
391    (setq inside (list inside)))
392  (when wherein
393    (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein))))
394  (case break
395    (:before (setq break-before (or break-before t) break nil))
396    (:after (setq break-after (or break-after t) break nil)))
397  (case backtrace
398    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
399    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
400  (case before
401    (:break (setq before :print break-before t))
402    (:backtrace (setq before :print backtrace-before t)))
403  (case after
404    (:break (setq after :print break-after t))
405    (:backtrace (setq after :print backtrace-after t)))
406
407  (when break
408    (setq break-before (if break-before
409                         `(and ,break ,break-before)
410                         break))
411    (setq break-after (if break-after
412                        `(and ,break ,break-after)
413                        break)))
414  (unless backtrace-before
415    (setq backtrace-before backtrace))
416  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
417    (setq backtrace-before `',backtrace-before))
418  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
419    (setq backtrace-after `',backtrace-after))
420
421  (when (and (null before) (null after))
422    (setq before :print)
423    (setq after :print))
424  (when (and (null before) backtrace-before)
425    (setq before :print))
426
427  (case before
428    ((:print :default) (setq before #'trace-before)))
429  (case after
430    ((:print :default) (setq after #'trace-after)))
431
432  (when (or (non-nil-symbol-p before) (functionp before))
433    (setq before `',before))
434  (when (or (non-nil-symbol-p after) (functionp after))
435    (setq after `',after))
436
437  (when inside
438    (let ((tests (loop for spec in inside
439                       as name = (or (trace-package-spec spec)
440                                     (%encapsulation-thing spec nil nil)
441                                     (error "Cannot trace inside ~s" spec))
442                       collect `(trace-inside-frame-p ',name))))
443      (setq if `(and ,if (or ,@tests)))))
444
445  (setq eval-before `(,@(trace-print-body print-before)
446                      ,@(trace-print-body print)
447                      ,@(and eval-before `(,eval-before))
448                      ,@(and eval `(,eval))
449                      ,@(and before `((apply ,before ',spec args)))
450                      ,@(trace-backtrace-body backtrace-before)
451                      ,@(and break-before `((when ,break-before
452                                              (force-output *trace-output*)
453                                              (break "~s trace entry: ~s" ',spec args))))))
454  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
455                     ,@(and after `((apply ,after ',spec vals)))
456                     ,@(and eval `(,eval))
457                     ,@(and eval-after `(,eval-after))
458                     ,@(trace-print-body print)
459                     ,@(trace-print-body print-after)
460                     ,@(and break-after `((when ,break-after
461                                            (force-output *trace-output*)
462                                            (break "~s trace exit: ~s" ',spec vals))))))
463
464  (prog1
465      (block %trace-block
466        ;;
467        ;; see if we're a callback
468        ;;
469        (when (and (typep spec 'symbol)
470                   (boundp spec)
471                   (macptrp (symbol-value spec)))
472          (let ((len (length %pascal-functions%))
473                (sym-name (symbol-name spec)))
474            (declare (fixnum len))
475            (dotimes (i len)
476              (let ((pfe (%svref %pascal-functions% i)))
477                (when (and (vectorp pfe)
478                           (string= sym-name (symbol-name (pfe.sym pfe))))
479                  (when backtrace
480                    (if (null before)
481                      (setq before :print)))
482                  (setf (pfe.trace-p pfe)
483                        `(,@(if before `((:before . ,before)))
484                          ,@(if after `((:after . ,after)))
485                          ,@(if backtrace `((:backtrace . ,backtrace)))))
486                  (push spec *trace-pfun-list*)))))
487          (return-from %trace-block))
488        ;;
489        ;; now look for traceable methods.
490        ;; It's possible, but not likely, that we will be both
491        ;; a callback and a function or method, if so we trace both.
492        ;; This isn't possible.
493        ;; If we're neither, signal an error.
494        ;;
495        (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def)
496          (%untrace-1 trace-thing)
497          (setq def (%encap-binding trace-thing))
498          (when (and methods (typep def 'standard-generic-function))
499            (dolist (m (%gf-methods def))
500              (apply #'trace-function m args)))
501          #+old
502          (when step               ; just check if has interpreted def
503            (if (typep def 'standard-generic-function)
504              (let ((methods (%gf-methods def)))
505                ; should we complain if no methods? naah
506                (dolist (m methods) ; stick :step-gf in advice-when slot
507                  (%trace m :step t)
508                  (let ((e (function-encapsulation m)))
509                    (when e (setf (encapsulation-advice-when e) :step-gf))))
510                ; we choose to believe that before and after are intended for the gf
511                (if  (or before after)
512                  (setq step nil)               
513                  (return-from %trace-block)))
514              #|(uncompile-for-stepping trace-thing nil t)|#))
515          (let* ((newsym (gensym "TRACE"))
516                 (method-p (typep trace-thing 'method))
517                 (newdef (trace-global-def 
518                          spec newsym if before-if eval-before after-if eval-after method-p)))
519            (when method-p
520              (copy-method-function-bits def newdef))
521            (encapsulate trace-thing newdef 'trace spec newsym))))
522    (when *trace-hook*
523      (apply *trace-hook* spec args))))
524
525
526(defun %traced-p (thing)
527  (let ((cap (get-encapsulation thing)))
528    (and cap (eq (encapsulation-type cap) 'trace))))
529
530(defmacro untrace (&rest syms)
531  "Remove tracing from the specified functions. With no args, untrace all
532   functions."
533  (if syms
534    `(%untrace-0 ',syms)
535    `(%untrace-all)))
536
537(defun %untrace-0 (syms)
538  (let (val x)
539    (dolist (symbol syms)
540      (setq x (%untrace symbol))
541      (when x (push x val)))
542    val))
543
544(defun %untrace-all ()
545  (dolist (pfun *trace-pfun-list*)
546    (%untrace pfun)
547    (when *untrace-hook*
548      (funcall *untrace-hook* pfun)))
549  (loop for cap being the hash-value of *encapsulation-table*
550    when (eq (encapsulation-type cap) 'trace)
551    collect (let ((spec (encapsulation-spec cap)))
552              (remove-encapsulation cap)
553              (when *untrace-hook*
554                (funcall *untrace-hook* spec))
555              spec)))
556
557(defun %untrace (sym &aux val)
558  (when (and (consp sym)(consp (car sym)))
559    (setq sym (car sym)))
560  (cond
561   ((and (typep sym 'symbol)
562         (boundp sym)
563         (macptrp (symbol-value sym)))
564    (%untrace-pfun sym))
565   (t 
566    (let* ((trace-thing (%encapsulation-thing sym))
567           (def (%encap-binding trace-thing)))
568      (when (typep def 'standard-generic-function)
569        (let ((methods (%gf-methods def)))
570          (dolist (m methods)
571            (let ((cap (get-encapsulation m)))
572              (when (and cap (eq (encapsulation-advice-when cap) :step-gf))
573                (remove-encapsulation cap)
574                (push m val))))))
575      ; gf could have first been traced :step, and then just plain traced
576      ; maybe the latter trace should undo the stepping??
577      (let ((spec (%untrace-1 trace-thing)))
578        (when spec
579          (push spec val))))))
580  (when *untrace-hook*
581    (funcall *untrace-hook* sym))
582  (if (null (cdr val)) (car val) val))
583
584;; thing is a symbol or method - def is current definition
585;; we already know its traced
586(defun %untrace-1 (thing)
587  (let ((cap (get-encapsulation thing)))
588    (when (and cap (eq (encapsulation-type cap) 'trace))
589      (remove-encapsulation cap)
590      (encapsulation-spec cap))))
591
592(defun %untrace-pfun (sym)
593  (let ((len (length %pascal-functions%))
594        (sym-name (symbol-name sym)))
595    (declare (fixnum len))
596    (dotimes (i len)
597      (let ((pfe (%svref %pascal-functions% i)))
598        (when (and (vectorp pfe)
599                   (string= sym-name (symbol-name (pfe.sym pfe))))
600          (setf (pfe.trace-p pfe) nil
601                *trace-pfun-list* (remove sym *trace-pfun-list*))
602          (return-from %untrace-pfun sym))))
603    nil))
604
605
606
607(defmacro trace (&rest syms)
608  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
609
610TRACE is a debugging tool that provides information when specified
611functions are called."
612  (if syms
613    (let ((options (loop while (keywordp (car syms))
614                     nconc (list (pop syms) (pop syms)))))
615      `(%trace-0 ',syms ',options))
616    `(%trace-list)))
617
618(defun trace-spec-p (arg)
619  (or (atom arg)
620      (memq (car arg) '(:method setf :package))))
621
622
623(defun %trace-0 (syms &optional global-options)
624  (dolist (spec syms)
625    (if (trace-spec-p spec)
626      (apply #'trace-function spec global-options)
627      (apply #'trace-function (append spec global-options)))))
628
629(defun %trace-list ()
630  (let (res)
631    (loop for x being the hash-value of *encapsulation-table*
632         when (eq (encapsulation-type x) 'trace)
633         do (push (encapsulation-spec x) res))
634    (dolist (x *trace-pfun-list*)
635      (push x res))
636    res))
637
638;; this week def is the name of an uninterned gensym whose fn-cell is original def
639
640(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
641  (let ((saved-method-var (gensym))
642        (enable (gensym))
643        do-it)
644    (setq do-it
645          (cond #+old (step
646                       (setq step-it           
647                             `(step-apply-simple ',def args))
648                       (if (eq step t)
649                         step-it
650                         `(if (apply ',step ',sym args) ; gaak
651                           ,step-it
652                           ,(if (and before method-p)
653                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
654                                `(apply ',def args)))))
655                (t (if (and eval-before method-p)
656                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
657                     `(apply ',def args)))))
658    (compile-named-function-warn
659     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
660               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
661       (declare (dynamic-extent args))
662       (let ((*trace-level* (1+ *trace-level*))
663             (,enable ,if))
664         (declare (special *trace-enable* *trace-level*))
665         ,(when eval-before
666           `(when (and ,enable ,before-if *trace-enable*)
667             (when *trace-print-hook*
668               (funcall *trace-print-hook* ',sym t))
669             (let* ((*trace-enable* nil))
670               ,@eval-before)
671             (when *trace-print-hook*
672               (funcall *trace-print-hook* ',sym nil))))
673         ,(if eval-after
674           `(let ((vals (multiple-value-list ,do-it)))
675             (when (and ,enable ,after-if *trace-enable*)
676               (when *trace-print-hook* 
677                 (funcall *trace-print-hook* ',sym t))
678               (let* ((*trace-enable* nil))
679                 ,@eval-after)
680               (when *trace-print-hook* 
681                 (funcall *trace-print-hook* ',sym nil)))
682             (values-list vals))
683           do-it)))
684     `(traced ,sym))))
685
686; &method var tells compiler to bind var to contents of next-method-context
687(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
688  (let* ((saved-method-var (gensym)))
689    `(lambda (,@(if (and method-p (neq when :after))
690                  `(&method ,saved-method-var))
691              &rest arglist)
692       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
693       (let ()
694         ,(ecase
695            when
696            (:before
697             `(block nil
698                ,stuff                 
699                (return ,(if method-p
700                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
701                           `(apply ',def arglist)))))
702            (:after         
703             `(block nil
704                (let ((values (multiple-value-list (apply (function ,def) arglist))))
705                  ;(declare (dynamic-extent values))
706                  ,stuff
707                  (return (values-list values)))))
708            (:around
709             ;; stuff is e.g. (+ 5 (:do-it))
710             (if method-p 
711               `(macrolet ((:do-it ()
712                             `(apply-with-method-context ,',saved-method-var 
713                                                         (symbol-function ',',def)
714                                                         arglist)))
715                  (block nil
716                    (return  ,stuff)))
717               `(macrolet ((:do-it ()
718                             `(apply (function ,',def) arglist)))
719                  (block nil
720                    (return  ,stuff))))))))))
721
722
723(defun compile-named-function-warn (fn name)
724  (multiple-value-bind (result warnings)(compile-named-function fn name)   
725    (when warnings 
726      (let ((first t))
727        (dolist (w warnings)
728          (signal-compiler-warning w first nil nil nil)
729          (setq first nil))))
730    result))
731
732       
733(defun %advised-p (thing)
734  (loop for nx = thing then (encapsulation-symbol cap)
735    as cap = (get-encapsulation nx) while cap
736    thereis (eq (encapsulation-type cap) 'advice)))
737
738(defun %advice-encapsulations (thing when advice-name)
739  (loop for nx = thing then (encapsulation-symbol cap)
740    as cap = (get-encapsulation nx) while cap
741    when (and (eq (encapsulation-type cap) 'advice)
742              (or (null when) (eq when (encapsulation-advice-when cap)))
743              (or (null advice-name) (equal advice-name (encapsulation-advice-name cap))))
744    collect cap))
745
746(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
747  (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
748         orig-sym)
749    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
750      (when capsules 
751        (unadvise-capsules capsules)))
752    (when (%traced-p advise-thing)
753      ; make traced call advised
754      (setq orig-sym
755            (encapsulation-symbol (get-encapsulation advise-thing))))
756    (lfun-name newdef `(advised ',function-spec))
757    (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef))
758    (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when)
759    newdef))
760
761(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist)
762  (let* ((newsym (gensym "ADVICE"))
763         ; WAS typep advise-thing 'method
764         (method-p (or (typep function 'method) ; can this happen?
765                       (and (consp function)(eq (car function) :method))))
766         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
767      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
768                 ,define-if-not)))
769
770(defmacro advisedp (function-spec &key when name)
771  `(advisedp-1 ',function-spec ',when ',name))
772
773(defun encapsulation-advice-spec (cap)
774  (list (encapsulation-spec cap)
775        (encapsulation-advice-when cap)
776        (encapsulation-advice-name cap)))
777 
778(defun advisedp-1 (function-spec when name)
779  (cond ((eq t function-spec)
780         (loop for c being the hash-value of *encapsulation-table*
781           when (and (eq (encapsulation-type c) 'advice)
782                     (or (null when)(eq when (encapsulation-advice-when c)))
783                     (or (null name)(equal name (encapsulation-advice-name c))))
784           collect (encapsulation-advice-spec c)))
785        (t (let* ((advise-thing (%encapsulation-thing function-spec))
786                  (capsules (%advice-encapsulations advise-thing when name)))
787             (mapcar #'encapsulation-advice-spec capsules)))))
788
789(defun %unadvise-1 (function-spec &optional when advice-name ignore)
790  (declare (ignore ignore))
791  (let ((advise-thing (%encapsulation-thing function-spec)))
792    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
793      (when capsules (unadvise-capsules capsules)))))
794
795(defun unadvise-capsules (capsules)
796  (let (val)
797    (dolist (capsule capsules)
798        (push (encapsulation-advice-spec capsule) val)
799        (remove-encapsulation capsule))
800    val))
801
802(defmacro unadvise (function &key when name)
803  (cond ((neq function t)
804         `(%unadvise-1 ',function ',when ',name))
805        (t '(%unadvise-all))))
806
807(defun %unadvise-all ()
808  (loop for cap being the hash-value of *encapsulation-table*
809    when (eq (encapsulation-type cap) 'advice)
810    collect (progn
811              (remove-encapsulation cap)
812              (encapsulation-advice-spec cap))))
813
814;; Called from %defun. Return t if we defined it, nil otherwise
815(defun %defun-encapsulated-maybe (name newdef)
816  (assert (not (get-encapsulation newdef)))
817  (let ((old-def (fboundp name)) cap)
818    (when (and old-def (setq cap (get-encapsulation name)))
819      (cond ((or (and *loading-files* *loading-removes-encapsulation*)
820                 ;; redefining a gf as a fn.
821                 (typep old-def 'standard-generic-function))
822             (forget-encapsulations name)
823             nil)
824            (t (set-unencapsulated-definition cap newdef)
825               T)))))
826
827;; Called from clos when change dcode
828(defun %set-encapsulated-gf-dcode (gf new-dcode)
829  (loop with cap = (get-encapsulation gf)
830    for gf-copy = (encapsulation-old-def cap)
831    as cur-dcode = (%gf-dcode gf-copy)
832    do (setq cap (get-encapsulation cur-dcode))
833    ;; refresh all the gf copies, in case other info in gf changed
834    do (%copy-function gf gf-copy)
835    do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
836    while cap))
837
838;; Called from clos when oldmethod is being replaced by newmethod in a gf.
839(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
840  (unless (eq oldmethod newmethod)
841    (cond ((and *loading-removes-encapsulation* *loading-files*)
842           (when (%traced-p oldmethod)
843             (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
844           (when (%advised-p oldmethod)
845             (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
846          (t (when (setq cap (get-encapsulation oldmethod))
847               (let* ((old-inner-def (find-unencapsulated-definition oldmethod))
848                      (newdef (%method-function newmethod))
849                      (olddef (%method-function oldmethod)))
850                 ;; make last encapsulation call new definition
851                 (set-unencapsulated-definition cap newdef)
852                 (setf (%method-function newmethod) olddef)
853                 (set-encapsulation-owner olddef newmethod)
854                 (setf (%method-function oldmethod) old-inner-def)
855                 (loop
856                   for def = olddef then (encapsulation-old-def cap)
857                   for cap = (get-encapsulation def) while cap
858                   do (copy-method-function-bits newdef def))))))))
859
860#|
861        Change History (most recent last):
862        2       12/29/94        akh     merge with d13
863|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.