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

Last change on this file since 9578 was 9578, checked in by gb, 12 years ago

propagate changes from working-0711-perf branch

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 38.7 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;; 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)
25(defvar *trace-pfun-list* nil)
26(defvar *trace-enable* t)
27(defvar *trace-level* 0)
28(defparameter *trace-max-indent* 40)
29(defvar *trace-print-level* nil)
30(defvar *trace-print-length* nil)
31;(defparameter *trace-define-if-undefined* nil)
32(defparameter *trace-bar-frequency* nil)
33(defvar *trace-hook* nil)
34(defvar *untrace-hook* nil)
35(defvar *trace-print-hook* nil)
36
37
38(defvar *advise-alist* nil)
39
40(defparameter *encapsulation-table*
41  (make-hash-table :test #'eq :rehash-size 2 :size 2))
42
43(defstruct (encapsulation)
44  symbol         ; the uninterned name containing original def
45  type           ; trace or advise
46  spec           ; the original function spec
47  advice-name    ; optional
48  advice-when    ; :before, :after, :around
49  owner          ; where encapsulation is installed
50)
51
52(defun setf-function-spec-name (spec)
53  (if (and (consp spec) (eq (car spec) 'setf))
54    (or (%setf-method (cadr spec)) ; this can be an anonymous function
55        (setf-function-name (cadr spec)))
56    spec))
57
58
59(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*)))
60  (fresh-line *trace-output*)
61  (dotimes (i (1- n))
62    (declare (fixnum i))
63    (write-char (if (and *trace-bar-frequency* 
64                         (eq 0 (mod i *trace-bar-frequency*)))
65                  #\| #\Space) *trace-output*))
66  (if (eq direction :in)
67    (format *trace-output* "~d> " (1- *trace-level*))
68    (format *trace-output* "<~d " (1- *trace-level*))))
69
70(defun trace-before  (&rest args)
71  (declare (dynamic-extent args))
72  (trace-tab :in)
73  (let* ((*print-level* *trace-print-level*)
74         (*print-length* *trace-print-length*)
75         (*print-readably* nil))
76    (format *trace-output* "Calling ~S ~%" args)
77    (force-output *trace-output*)))
78
79(defun trace-after (sym &rest args &aux (n (length args)))
80  (declare (dynamic-extent args))
81  (let* ((*print-level* *trace-print-level*)
82         (*print-length* *trace-print-length*)
83         (*print-readably* nil))
84    (if (eq n 1)
85      (progn
86        (trace-tab :out)
87        (format *trace-output* "~S returned ~S~%" sym (%car args)))
88      (progn
89        (trace-tab :out)
90        (format *trace-output* "~S returned ~S values :" sym n)
91        (dolist (val args)
92          (trace-tab :out)
93          (format *trace-output* "     ~S" val))))
94    (force-output *trace-output*)))
95
96(defun forget-encapsulations (name)
97  (when (%traced-p name)
98    (format t "~%... Untracing ~a" name) 
99    (%untrace-1 name))
100  (when (%advised-p name nil nil t)
101    (format t "~%... Unadvising ~a" name) 
102    (unadvise-1 name))
103  nil)
104
105(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
326  (typecase spec
327    (symbol
328     (if (or (null spec)(special-operator-p spec)(macro-function spec))
329       (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))
344    (cons
345     (case (car spec)
346       (:method 
347        (let ((gf (cadr spec))
348              (qualifiers (butlast (cddr spec)))
349              (specializers (car (last (cddr spec))))
350              method)
351          (setq specializers (require-type specializers 'list))
352          (prog ()
353            AGN
354            (cond ((setq method
355                         (find-method-by-names gf qualifiers specializers))
356                   (return (values (%method-function method) method)))
357                  (define-if-not
358                    (when (define-undefined-method spec gf qualifiers specializers)
359                      (go AGN)))
360                  (t (if error-p
361                       (error "Method ~s qualifiers ~s specializers ~s not found."
362                              gf qualifiers specializers)
363                       (return (values nil nil))))))))
364       (setf
365        (let ((name-or-fn (setf-function-spec-name spec)))
366          (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn))
367                ((functionp name-or-fn) ; it's anonymous - give it a name
368                 (let ((newname (gensym)))
369                   (%fhave newname name-or-fn)
370                   (store-setf-method (cadr spec) newname)
371                   (values name-or-fn newname))))))))
372    (t (if error-p
373         (error "Invalid trace spec ~s" spec)
374         (values nil nil)))))
375   
376
377(defun trace-null-def (&rest ignore)
378  (declare (ignore ignore)))
379
380(defun define-undefined-method (spec gf qualifiers specializers)
381  (let (vars def)   
382    (flet ((blob (e)
383                 (let ((v (gensym)))
384                   (push v vars)
385                   (list v e))))
386      (declare (dynamic-extent #'blob))
387      (setq def
388            (let ((lambda-list (mapcar #' blob specializers)))
389              (eval
390               `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore)
391                  (declare (ignore ignore ,@vars))))))
392      (when def (warn "~S was undefined" spec))
393      def)))
394
395(defun traceable-symbol-p (sym)
396  (and sym
397       (not (special-operator-p sym))
398       (not (macro-function sym))
399       (fboundp sym)))
400
401(defun %trace-package (pkg &rest args)
402  (declare (dynamic-extent args))
403  (do-present-symbols (sym pkg)
404    ;; Don't auto-trace imported symbols, because too often these are imported
405    ;; system functions...
406    (when (eq (symbol-package sym) pkg)
407      (when (traceable-symbol-p sym)
408        (apply #'trace-function sym args))
409      (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)))
413                  (traceable-symbol-p name)))
414        (apply #'trace-function `(setf ,sym) args)))))
415
416(defun trace-print-body (print-form)
417  (when print-form
418    (if (and (consp print-form) (eq (car print-form) 'values))
419      `((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))))
424      `((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))))))))
433
434(defun trace-backtrace-body (test-form)
435  (when test-form
436    `((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*))))))))
454
455(defun trace-inside-frame-p (name)
456  (if (packagep name)
457    (map-call-frames #'(lambda (p)
458                         (let* ((fn (cfp-lfun p))
459                                (fname (and fn (function-name fn)))
460                                (sym (typecase fname
461                                       (method (method-name fname))
462                                       (cons (and (setf-function-name-p fname) (cadr fname)))
463                                       (symbol fname)
464                                       (t nil))))
465                           (when (and sym (eq (symbol-package sym) name))
466                             (return-from trace-inside-frame-p t)))))
467    (let ((fn (typecase name
468                (symbol (fboundp name))
469                (method (%method-function name)))))
470      (when fn
471        (map-call-frames #'(lambda (p)
472                             (when (eq (cfp-lfun p) fn)
473                               (return-from trace-inside-frame-p t))))))))
474
475(defun trace-package-spec (spec)
476  (when (or (stringp spec)
477            (packagep spec)
478            (and (consp spec) (eq (car spec) :package)))
479    (let ((pkg (if (consp spec)
480                 (destructuring-bind (pkg) (cdr spec) pkg)
481                 spec)))
482      (pkg-arg pkg))))
483
484(defun trace-function (spec &rest args &key before after methods
485                            (if t) (before-if t) (after-if t)
486                            print print-before print-after
487                            eval eval-before eval-after
488                            break break-before break-after
489                            backtrace backtrace-before backtrace-after
490                            inside
491                            define-if-not
492                            ;; Some synonyms, just to be nice
493                            (condition t) (if-before t) (if-after t) (wherein nil))
494
495  (declare (dynamic-extent args))
496  (let ((pkg (trace-package-spec spec)))
497    (when pkg
498      (return-from trace-function (apply #'%trace-package pkg args))))
499
500  ;; A little bit of dwim, after all this _is_ an interactive tool...
501  (unless (eq condition t)
502    (setq if (if (eq if t) condition `(and ,if ,condition))))
503  (unless (eq if-before t)
504    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
505  (unless (eq if-after t)
506    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
507  (when (and inside (trace-spec-p inside))
508    (setq inside (list inside)))
509  (when wherein
510    (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein))))
511  (case break
512    (:before (setq break-before (or break-before t) break nil))
513    (:after (setq break-after (or break-after t) break nil)))
514  (case backtrace
515    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
516    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
517  (case before
518    (:break (setq before :print break-before t))
519    (:backtrace (setq before :print backtrace-before t)))
520  (case after
521    (:break (setq after :print break-after t))
522    (:backtrace (setq after :print backtrace-after t)))
523
524  (when break
525    (setq break-before (if break-before
526                         `(and ,break ,break-before)
527                         break))
528    (setq break-after (if break-after
529                        `(and ,break ,break-after)
530                        break)))
531  (unless backtrace-before
532    (setq backtrace-before backtrace))
533  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
534    (setq backtrace-before `',backtrace-before))
535  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
536    (setq backtrace-after `',backtrace-after))
537
538  (when (and (null before) (null after))
539    (setq before :print)
540    (setq after :print))
541  (when (and (null before) backtrace-before)
542    (setq before :print))
543
544  (case before
545    ((:print :default) (setq before #'trace-before)))
546  (case after
547    ((:print :default) (setq after #'trace-after)))
548
549  (when (or (non-nil-symbol-p before) (functionp before))
550    (setq before `',before))
551  (when (or (non-nil-symbol-p after) (functionp after))
552    (setq after `',after))
553
554  (when inside
555    (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))))
560      (setq if `(and ,if (or ,@tests)))))
561
562  (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))))))
571  (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))))))
580
581  (prog1
582      (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)))))))
654    (when *trace-hook*
655      (apply *trace-hook* spec args))))
656
657
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))))
663
664(defmacro untrace (&rest syms)
665  "Remove tracing from the specified functions. With no args, untrace all
666   functions."
667  (if syms
668    `(%untrace-0 ',syms)
669    `(%untrace-all)))
670
671(defun %untrace-0 (syms)
672  (let (val x)
673    (dolist (symbol syms)
674      (setq x (%untrace symbol))
675      (when x (push x val)))
676    val))
677
678
679(defun %untrace (sym)
680  (when (and (consp sym)(consp (car sym)))
681    (setq sym (car sym)))
682  (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)))))
703  (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))
718
719;; thing is a symbol or method - def is current definition
720;; we already know its traced
721(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)))
729
730(defun %untrace-pfun (sym)
731  (let ((len (length %pascal-functions%))
732        (sym-name (symbol-name sym)))
733    (declare (fixnum len))
734    (dotimes (i len)
735      (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))))
741    nil))
742
743
744
745(defmacro trace (&rest syms)
746  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
747
748TRACE is a debugging tool that provides information when specified
749functions are called."
750  (if syms
751    (let ((options (loop while (keywordp (car syms))
752                     nconc (list (pop syms) (pop syms)))))
753      `(%trace-0 ',syms ',options))
754    `(%trace-list)))
755
756(defun trace-spec-p (arg)
757  (or (atom arg)
758      (memq (car arg) '(:method setf :package))))
759
760
761(defun %trace-0 (syms &optional global-options)
762  (dolist (spec syms)
763    (if (trace-spec-p spec)
764      (apply #'trace-function spec global-options)
765      (apply #'trace-function (append spec global-options)))))
766
767(defun %trace-list ()
768  (let (res)
769    (dolist (x *trace-alist*)
770      (push (encapsulation-spec x) res))
771    (dolist (x *trace-pfun-list*)
772      (push x res))
773    res))
774
775(defmacro with-traces (syms &body body)
776 `(unwind-protect
777       (progn
778         (let ((*trace-output* (make-broadcast-stream)))
779           ;; if you're tracing ccl internals you'll get trace output as it encapsulates the
780           ;; functions so hide all the trace output while eval'ing the trace form itself.
781           (trace ,@syms))
782         ,@body)
783    (untrace ,@syms)))
784
785;; this week def is the name of an uninterned gensym whose fn-cell is original def
786
787(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
788  (let ((saved-method-var (gensym))
789        (enable (gensym))
790        do-it)
791    (setq do-it
792          (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)))))
802                (t (if (and eval-before method-p)
803                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
804                     `(apply ',def args)))))
805    (compile-named-function-warn
806     `(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?
808       (declare (dynamic-extent args))
809       (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)))
831     `(traced ,sym))))
832
833; &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))
836  (let* ((saved-method-var (gensym)))
837    `(lambda (,@(if (and method-p (neq when :after))
838                  `(&method ,saved-method-var))
839              &rest arglist)
840      ;(declare (dynamic-extent arglist))
841       (let ()
842         ,(ecase
843            when
844            (:before
845             `(block nil
846                ,stuff                 
847                (return ,(if method-p
848                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
849                           `(apply ',def arglist)))))
850            (:after         
851             `(block nil
852                (let ((values (multiple-value-list (apply (function ,def) arglist))))
853                  ;(declare (dynamic-extent values))
854                  ,stuff
855                  (return (values-list values)))))
856            (:around
857             ;; stuff is e.g. (+ 5 (:do-it))
858             (if method-p 
859               `(macrolet ((:do-it ()
860                             `(apply-with-method-context ,',saved-method-var 
861                                                         (symbol-function ',',def)
862                                                         arglist)))
863                  (block nil
864                    (return  ,stuff)))
865               `(macrolet ((:do-it ()
866                             `(apply (function ,',def) arglist)))
867                  (block nil
868                    (return  ,stuff))))))))))
869
870
871(defun compile-named-function-warn (fn name)
872  (multiple-value-bind (result warnings)
873      (compile-named-function fn :name name)   
874    (when warnings 
875      (let ((first t))
876        (dolist (w warnings)
877          (signal-compiler-warning w first nil nil nil)
878          (setq first nil))))
879    result))
880
881;; want to look like
882;; (setq values (multiple-value-list (progn ,@frob)))
883     
884       
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
899
900(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))
905    (when (%traced-p advise-thing)
906      (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)
936  (let* ((newsym (gensym "ADVICE"))
937         ; WAS typep advise-thing 'method
938         (method-p (or (typep function 'method) ; can this happen?
939                       (and (consp function)(eq (car function) :method))))
940         (newdef (advise-global-def function newsym when form method-p)))
941      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
942                 ,define-if-not)))
943
944(defmacro advisedp (function-spec &key when name)
945  `(advisedp-1 ',function-spec ',when ',name))
946
947(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)
967  (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)))
970      (when capsules (unadvise-capsules capsules)))))
971
972(defun unadvise-capsules (capsules)
973  (let (val)
974    (dolist (capsule capsules)
975        (push (list (encapsulation-spec capsule)
976                    (encapsulation-advice-when capsule)
977                    (encapsulation-advice-name capsule))
978              val)
979        (remove-encapsulation capsule))
980    val))
981
982(defmacro unadvise (function &key when name)
983  (cond ((neq function t)
984         `(unadvise-1 ',function ',when ',name))
985        (t '(%unadvise-all))))
986
987(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
1005(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))
1009             (forget-encapsulations name)
1010             nil)
1011            (t (%set-unencapsulated-definition name newdef)
1012               T)))))
1013
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
1049
1050#|
1051        Change History (most recent last):
1052        2       12/29/94        akh     merge with d13
1053|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.