source: branches/working-0711/ccl/lib/encapsulate.lisp @ 9847

Last change on this file since 9847 was 9847, checked in by gz, 12 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.

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

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.6 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-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.
219  (typecase spec
220    (symbol
221     ;; weed out macros and special-forms
222     (if (or (null spec) (special-operator-p spec) (macro-function spec))
223       (if error-p
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)
240    (cons
241     (case (car spec)
242       (:method 
243        (let ((gf (cadr spec))
244              (qualifiers (butlast (cddr spec)))
245              (specializers (car (last (cddr spec))))
246              method)
247          (setq specializers (require-type specializers 'list))
248          (prog ()
249            AGN
250            (cond ((setq method
251                         (find-method-by-names gf qualifiers specializers))
252                   (return method))
253                  (define-if-not
254                    (when (define-undefined-method spec gf qualifiers specializers)
255                      (go AGN)))
256                  (t (if error-p
257                       (error "Method ~s qualifiers ~s specializers ~s not found."
258                              gf qualifiers specializers)
259                       (return nil)))))))
260       (setf
261        (let ((name-or-fn (setf-function-spec-name spec)))
262          (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
263                ((functionp name-or-fn) ; it's anonymous - give it a name
264                 (let ((newname (gensym)))
265                   (%fhave newname name-or-fn)
266                   (store-setf-method (cadr spec) newname)
267                   newname)))))))
268    (t (if error-p
269         (error "Invalid trace spec ~s" spec)
270         nil))))
271
272(defun trace-null-def (&rest ignore)
273  (declare (ignore ignore)))
274
275(defun define-undefined-method (spec gf qualifiers specializers)
276  (let (vars def)   
277    (flet ((blob (e)
278                 (let ((v (gensym)))
279                   (push v vars)
280                   (list v e))))
281      (declare (dynamic-extent #'blob))
282      (setq def
283            (let ((lambda-list (mapcar #' blob specializers)))
284              (eval
285               `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore)
286                  (declare (ignore ignore ,@vars))))))
287      (when def (warn "~S was undefined" spec))
288      def)))
289
290(defun traceable-symbol-p (sym)
291  (and sym
292       (not (special-operator-p sym))
293       (not (macro-function sym))
294       (fboundp sym)))
295
296(defun %trace-package (pkg &rest args)
297  (declare (dynamic-extent args))
298  (do-present-symbols (sym pkg)
299    ;; Don't auto-trace imported symbols, because too often these are imported
300    ;; system functions...
301    (when (eq (symbol-package sym) pkg)
302      (when (traceable-symbol-p sym)
303        (apply #'trace-function sym args))
304      (when (or (%setf-method 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)))
308                  (traceable-symbol-p name)))
309        (apply #'trace-function `(setf ,sym) args)))))
310
311(defun trace-print-body (print-form)
312  (when print-form
313    (if (and (consp print-form) (eq (car print-form) 'values))
314      `((mapcar #'(lambda (name object)
315                    (trace-tab :in)
316                    (format *trace-output* "~s = ~s" name object))
317         ',(cdr print-form)
318         (list ,@(cdr print-form))))
319      `((let ((objects (multiple-value-list ,print-form))
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))))))))
328
329(defun trace-backtrace-body (test-form)
330  (when test-form
331    `((let ((test ,test-form))
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*))))))))
349
350(defun trace-inside-frame-p (name)
351  (if (packagep name)
352    (map-call-frames #'(lambda (p)
353                         (let* ((fn (cfp-lfun p))
354                                (fname (and fn (function-name fn)))
355                                (sym (typecase fname
356                                       (method (method-name fname))
357                                       (cons (and (setf-function-name-p fname) (cadr fname)))
358                                       (symbol fname)
359                                       (t nil))))
360                           (when (and sym (eq (symbol-package sym) name))
361                             (return-from trace-inside-frame-p t)))))
362    (let ((fn (%encap-binding name)))
363      (when fn
364        (map-call-frames #'(lambda (p)
365                             (when (eq (cfp-lfun p) fn)
366                               (return-from trace-inside-frame-p t))))))))
367
368(defun trace-package-spec (spec)
369  (when (or (stringp spec)
370            (packagep spec)
371            (and (consp spec) (eq (car spec) :package)))
372    (let ((pkg (if (consp spec)
373                 (destructuring-bind (pkg) (cdr spec) pkg)
374                 spec)))
375      (pkg-arg pkg))))
376
377(defun trace-function (spec &rest args &key before after methods
378                            (if t) (before-if t) (after-if t)
379                            print print-before print-after
380                            eval eval-before eval-after
381                            break break-before break-after
382                            backtrace backtrace-before backtrace-after
383                            inside
384                            define-if-not
385                            ;; Some synonyms, just to be nice
386                            (condition t) (if-before t) (if-after t) (wherein nil))
387
388  (declare (dynamic-extent args))
389  (let ((pkg (trace-package-spec spec)))
390    (when pkg
391      (return-from trace-function (apply #'%trace-package pkg args))))
392
393  ;; A little bit of dwim, after all this _is_ an interactive tool...
394  (unless (eq condition t)
395    (setq if (if (eq if t) condition `(and ,if ,condition))))
396  (unless (eq if-before t)
397    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
398  (unless (eq if-after t)
399    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
400  (when (and inside (trace-spec-p inside))
401    (setq inside (list inside)))
402  (when wherein
403    (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein))))
404  (case break
405    (:before (setq break-before (or break-before t) break nil))
406    (:after (setq break-after (or break-after t) break nil)))
407  (case backtrace
408    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
409    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
410  (case before
411    (:break (setq before :print break-before t))
412    (:backtrace (setq before :print backtrace-before t)))
413  (case after
414    (:break (setq after :print break-after t))
415    (:backtrace (setq after :print backtrace-after t)))
416
417  (when break
418    (setq break-before (if break-before
419                         `(and ,break ,break-before)
420                         break))
421    (setq break-after (if break-after
422                        `(and ,break ,break-after)
423                        break)))
424  (unless backtrace-before
425    (setq backtrace-before backtrace))
426  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
427    (setq backtrace-before `',backtrace-before))
428  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
429    (setq backtrace-after `',backtrace-after))
430
431  (when (and (null before) (null after))
432    (setq before :print)
433    (setq after :print))
434  (when (and (null before) backtrace-before)
435    (setq before :print))
436
437  (case before
438    ((:print :default) (setq before #'trace-before)))
439  (case after
440    ((:print :default) (setq after #'trace-after)))
441
442  (when (or (non-nil-symbol-p before) (functionp before))
443    (setq before `',before))
444  (when (or (non-nil-symbol-p after) (functionp after))
445    (setq after `',after))
446
447  (when inside
448    (let ((tests (loop for spec in inside
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))))
453      (setq if `(and ,if (or ,@tests)))))
454
455  (setq eval-before `(,@(trace-print-body print-before)
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))))))
464  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
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))))))
473
474  (prog1
475      (block %trace-block
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))))
532    (when *trace-hook*
533      (apply *trace-hook* spec args))))
534
535
536(defun %traced-p (thing)
537  (let ((cap (get-encapsulation thing)))
538    (and cap (eq (encapsulation-type cap) 'trace))))
539
540(defmacro untrace (&rest syms)
541  "Remove tracing from the specified functions. With no args, untrace all
542   functions."
543  (if syms
544    `(%untrace-0 ',syms)
545    `(%untrace-all)))
546
547(defun %untrace-0 (syms)
548  (let (val x)
549    (dolist (symbol syms)
550      (setq x (%untrace symbol))
551      (when x (push x val)))
552    val))
553
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)
568  (when (and (consp sym)(consp (car sym)))
569    (setq sym (car sym)))
570  (cond
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))))))
590  (when *untrace-hook*
591    (funcall *untrace-hook* sym))
592  (if (null (cdr val)) (car val) val))
593
594;; thing is a symbol or method - def is current definition
595;; we already know its traced
596(defun %untrace-1 (thing)
597  (let ((cap (get-encapsulation thing)))
598    (when (and cap (eq (encapsulation-type cap) 'trace))
599      (remove-encapsulation cap)
600      (encapsulation-spec cap))))
601
602(defun %untrace-pfun (sym)
603  (let ((len (length %pascal-functions%))
604        (sym-name (symbol-name sym)))
605    (declare (fixnum len))
606    (dotimes (i len)
607      (let ((pfe (%svref %pascal-functions% i)))
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))))
613    nil))
614
615
616
617(defmacro trace (&rest syms)
618  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
619
620TRACE is a debugging tool that provides information when specified
621functions are called."
622  (if syms
623    (let ((options (loop while (keywordp (car syms))
624                     nconc (list (pop syms) (pop syms)))))
625      `(%trace-0 ',syms ',options))
626    `(%trace-list)))
627
628(defun trace-spec-p (arg)
629  (or (atom arg)
630      (memq (car arg) '(:method setf :package))))
631
632
633(defun %trace-0 (syms &optional global-options)
634  (dolist (spec syms)
635    (if (trace-spec-p spec)
636      (apply #'trace-function spec global-options)
637      (apply #'trace-function (append spec global-options)))))
638
639(defun %trace-list ()
640  (let (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))
644    (dolist (x *trace-pfun-list*)
645      (push x res))
646    res))
647
648(defmacro with-traces (syms &body body)
649 `(unwind-protect
650       (progn
651         (let ((*trace-output* (make-broadcast-stream)))
652           ;; if you're tracing ccl internals you'll get trace output as it encapsulates the
653           ;; functions so hide all the trace output while eval'ing the trace form itself.
654           (trace ,@syms))
655         ,@body)
656    (untrace ,@syms)))
657
658;; this week def is the name of an uninterned gensym whose fn-cell is original def
659
660(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
661  (let ((saved-method-var (gensym))
662        (enable (gensym))
663        do-it)
664    (setq do-it
665          (cond #+old (step
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)))))
675                (t (if (and eval-before method-p)
676                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
677                     `(apply ',def args)))))
678    (compile-named-function-warn
679     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
680               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
681       (declare (dynamic-extent args))
682       (let ((*trace-level* (1+ *trace-level*))
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)))
704     `(traced ,sym))))
705
706; &method var tells compiler to bind var to contents of next-method-context
707(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
708  (let* ((saved-method-var (gensym)))
709    `(lambda (,@(if (and method-p (neq when :after))
710                  `(&method ,saved-method-var))
711              &rest arglist)
712       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
713       (let ()
714         ,(ecase
715            when
716            (:before
717             `(block nil
718                ,stuff                 
719                (return ,(if method-p
720                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
721                           `(apply ',def arglist)))))
722            (:after         
723             `(block nil
724                (let ((values (multiple-value-list (apply (function ,def) arglist))))
725                  ;(declare (dynamic-extent values))
726                  ,stuff
727                  (return (values-list values)))))
728            (:around
729             ;; stuff is e.g. (+ 5 (:do-it))
730             (if method-p 
731               `(macrolet ((:do-it ()
732                             `(apply-with-method-context ,',saved-method-var 
733                                                         (symbol-function ',',def)
734                                                         arglist)))
735                  (block nil
736                    (return  ,stuff)))
737               `(macrolet ((:do-it ()
738                             `(apply (function ,',def) arglist)))
739                  (block nil
740                    (return  ,stuff))))))))))
741
742
743(defun compile-named-function-warn (fn name)
744  (multiple-value-bind (result warnings)
745      (compile-named-function fn :name name)   
746    (when warnings 
747      (let ((first t))
748        (dolist (w warnings)
749          (signal-compiler-warning w first nil nil nil)
750          (setq first nil))))
751    result))
752
753       
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))
766
767(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
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)))
773    (when (%traced-p advise-thing)
774      ; make traced call advised
775      (setq orig-sym
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)
783  (let* ((newsym (gensym "ADVICE"))
784         ; WAS typep advise-thing 'method
785         (method-p (or (typep function 'method) ; can this happen?
786                       (and (consp function)(eq (car function) :method))))
787         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
788      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
789                 ,define-if-not)))
790
791(defmacro advisedp (function-spec &key when name)
792  `(advisedp-1 ',function-spec ',when ',name))
793
794(defun encapsulation-advice-spec (cap)
795  (list (encapsulation-spec cap)
796        (encapsulation-advice-when cap)
797        (encapsulation-advice-name cap)))
798 
799(defun advisedp-1 (function-spec when name)
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)
811  (declare (ignore ignore))
812  (let ((advise-thing (%encapsulation-thing function-spec)))
813    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
814      (when capsules (unadvise-capsules capsules)))))
815
816(defun unadvise-capsules (capsules)
817  (let (val)
818    (dolist (capsule capsules)
819        (push (encapsulation-advice-spec capsule) val)
820        (remove-encapsulation capsule))
821    val))
822
823(defmacro unadvise (function &key when name)
824  (cond ((neq function t)
825         `(%unadvise-1 ',function ',when ',name))
826        (t '(%unadvise-all))))
827
828(defun %unadvise-all ()
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
836(defun %defun-encapsulated-maybe (name newdef)
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))
843             (forget-encapsulations name)
844             nil)
845            (t (set-unencapsulated-definition cap newdef)
846               T)))))
847
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))))))))
880
881#|
882        Change History (most recent last):
883        2       12/29/94        akh     merge with d13
884|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.