[Openmcl-cvs-notifications] r9844 - in /trunk/source: level-0/PPC/ppc-def.lisp level-0/X86/x86-def.lisp level-0/l0-def.lisp level-1/l1-clos-boot.lisp level-1/l1-clos.lisp level-1/l1-dcode.lisp level-1/l1-utils.lisp lib/edit-callers.lisp lib/encapsulate.lisp
gz at clozure.com
gz at clozure.com
Fri Jun 27 14:28:43 EDT 2008
Author: gz
Date: Fri Jun 27 14:28:43 2008
New Revision: 9844
Log:
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, declare=
s 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 e=
xtent
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 origin=
al
dcode. Now, we just save a copy of the original gf code and jump to it. T=
his
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-pro=
to*
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 th=
at
will be hard to fix).
Modified:
trunk/source/level-0/PPC/ppc-def.lisp
trunk/source/level-0/X86/x86-def.lisp
trunk/source/level-0/l0-def.lisp
trunk/source/level-1/l1-clos-boot.lisp
trunk/source/level-1/l1-clos.lisp
trunk/source/level-1/l1-dcode.lisp
trunk/source/level-1/l1-utils.lisp
trunk/source/lib/edit-callers.lisp
trunk/source/lib/encapsulate.lisp
Modified: trunk/source/level-0/PPC/ppc-def.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/PPC/ppc-def.lisp (original)
+++ trunk/source/level-0/PPC/ppc-def.lisp Fri Jun 27 14:28:43 2008
@@ -1232,6 +1232,16 @@
(bctr))
=
=
+(defun %copy-function (proto &optional target)
+ (let* ((total-size (uvsize proto))
+ (new (or target (allocate-typed-vector :function total-size))))
+ (declare (fixnum total-size))
+ (when target
+ (unless (eql total-size (uvsize target))
+ (error "Wrong size target ~s" target)))
+ (%copy-gvector-to-gvector proto 0 new 0 total-size)
+ new))
+
(defun replace-function-code (target-fn proto-fn)
(if (typep target-fn 'function)
(if (typep proto-fn 'function)
Modified: trunk/source/level-0/X86/x86-def.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/X86/x86-def.lisp (original)
+++ trunk/source/level-0/X86/x86-def.lisp Fri Jun 27 14:28:43 2008
@@ -111,6 +111,23 @@
((null imms) (%function-vector-to-function newv))
(declare (fixnum k) (list imms))
(setf (%svref newv k) (car imms)))))
+
+(defun %copy-function (proto &optional target)
+ (let* ((protov (%function-to-function-vector proto))
+ (code-words (%function-code-words proto))
+ (total-words (uvsize protov))
+ (newv (if target
+ (%function-to-function-vector target)
+ (allocate-typed-vector :function total-words))))
+ (declare (fixnum code-words total-words))
+ (when target
+ (unless (and (eql code-words (%function-code-words target))
+ (eql total-words (uvsize newv)))
+ (error "Wrong size target ~s" target)))
+ (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words =
target::word-shift)))
+ (loop for k fixnum from code-words below total-words
+ do (setf (%svref newv k) (%svref protov k)))
+ (%function-vector-to-function newv)))
=
(defun replace-function-code (target proto)
(let* ((target-words (%function-code-words target))
Modified: trunk/source/level-0/l0-def.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-def.lisp (original)
+++ trunk/source/level-0/l0-def.lisp Fri Jun 27 14:28:43 2008
@@ -86,16 +86,6 @@
=
(%fhave 'encapsulated-function-name ;Redefined in encapsulate - used in l=
1-io
(qlfun bootstrapping-encapsulated-function-name (fn)
- (declare (ignore fn))
- nil))
-
-(%fhave '%traced-p ;Redefined in encapsulate - used in l1-io
- (qlfun bootstrapping-%traced-p (fn)
- (declare (ignore fn))
- nil))
-
-(%fhave '%advised-p ;Redefined in encapsulate used in l1-io
- (qlfun bootstrapping-%advised-p (fn)
(declare (ignore fn))
nil))
=
Modified: trunk/source/level-1/l1-clos-boot.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos-boot.lisp (original)
+++ trunk/source/level-1/l1-clos-boot.lisp Fri Jun 27 14:28:43 2008
@@ -536,25 +536,19 @@
)
;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;
=
-(%fhave 'function-encapsulation ;Redefined in encapsulate
- (qlfun bootstrapping-function-encapsulation (name)
- (declare (ignore name))
- nil))
-
(%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate
(qlfun boot-%move-method-encapsulations-maybe (m1 m2)
(declare (ignore m1 m2))
nil))
=
-
(%fhave 'find-unencapsulated-definition ;Redefined in encapsulate
- (qlfun bootstrapping-unenecapsulated-def (spec)
- (values
- (typecase spec
- (symbol (fboundp spec))
- (method (%method-function spec))
- (t spec))
- spec)))
+ (qlfun bootstrapping-find-unencapsulated-definition (fn)
+ fn))
+
+(%fhave 'function-encapsulated-p ;Redefined in encapsulate
+ (qlfun bootstrapping-function-encapsulated-p (fn)
+ (declare (ignore fn))
+ nil))
=
(let* ((class-wrapper-random-state (make-random-state))
(class-wrapper-random-state-lock (make-lock)))
@@ -566,11 +560,9 @@
=
=
(defun %inner-method-function (method)
- (let ((f (%method-function method)))
- (when (function-encapsulation f)
- (setq f (find-unencapsulated-definition f)))
- (closure-function f)))
-
+ (closure-function
+ (find-unencapsulated-definition
+ (%method-function method))))
=
(defun copy-method-function-bits (from to)
(let ((new-bits (logior (logand (logior (lsh 1 $lfbits-method-bit)
@@ -707,10 +699,6 @@
method))
=
=
-(defun forget-encapsulations (name)
- (declare (ignore name))
- nil)
-
(defun %anonymous-method (function specializers qualifiers lambda-list &o=
ptional documentation
&aux name method-class)
(let ((inner-function (closure-function function)))
@@ -775,9 +763,7 @@
(defun %method-function-method (method-function)
(setq method-function
(closure-function
- (if (function-encapsulation method-function)
- (find-unencapsulated-definition method-function)
- method-function)))
+ (find-unencapsulated-definition method-function)))
(setq method-function (require-type method-function 'method-function))
(lfun-name method-function))
=
@@ -1092,27 +1078,15 @@
(min multi-method-index min-index)
multi-method-index)
0))
- (let* ((old-dcode (%gf-dcode gf))
- (encapsulated-dcode-cons (and (combined-method-p old-dcode)
- (eq '%%call-gf-encapsulation =
- (function-name (%combined=
-method-dcode old-dcode)))
- (cdr (%combined-method-method=
s old-dcode)))))
- (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr enc=
apsulated-dcode-cons) old-dcode))
+ (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf))))
+ (when (or non-dt
+ (neq dcode old-dcode)
(neq multi-method-index (%gf-dispatch-table-argnum dt)=
))
- (let* ((proto (if non-dt
- #'funcallable-trampoline
- (or (cdr (assq dcode dcode-proto-alist)) *gf-p=
roto*))))
- (clear-gf-dispatch-table dt)
- (setf (%gf-dispatch-table-argnum dt) multi-method-index)
- (if encapsulated-dcode-cons ; and more?
- (let ((old-gf (car encapsulated-dcode-cons)))
- (if (not (typep old-gf 'generic-function))
- (error "Confused"))
- ;(setf (uvref old-gf 0)(uvref proto 0))
- (setf (cdr encapsulated-dcode-cons) dcode))
- (progn =
- (setf (%gf-dcode gf) dcode)
- (replace-function-code gf proto))))))
+ (clear-gf-dispatch-table dt)
+ (setf (%gf-dispatch-table-argnum dt) multi-method-index)
+ (if (function-encapsulated-p gf)
+ (%set-encapsulated-gf-dcode gf dcode)
+ (setf (%gf-dcode gf) dcode))))
(values dcode multi-method-index)))))
=
(defun inherits-from-standard-generic-function-p (class)
Modified: trunk/source/level-1/l1-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos.lisp (original)
+++ trunk/source/level-1/l1-clos.lisp Fri Jun 27 14:28:43 2008
@@ -1438,10 +1438,7 @@
(defmethod initialize-instance :before ((instance generic-function)
&key &allow-other-keys)
=
- (replace-function-code instance *gf-proto*)
- (setf (gf.dcode instance) #'%%0-arg-dcode))
- =
- =
+ (setf (%gf-dcode instance) #'%%0-arg-dcode))
=
(defmethod initialize-instance :after ((gf standard-generic-function)
&key
@@ -1704,8 +1701,7 @@
(error "~S is not a funcallable instance" funcallable-instance))
(unless (functionp function)
(error "~S is not a function" function))
- (replace-function-code funcallable-instance #'funcallable-trampoline)
- (setf (gf.dcode funcallable-instance) function))
+ (setf (%gf-dcode funcallable-instance) function))
=
(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-othe=
r-keys)
(error "Can't reinitialize ~s" slotd))
@@ -2029,9 +2025,6 @@
#'%%1st-two-arg-eql-method-hack-dcode)
(t
#'%%1st-arg-eql-method-hack-dcode)))))
-
- =
- =
=
=
(defun maybe-hack-eql-methods (gf)
Modified: trunk/source/level-1/l1-dcode.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-dcode.lisp (original)
+++ trunk/source/level-1/l1-dcode.lisp Fri Jun 27 14:28:43 2008
@@ -514,12 +514,15 @@
;(require-type gf 'standard-generic-function)
(gf.dcode gf))
=
-(defun %set-gf-dcode (gf val)
- (setf (gf.dcode gf) val))
+(defun %set-gf-dcode (gf dcode)
+ (let ((gf (require-type gf 'standard-generic-function))
+ (dcode (require-type dcode 'function)))
+ (replace-function-code gf (or (cdr (assq dcode dcode-proto-alist))
+ #'funcallable-trampoline))
+ (setf (gf.dcode gf) dcode)))
=
(defun %set-gf-dispatch-table (gf val)
(setf (gf.dispatch-table gf) val))
-
=
(defun %combined-method-methods (cm)
;(require-type cm 'combined-method)
@@ -824,7 +827,7 @@
(when (null args) (dcode-too-few-args 0 (%gf-dispatch-table-gf dt)))
(let ((method (%find-1st-arg-combined-method dt (%car args))))
(apply method args)))))
-
+(register-dcode-proto #'%%1st-arg-dcode *gf-proto*)
=
(defun %%one-arg-dcode (dt arg)
(let ((method (%find-1st-arg-combined-method dt arg)))
@@ -853,7 +856,7 @@
(when (>=3D argnum args-len) (dcode-too-few-args args-len (%gf-dispa=
tch-table-gf dt)))
(let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args arg=
s-len argnum) args)))
(%apply-lexpr-tail-wise method args)))))
-
+(register-dcode-proto #'%%nth-arg-dcode *gf-proto*)
=
(defun 0-arg-combined-method-trap (gf)
(let* ((methods (%gf-methods gf))
Modified: trunk/source/level-1/l1-utils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-utils.lisp (original)
+++ trunk/source/level-1/l1-utils.lisp Fri Jun 27 14:28:43 2008
@@ -377,8 +377,6 @@
"This function simply returns what was passed to it."
x)
=
-(%fhave 'find-unencapsulated-definition #'identity)
-
(defun coerce-to-function (arg)
(if (functionp arg)
arg
Modified: trunk/source/lib/edit-callers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/edit-callers.lisp (original)
+++ trunk/source/lib/edit-callers.lisp Fri Jun 27 14:28:43 2008
@@ -134,11 +134,11 @@
(or (global-function-p function)
(pascal-function-p function)
(let ((name (function-name function)))
- (and name (function-encapsulation name) name))
+ (and name (function-encapsulated-p name) name))
(let ((caller function) next)
(loop
(setq next (gethash caller *function-parent-table*))
- (if next =
+ (if next
(cond ((consp next)
(when (null the-list)(push function the-list))
(return
Modified: trunk/source/lib/encapsulate.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/encapsulate.lisp (original)
+++ trunk/source/lib/encapsulate.lisp Fri Jun 27 14:28:43 2008
@@ -16,12 +16,9 @@
=
(in-package "CCL")
=
-;; Lets try encapsulations
-;; trace is here too
-;; Make trace like 1.3, trace methods, trace (setf car)
-
-
-(defvar *trace-alist* nil)
+(defvar *loading-removes-encapsulation* nil
+ "If true, loading a new method definition from a file will remove any tr=
acing and advice on the method")
+
(defvar *trace-pfun-list* nil)
(defvar *trace-enable* t)
(defvar *trace-level* 0)
@@ -34,11 +31,24 @@
(defvar *untrace-hook* nil)
(defvar *trace-print-hook* nil)
=
-
-(defvar *advise-alist* nil)
+;;;
+;;; We support encapsulating three types of objects, i.e. modifying their=
definition
+;;; without changing their identity:
+;;; 1. symbol - via the symbol-function slot
+;;; 2. method - via the %method-function slot
+;;; 3. standard-generic-function - via the %gf-dcode slot
+;;;
+;;; Encapsulation is effected by creating a new compiled function and stor=
ing it in the
+;;; slot above. The new function references a gensym fbound to the origina=
l definition
+;;; (except in the case of a gf, the gensym is fbound to a copy of the gf =
which in
+;;; turn contains the original dcode, since we can't invoke the dcode dire=
ctly).
+;;; In addition, an ENCAPSULATION struct describing the encapsulation is c=
reated and
+;;; stored in the *encapsulation-table* with the new compiled function as =
the key.
+;;;
+;;; =
=
(defparameter *encapsulation-table*
- (make-hash-table :test #'eq :rehash-size 2 :size 2))
+ (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t))
=
(defstruct (encapsulation)
symbol ; the uninterned name containing original def
@@ -46,8 +56,11 @@
spec ; the original function spec
advice-name ; optional
advice-when ; :before, :after, :around =
- owner ; where encapsulation is installed
+ owner ; where encapsulation is installed (can change)
)
+
+(defun encapsulation-old-def (cap)
+ (fboundp (encapsulation-symbol cap)))
=
(defun setf-function-spec-name (spec)
(if (and (consp spec) (eq (car spec) 'setf))
@@ -55,14 +68,13 @@
(setf-function-name (cadr spec)))
spec))
=
-
(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*)=
))
(fresh-line *trace-output*)
(dotimes (i (1- n))
(declare (fixnum i))
(write-char (if (and *trace-bar-frequency* =
- (eq 0 (mod i *trace-bar-frequency*)))
- #\| #\Space) *trace-output*))
+ (eq 0 (mod i *trace-bar-frequency*)))
+ #\| #\Space) *trace-output*))
(if (eq direction :in)
(format *trace-output* "~d> " (1- *trace-level*))
(format *trace-output* "<~d " (1- *trace-level*))))
@@ -97,222 +109,124 @@
(when (%traced-p name)
(format t "~%... Untracing ~a" name) =
(%untrace-1 name))
- (when (%advised-p name nil nil t)
+ (when (%advised-p name)
(format t "~%... Unadvising ~a" name) =
- (unadvise-1 name))
+ (%unadvise-1 name))
nil)
=
(defun function-encapsulated-p (fn-or-method)
- (typecase fn-or-method
- ((or method symbol cons)(function-encapsulation fn-or-method))
- (function
- (or (function-traced-p fn-or-method)
- (function-advised-p fn-or-method )))))
-
-(defun function-traced-p (fn)
- (%function-in-alist fn *trace-alist*))
-
-(defun function-advised-p (fn)
- (%function-in-alist fn *advise-alist*)) =
-
-(defun %function-in-alist (def list)
- (dolist (cap list)
- (let ((symbol (encapsulation-owner cap)))
- (typecase symbol
- (symbol (when (eq (fboundp symbol) def)
- (return cap)))
- (method (when (eq (%method-function symbol) def)
- (return cap)))
- (standard-generic-function
- (when (eq symbol def) (return cap)))))))
-
-(defun function-encapsulation (spec)
- (typecase spec
- ((or symbol method)
- (gethash spec *encapsulation-table*))
- (function (function-encapsulated-p spec))
- (cons (gethash (setf-function-spec-name spec) *encapsulation-table*))))
-;; i.e. old 68K clos - vs 68K target with new clos
-
-
-
-
-; she works now - does the equivalent of the original gf - called from tra=
ced def
-(defun %%call-encapsulated-gf (thing args)
- ; (print 'one)(print thing)(print args)
- ; thing is gf . %%1st-arg-dcode
- ; args is ok
- (let* ((dcode (cdr thing))
- (proto (assq dcode dcode-proto-alist)) ; <<
- (dt (%gf-dispatch-table (car thing))))
- (if proto ; assume all of these special dudes want args individually =
- (if (listp args)
- (apply dcode dt args)
- (%apply-lexpr dcode dt args))
- (funcall dcode dt args))))
- =
-
-
- ; (apply encapsulation args)
-
-
-;; the dcode function of the original gf has been bashed with a combined m=
ethod whose
-;; dcode function is this. So the combined method is called with 2 args (d=
ispatch-table
-;; and args to the gf). The combined method in turn makes a lexpr of those=
2 args.
-
-(defun %%call-gf-encapsulation (thing args)
- ; (print 'two)(print thing)(print (if (listp args) args (collect-lexpr-a=
rgs args 0)))
- ; thing traced-blitz gf-blitz . %%1st-arg-dcode =
- ; args =3D dispatch-table . original-args
- ; dont need dispatch-table - its just there as a side effect
- (if (listp args) ; this probably never happens
- (let ((orig-args (cadr args)))
- (if (listp orig-args)
- (apply (car thing) orig-args)
- (%apply-lexpr (car thing) orig-args)))
- (let* ((orig-args (%lexpr-ref args (%lexpr-count args) 1)))
- (if (listp orig-args)
- (apply (car thing) orig-args)
- ; knee deep in lexprs
- (%apply-lexpr (car thing) orig-args)))))
- =
-
-(defun encapsulate (fn-spec old-def type trace-spec newsym
- &optional advice-name advice-when)
- (let ((capsule (function-encapsulation fn-spec))
- gf-dcode old-encapsulation)
- (%fhave newsym
- (if (standard-generic-function-p old-def)
- (let ((dcode (%gf-dcode old-def)))
- (setq gf-dcode
- (if (and (combined-method-p dcode)
- (eq '%%call-gf-encapsulation
- (function-name (%combined-method-dcode =
dcode))))
- (let ((stuff (%combined-method-methods dcode)))
- (setq old-encapsulation (car stuff))
- (cdr stuff))
- (cons old-def dcode)))
- (replace-function-code old-def *gf-proto*) ; << gotta re=
member to fix it
- (or old-encapsulation
- (%cons-combined-method old-def gf-dcode #'%%call-encap=
sulated-gf)))
- old-def)) ; make new symbol call old definit=
ion
- ;; move the encapsulation from fn-spec to sym =
- (cond (capsule (put-encapsulation newsym capsule))) =
- (put-encapsulation fn-spec
- (make-encapsulation
- :symbol newsym
- :type type
- :spec trace-spec
- :advice-name advice-name
- :advice-when advice-when))
- (values newsym gf-dcode)))
- =
-
-;; call with cap nil to remove - for symbol anyway
-;; maybe advising methods is silly - just define a before method
-
-(defun put-encapsulation (spec cap)
- (when cap
- (setf (encapsulation-owner cap) spec)
- (record-encapsulation cap)
- )
- (let ((key (typecase spec
- ((or symbol method standard-generic-function) spec)
- (cons (setf-function-spec-name spec))
- (t (report-bad-arg spec '(or symbol method cons))))))
- (if cap
- (setf (gethash key *encapsulation-table*) cap)
- (remhash key *encapsulation-table*)))
- cap)
-
-(defun remove-encapsulation (capsule &optional dont-replace)
- ; optional don't replace is for unadvising, tracing all on a method
- (let (spec nextsym newdef def)
- (setq spec (encapsulation-owner capsule))
- (setq def (typecase spec
- (symbol (fboundp spec))
- (method spec)))
- (setq nextsym (encapsulation-symbol capsule))
- (setq newdef (fboundp nextsym))
- (without-interrupts
- (if (standard-generic-function-p def)
- (if (and (combined-method-p newdef)
- (eq '%%call-encapsulated-gf (function-name (%combined-meth=
od-dcode newdef))))
- (let* ((orig-decode (require-type (cdr (%combined-method-methods =
newdef)) 'function))
- (proto (cdr (assq orig-decode dcode-proto-alist)))
- ) ; <<
- (setf (%gf-dcode def) orig-decode)
- (replace-function-code def (or proto #'funcallable-trampoline)))
- (setf (car (%combined-method-methods (%gf-dcode def))) newdef))
- (typecase spec
- (symbol (%fhave spec newdef))
- (method (setf (%method-function spec) newdef)
- (remove-obsoleted-combined-methods spec)
- newdef)))
- (put-encapsulation spec
- (if (null dont-replace)
- (function-encapsulation nextsym)))
- (put-encapsulation nextsym nil)
- (unrecord-encapsulation capsule)
- )))
-
-
-(defun record-encapsulation (capsule)
- (ecase (encapsulation-type capsule)
- (trace
- (when (not (memq capsule *trace-alist*))
- (push capsule *trace-alist*)))
- (advice
- (when (not (memq capsule *advise-alist*))
- (push capsule *advise-alist*)))))
-
-(defun unrecord-encapsulation (capsule)
- (ecase (encapsulation-type capsule)
- (trace
- (setq *trace-alist* (delq capsule *trace-alist*)))
- (advice
- (setq *advise-alist* (delq capsule *advise-alist*)))))
-
-
-(defun find-unencapsulated-definition (spec)
- ;; spec is a symbol, function, or method object
- ;; returns a raw function ?? =
- (let (foo)
- (while (setq foo (function-encapsulation spec))
- (setq spec (encapsulation-symbol foo)))
- (values
- (typecase spec
- (symbol (fboundp spec))
- (method (%method-function spec))
- (t spec))
- spec)))
-
-(defun %trace-fboundp (spec)
- (typecase spec
- (symbol (fboundp spec))
- (method (%method-function spec))))
-
-
-(defun %trace-function-spec-p (spec &optional define-if-not undefined-ok (=
error-p t))
- ;; weed out macros and special-forms
+ (get-encapsulation fn-or-method))
+
+(defun %encap-binding (thing)
+ (require-type (etypecase thing
+ (symbol (fboundp thing))
+ (method (%method-function thing)))
+ 'function))
+
+(defun get-encapsulation (spec)
+ (let* ((key (typecase spec
+ (symbol (let* ((def (fboundp spec)))
+ (if (generic-function-p def)
+ (%gf-dcode def)
+ def)))
+ (method (%method-function spec))
+ (standard-generic-function (%gf-dcode spec))
+ (function spec)))
+ (cap (gethash key *encapsulation-table*)))
+ #+gz (assert (or (null cap)
+ (let ((fn (%encap-binding (encapsulation-owner cap))))
+ (eq (if (standard-generic-function-p fn) (%gf-dcode=
fn) fn) key))))
+ cap))
+
+(defun set-encapsulation-owner (fn owner)
+ (let ((cap (get-encapsulation fn)))
+ (when cap
+ (setf (encapsulation-owner cap) owner))))
+
+(defun put-encapsulation (fn cap)
+ (let* ((owner (encapsulation-owner cap))
+ (old-def (%encap-binding owner))
+ (newsym (encapsulation-symbol cap)))
+ (setf (gethash fn *encapsulation-table*) cap)
+ (set-encapsulation-owner old-def newsym)
+ (etypecase owner
+ (symbol
+ (cond ((standard-generic-function-p old-def)
+ (%fhave newsym (%copy-function old-def))
+ (setf (%gf-dcode old-def) fn))
+ (t
+ (%fhave newsym old-def)
+ (%fhave owner fn))))
+ (method
+ (%fhave newsym old-def)
+ (setf (%method-function owner) fn)
+ (remove-obsoleted-combined-methods owner)))))
+
+(defun remove-encapsulation (cap)
+ (let* ((owner (encapsulation-owner cap))
+ (cur-def (%encap-binding owner))
+ (old-def (encapsulation-old-def cap)))
+ (assert (eq cap (get-encapsulation cur-def)))
+ (set-encapsulation-owner old-def owner)
+ (typecase owner
+ (symbol
+ (cond ((standard-generic-function-p cur-def)
+ (remhash (%gf-dcode cur-def) *encapsulation-table*)
+ (setf (%gf-dcode cur-def) (%gf-dcode old-def)))
+ (t
+ (remhash cur-def *encapsulation-table*)
+ (%fhave owner old-def))))
+ (method
+ (remhash cur-def *encapsulation-table*)
+ (setf (%method-function owner) old-def)
+ (remove-obsoleted-combined-methods owner)))))
+
+
+(defun encapsulate (owner newdef type trace-spec newsym &optional advice-n=
ame advice-when)
+ (let ((cap (make-encapsulation
+ :owner owner
+ :symbol newsym
+ :type type
+ :spec trace-spec
+ :advice-name advice-name
+ :advice-when advice-when)))
+ (put-encapsulation newdef cap)
+ cap))
+
+(defun find-unencapsulated-definition (fn)
+ (when fn
+ (loop for cap =3D (get-encapsulation fn) while cap
+ do (setq fn (encapsulation-old-def cap)))
+ fn))
+
+(defun set-unencapsulated-definition (cap newdef)
+ (loop for owner =3D (encapsulation-symbol cap)
+ do (setq cap (get-encapsulation owner)) while cap
+ finally (%fhave owner newdef)))
+
+(defun %encapsulation-thing (spec &optional define-if-not (error-p t))
+ ;; Returns either an fboundp symbol or a method, or nil.
(typecase spec
(symbol
- (if (or (null spec)(special-operator-p spec)(macro-function spec))
+ ;; weed out macros and special-forms
+ (if (or (null spec) (special-operator-p spec) (macro-function spec))
(if error-p
- (error "Cannot trace or advise ~S" spec)
- (values nil nil))
- (let ((res (or (fboundp spec)(and define-if-not
- (progn (warn "~S was undefined" spec)
- (%fhave spec (%function 'trace-null-def)))))))
- (if res
- (values res spec)
- (if undefined-ok
- (values nil spec)
- (if error-p
- (error "~S is undefined." spec)
- (values nil nil)))))))
- (method
- (values (%method-function spec) spec))
+ (error "Cannot trace or advise ~a~S" spec
+ (cond ((null spec) "")
+ ((special-operator-p spec) "special operator ")
+ (t "macro ")))
+ nil)
+ (if (or (fboundp spec)
+ (and define-if-not
+ (progn
+ (warn "~S was undefined" spec)
+ (%fhave spec (%function 'trace-null-def))
+ t)))
+ spec
+ (if error-p
+ (error "~S is undefined." spec)
+ nil))))
+ (method spec)
(cons
(case (car spec)
(:method =
@@ -325,26 +239,25 @@
AGN
(cond ((setq method
(find-method-by-names gf qualifiers specializers))
- (return (values (%method-function method) method)))
+ (return method))
(define-if-not
(when (define-undefined-method spec gf qualifiers spec=
ializers)
(go AGN)))
(t (if error-p
- (error "Method ~s qualifiers ~s specializers ~s not found."
- gf qualifiers specializers)
- (return (values nil nil))))))))
+ (error "Method ~s qualifiers ~s specializers ~s not=
found."
+ gf qualifiers specializers)
+ (return nil)))))))
(setf
(let ((name-or-fn (setf-function-spec-name spec)))
- (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn))
+ (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
((functionp name-or-fn) ; it's anonymous - give it a name
(let ((newname (gensym)))
(%fhave newname name-or-fn)
(store-setf-method (cadr spec) newname)
- (values name-or-fn newname))))))))
+ newname)))))))
(t (if error-p
- (error "Invalid trace spec ~s" spec)
- (values nil nil)))))
- =
+ (error "Invalid trace spec ~s" spec)
+ nil))))
=
(defun trace-null-def (&rest ignore)
(declare (ignore ignore)))
@@ -377,52 +290,52 @@
;; system functions...
(when (eq (symbol-package sym) pkg)
(when (traceable-symbol-p sym)
- (apply #'trace-function sym args))
+ (apply #'trace-function sym args))
(when (or (%setf-method sym)
- ;; Not really right. Should construct the name if doesn't exist.
- ;; But that would create a lot of garbage for little gain...
- (let ((name (existing-setf-function-name sym)))
+ ;; Not really right. Should construct the name if doesn't=
exist.
+ ;; But that would create a lot of garbage for little gain.=
..
+ (let ((name (existing-setf-function-name sym)))
(traceable-symbol-p name)))
- (apply #'trace-function `(setf ,sym) args)))))
+ (apply #'trace-function `(setf ,sym) args)))))
=
(defun trace-print-body (print-form)
(when print-form
(if (and (consp print-form) (eq (car print-form) 'values))
`((mapcar #'(lambda (name object)
- (trace-tab :in)
- (format *trace-output* "~s =3D ~s" name object))
- ',(cdr print-form)
- (list ,@(cdr print-form))))
+ (trace-tab :in)
+ (format *trace-output* "~s =3D ~s" name object))
+ ',(cdr print-form)
+ (list ,@(cdr print-form))))
`((let ((objects (multiple-value-list ,print-form))
- (i -1))
- (if (and objects (not (cdr objects)))
- (progn
- (trace-tab :in)
- (format *trace-output* "~s =3D ~s" ',print-form (car objects)))
- (dolist (object objects)
- (trace-tab :in)
- (format *trace-output* "~s [~d] =3D ~s" ',print-form (incf i) objec=
t))))))))
+ (i -1))
+ (if (and objects (not (cdr objects)))
+ (progn
+ (trace-tab :in)
+ (format *trace-output* "~s =3D ~s" ',print-form (car objects=
)))
+ (dolist (object objects)
+ (trace-tab :in)
+ (format *trace-output* "~s [~d] =3D ~s" ',print-form (incf i=
) object))))))))
=
(defun trace-backtrace-body (test-form)
(when test-form
`((let ((test ,test-form))
- (when test
- (multiple-value-bind (detailed-p count)
- (cond ((memq test '(:detailed :verbose :full))
- (values t nil))
- ((integerp test)
- (values nil test))
- ((and (consp test)
- (keywordp (car test))
- (consp (cdr test))
- (null (cddr test)))
- (values (memq (car test) '(:detailed :verbose :full))
- (and (integerp (cadr test)) (cadr test))))
- (t (values nil nil)))
- (let ((*debug-io* *trace-output*))
- (print-call-history :detailed-p detailed-p
- :count (or count most-positive-fixnum))
- (terpri *trace-output*))))))))
+ (when test
+ (multiple-value-bind (detailed-p count)
+ (cond ((memq test '(:detailed :verbose :full))
+ (values t nil))
+ ((integerp test)
+ (values nil test))
+ ((and (consp test)
+ (keywordp (car test))
+ (consp (cdr test))
+ (null (cddr test)))
+ (values (memq (car test) '(:detailed :verbose :full))
+ (and (integerp (cadr test)) (cadr test))))
+ (t (values nil nil)))
+ (let ((*debug-io* *trace-output*))
+ (print-call-history :detailed-p detailed-p
+ :count (or count most-positive-fixnum))
+ (terpri *trace-output*))))))))
=
(defun trace-inside-frame-p (name)
(if (packagep name)
@@ -436,9 +349,7 @@
(t nil))))
(when (and sym (eq (symbol-package sym) name))
(return-from trace-inside-frame-p t)))))
- (let ((fn (typecase name
- (symbol (fboundp name))
- (method (%method-function name)))))
+ (let ((fn (%encap-binding name)))
(when fn
(map-call-frames #'(lambda (p)
(when (eq (cfp-lfun p) fn)
@@ -495,11 +406,11 @@
=
(when break
(setq break-before (if break-before
- `(and ,break ,break-before)
- break))
+ `(and ,break ,break-before)
+ break))
(setq break-after (if break-after
- `(and ,break ,break-after)
- break)))
+ `(and ,break ,break-after)
+ break)))
(unless backtrace-before
(setq backtrace-before backtrace))
(when (and (consp backtrace-before) (keywordp (car backtrace-before)))
@@ -525,113 +436,96 @@
=
(when inside
(let ((tests (loop for spec in inside
- as name =3D (or (trace-package-spec spec)
- (nth-value 1 (%trace-function-spec-p =
spec nil nil nil))
- (error "Cannot trace inside ~s" spec))
- collect `(trace-inside-frame-p ',name))))
+ as name =3D (or (trace-package-spec spec)
+ (%encapsulation-thing spec nil nil)
+ (error "Cannot trace inside ~s" spec))
+ collect `(trace-inside-frame-p ',name))))
(setq if `(and ,if (or , at tests)))))
=
(setq eval-before `(,@(trace-print-body print-before)
- ,@(trace-print-body print)
- ,@(and eval-before `(,eval-before))
- ,@(and eval `(,eval))
- ,@(and before `((apply ,before ',spec args)))
- ,@(trace-backtrace-body backtrace-before)
- ,@(and break-before `((when ,break-before
- (force-output *trace-output*)
- (break "~s trace entry: ~s" ',spec args))))))
+ ,@(trace-print-body print)
+ ,@(and eval-before `(,eval-before))
+ ,@(and eval `(,eval))
+ ,@(and before `((apply ,before ',spec args)))
+ ,@(trace-backtrace-body backtrace-before)
+ ,@(and break-before `((when ,break-before
+ (force-output *trace-output*)
+ (break "~s trace entry: ~s" =
',spec args))))))
(setq eval-after `(,@(trace-backtrace-body backtrace-after)
- ,@(and after `((apply ,after ',spec vals)))
- ,@(and eval `(,eval))
- ,@(and eval-after `(,eval-after))
- ,@(trace-print-body print)
- ,@(trace-print-body print-after)
- ,@(and break-after `((when ,break-after
- (force-output *trace-output*)
- (break "~s trace exit: ~s" ',spec vals))))))
+ ,@(and after `((apply ,after ',spec vals)))
+ ,@(and eval `(,eval))
+ ,@(and eval-after `(,eval-after))
+ ,@(trace-print-body print)
+ ,@(trace-print-body print-after)
+ ,@(and break-after `((when ,break-after
+ (force-output *trace-output*)
+ (break "~s trace exit: ~s" ',s=
pec vals))))))
=
(prog1
(block %trace-block
- ;;
- ;; see if we're a callback
- ;;
- (when (and (typep spec 'symbol)
- (boundp spec)
- (macptrp (symbol-value spec)))
- (let ((len (length %pascal-functions%))
- (sym-name (symbol-name spec)))
- (declare (fixnum len))
- (dotimes (i len)
- (let ((pfe (%svref %pascal-functions% i)))
- (when (and (vectorp pfe)
- (string=3D sym-name (symbol-name (pfe.sym pfe))))
- (when backtrace
- (if (null before)
- (setq before :print)))
- (setf (pfe.trace-p pfe)
- `(,@(if before `((:before . ,before)))
- ,@(if after `((:after . ,after)))
- ,@(if backtrace `((:backtrace . ,backtrace)))))
- (push spec *trace-pfun-list*)))))
- (return-from %trace-block))
- ;;
- ;; now look for tracible methods.
- ;; It's possible, but not likely, that we will be both
- ;; a callback and a function or method, if so we trace both.
- ;; This isn't possible.
- ;; If we're neither, signal an error.
- ;;
- (multiple-value-bind (def trace-thing) =
- (%trace-function-spec-p spec define-if-not)
- (when (null def)
- (return-from trace-function
- (warn "Trace does not understand ~S, ignored." spec)))
- (when (%traced-p trace-thing)
- (%untrace-1 trace-thing)
- (setq def (%trace-fboundp trace-thing)))
- (when (and methods (typep def 'standard-generic-function))
- (dolist (m (%gf-methods def))
- (apply #'trace-function m args)))
- #+old
- (when step ; just check if has interpreted def
- (if (typep def 'standard-generic-function)
- (let ((methods (%gf-methods def)))
- ; should we complain if no methods? naah
- (dolist (m methods) ; stick :step-gf in advice-when slot
- (%trace m :step t)
- (let ((e (function-encapsulation m)))
- (when e (setf (encapsulation-advice-when e) :step-gf))))
- ; we choose to believe that before and after are intended for the gf
- (if (or before after)
- (setq step nil) =
- (return-from %trace-block)))
- #|(uncompile-for-stepping trace-thing nil t)|#))
- (let* ((newsym (gensym "TRACE"))
- (method-p (typep trace-thing 'method))
- (newdef (trace-global-def =
- spec newsym if before-if eval-before after-if eval-after method-p)))
- (when method-p
- (copy-method-function-bits def newdef))
- (without-interrupts
- (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def=
'trace spec newsym)
- (declare (ignore ignore))
- (cond (gf-dcode =
- (setf (%gf-dcode def)
- (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-enca=
psulation)))
- ((symbolp trace-thing) (%fhave trace-thing newdef))
- ((typep trace-thing 'method)
- (setf (%method-function trace-thing) newdef)
- (remove-obsoleted-combined-methods trace-thing)
- newdef)))))))
+ ;;
+ ;; see if we're a callback
+ ;;
+ (when (and (typep spec 'symbol)
+ (boundp spec)
+ (macptrp (symbol-value spec)))
+ (let ((len (length %pascal-functions%))
+ (sym-name (symbol-name spec)))
+ (declare (fixnum len))
+ (dotimes (i len)
+ (let ((pfe (%svref %pascal-functions% i)))
+ (when (and (vectorp pfe)
+ (string=3D sym-name (symbol-name (pfe.sym pfe))=
))
+ (when backtrace
+ (if (null before)
+ (setq before :print)))
+ (setf (pfe.trace-p pfe)
+ `(,@(if before `((:before . ,before)))
+ ,@(if after `((:after . ,after)))
+ ,@(if backtrace `((:backtrace . ,backtrace)))))
+ (push spec *trace-pfun-list*)))))
+ (return-from %trace-block))
+ ;;
+ ;; now look for traceable methods.
+ ;; It's possible, but not likely, that we will be both
+ ;; a callback and a function or method, if so we trace both.
+ ;; This isn't possible.
+ ;; If we're neither, signal an error.
+ ;;
+ (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def)
+ (%untrace-1 trace-thing)
+ (setq def (%encap-binding trace-thing))
+ (when (and methods (typep def 'standard-generic-function))
+ (dolist (m (%gf-methods def))
+ (apply #'trace-function m args)))
+ #+old
+ (when step ; just check if has interpreted def
+ (if (typep def 'standard-generic-function)
+ (let ((methods (%gf-methods def)))
+ ; should we complain if no methods? naah
+ (dolist (m methods) ; stick :step-gf in advice-when slot
+ (%trace m :step t)
+ (let ((e (function-encapsulation m)))
+ (when e (setf (encapsulation-advice-when e) :step-gf))=
))
+ ; we choose to believe that before and after are intended =
for the gf
+ (if (or before after)
+ (setq step nil) =
+ (return-from %trace-block)))
+ #|(uncompile-for-stepping trace-thing nil t)|#))
+ (let* ((newsym (gensym "TRACE"))
+ (method-p (typep trace-thing 'method))
+ (newdef (trace-global-def =
+ spec newsym if before-if eval-before after-if ev=
al-after method-p)))
+ (when method-p
+ (copy-method-function-bits def newdef))
+ (encapsulate trace-thing newdef 'trace spec newsym))))
(when *trace-hook*
(apply *trace-hook* spec args))))
=
=
-;; sym is either a symbol or a method
-
-(defun %traced-p (sym)
- (let ((foo (function-encapsulation sym)))
- (and foo (eq (encapsulation-type foo) 'trace))))
+(defun %traced-p (thing)
+ (let ((cap (get-encapsulation thing)))
+ (and cap (eq (encapsulation-type cap) 'trace))))
=
(defmacro untrace (&rest syms)
"Remove tracing from the specified functions. With no args, untrace all
@@ -647,69 +541,65 @@
(when x (push x val)))
val))
=
-
-(defun %untrace (sym)
+(defun %untrace-all ()
+ (dolist (pfun *trace-pfun-list*)
+ (%untrace pfun)
+ (when *untrace-hook*
+ (funcall *untrace-hook* pfun)))
+ (loop for cap being the hash-value of *encapsulation-table*
+ when (eq (encapsulation-type cap) 'trace)
+ collect (let ((spec (encapsulation-spec cap)))
+ (remove-encapsulation cap)
+ (when *untrace-hook*
+ (funcall *untrace-hook* spec))
+ spec)))
+
+(defun %untrace (sym &aux val)
(when (and (consp sym)(consp (car sym)))
(setq sym (car sym)))
(cond
- ((and (typep sym 'symbol)
- (boundp sym)
- (macptrp (symbol-value sym)))
- (%untrace-pfun sym))
- (t =
- (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
- (let (val)
- (when (typep def 'standard-generic-function)
- (let ((methods (%gf-methods def)))
- (dolist (m methods)
- (let ((e (function-encapsulation m)))
- (when (and e (eq (encapsulation-advice-when e) :step-gf))
- (remove-encapsulation e)
- (push m val))))))
- ; gf could have first been traced :step, and then just plain traced
- ; maybe the latter trace should undo the stepping??
- (when (%traced-p trace-thing)
- (%untrace-1 trace-thing)
- (push trace-thing val))
- (if (null (cdr val))(car val) val)))))
+ ((and (typep sym 'symbol)
+ (boundp sym)
+ (macptrp (symbol-value sym)))
+ (%untrace-pfun sym))
+ (t =
+ (let* ((trace-thing (%encapsulation-thing sym))
+ (def (%encap-binding trace-thing)))
+ (when (typep def 'standard-generic-function)
+ (let ((methods (%gf-methods def)))
+ (dolist (m methods)
+ (let ((cap (get-encapsulation m)))
+ (when (and cap (eq (encapsulation-advice-when cap) :step-gf))
+ (remove-encapsulation cap)
+ (push m val))))))
+ ; gf could have first been traced :step, and then just plain traced
+ ; maybe the latter trace should undo the stepping??
+ (let ((spec (%untrace-1 trace-thing)))
+ (when spec
+ (push spec val))))))
(when *untrace-hook*
- (funcall *untrace-hook* sym)))
-
-(defun %untrace-all ()
- (let ((val nil))
- (dolist (cap *trace-alist*)
- (push (encapsulation-spec cap) val)
- (remove-encapsulation cap)
- (when *untrace-hook*
- (funcall *untrace-hook* (encapsulation-spec cap))))
- (dolist (pfun *trace-pfun-list*)
- (%untrace pfun)
- (when *untrace-hook*
- (funcall *untrace-hook* pfun)))
- val))
+ (funcall *untrace-hook* sym))
+ (if (null (cdr val)) (car val) val))
=
;; thing is a symbol or method - def is current definition
;; we already know its traced
(defun %untrace-1 (thing)
- (let (capsule)
- (setq capsule (function-encapsulation thing))
- ;; trace encapsulations must be first =
- (when (neq (encapsulation-type capsule) 'trace)
- (error "~S was not traced." thing))
- (remove-encapsulation capsule)
- (encapsulation-spec capsule)))
+ (let ((cap (get-encapsulation thing)))
+ (when (and cap (eq (encapsulation-type cap) 'trace))
+ (remove-encapsulation cap)
+ (encapsulation-spec cap))))
=
(defun %untrace-pfun (sym)
(let ((len (length %pascal-functions%))
- (sym-name (symbol-name sym)))
+ (sym-name (symbol-name sym)))
(declare (fixnum len))
(dotimes (i len)
(let ((pfe (%svref %pascal-functions% i)))
- (when (and (vectorp pfe)
- (string=3D sym-name (symbol-name (pfe.sym pfe))))
- (setf (pfe.trace-p pfe) nil
- *trace-pfun-list* (remove sym *trace-pfun-list*))
- (return-from %untrace-pfun sym))))
+ (when (and (vectorp pfe)
+ (string=3D sym-name (symbol-name (pfe.sym pfe))))
+ (setf (pfe.trace-p pfe) nil
+ *trace-pfun-list* (remove sym *trace-pfun-list*))
+ (return-from %untrace-pfun sym))))
nil))
=
=
@@ -721,7 +611,7 @@
functions are called."
(if syms
(let ((options (loop while (keywordp (car syms))
- nconc (list (pop syms) (pop syms)))))
+ nconc (list (pop syms) (pop syms)))))
`(%trace-0 ',syms ',options))
`(%trace-list)))
=
@@ -738,8 +628,9 @@
=
(defun %trace-list ()
(let (res)
- (dolist (x *trace-alist*)
- (push (encapsulation-spec x) res))
+ (loop for x being the hash-value of *encapsulation-table*
+ when (eq (encapsulation-type x) 'trace)
+ do (push (encapsulation-spec x) res))
(dolist (x *trace-pfun-list*)
(push x res))
res))
@@ -748,58 +639,57 @@
=
(defun trace-global-def (sym def if before-if eval-before after-if eval-af=
ter &optional method-p)
(let ((saved-method-var (gensym))
- (enable (gensym))
- do-it)
+ (enable (gensym))
+ do-it)
(setq do-it
(cond #+old (step
- (setq step-it =
- `(step-apply-simple ',def args))
- (if (eq step t)
- step-it
- `(if (apply ',step ',sym args) ; gaak
- ,step-it
- ,(if (and before method-p)
- `(apply-with-method-context ,saved-method-var (symbol-function ',def) =
args)
- `(apply ',def args)))))
+ (setq step-it =
+ `(step-apply-simple ',def args))
+ (if (eq step t)
+ step-it
+ `(if (apply ',step ',sym args) ; gaak
+ ,step-it
+ ,(if (and before method-p)
+ `(apply-with-method-context ,saved-method-=
var (symbol-function ',def) args)
+ `(apply ',def args)))))
(t (if (and eval-before method-p)
`(apply-with-method-context ,saved-method-var (symbol=
-function ',def) args)
`(apply ',def args)))))
(compile-named-function-warn
`(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
- &rest args) ; if methodp put &method on front of args - vs get-sav=
ed-method-var?
+ &rest args) ; if methodp put &method on front of args - vs =
get-saved-method-var?
(declare (dynamic-extent args))
(let ((*trace-level* (1+ *trace-level*))
- (,enable ,if))
- (declare (special *trace-enable* *trace-level*))
- ,(when eval-before
- `(when (and ,enable ,before-if *trace-enable*)
- (when *trace-print-hook*
- (funcall *trace-print-hook* ',sym t))
- (let* ((*trace-enable* nil))
- , at eval-before)
- (when *trace-print-hook*
- (funcall *trace-print-hook* ',sym nil))))
- ,(if eval-after
- `(let ((vals (multiple-value-list ,do-it)))
- (when (and ,enable ,after-if *trace-enable*)
- (when *trace-print-hook* =
- (funcall *trace-print-hook* ',sym t))
- (let* ((*trace-enable* nil))
- , at eval-after)
- (when *trace-print-hook* =
- (funcall *trace-print-hook* ',sym nil)))
- (values-list vals))
- do-it)))
+ (,enable ,if))
+ (declare (special *trace-enable* *trace-level*))
+ ,(when eval-before
+ `(when (and ,enable ,before-if *trace-enable*)
+ (when *trace-print-hook*
+ (funcall *trace-print-hook* ',sym t))
+ (let* ((*trace-enable* nil))
+ , at eval-before)
+ (when *trace-print-hook*
+ (funcall *trace-print-hook* ',sym nil))))
+ ,(if eval-after
+ `(let ((vals (multiple-value-list ,do-it)))
+ (when (and ,enable ,after-if *trace-enable*)
+ (when *trace-print-hook* =
+ (funcall *trace-print-hook* ',sym t))
+ (let* ((*trace-enable* nil))
+ , at eval-after)
+ (when *trace-print-hook* =
+ (funcall *trace-print-hook* ',sym nil)))
+ (values-list vals))
+ do-it)))
`(traced ,sym))))
=
; &method var tells compiler to bind var to contents of next-method-context
-(defun advise-global-def (function-spec def when stuff &optional method-p)
- (declare (ignore function-spec))
+(defun advise-global-def (def when stuff &optional method-p dynamic-extent=
-arglist)
(let* ((saved-method-var (gensym)))
`(lambda (,@(if (and method-p (neq when :after))
`(&method ,saved-method-var))
&rest arglist)
- ;(declare (dynamic-extent arglist))
+ ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
(let ()
,(ecase
when
@@ -839,176 +729,135 @@
(setq first nil))))
result))
=
-;; want to look like
-;; (setq values (multiple-value-list (progn , at frob)))
- =
=
-(defun %advised-p (thing &optional when advice-name quick)
- ;; thing is a symbol, result is list of encapsulations
- ;; Quick when used as a simple predicate
- (let ((nx thing) cap val)
- (while (setq cap (function-encapsulation nx))
- (when (eq (encapsulation-type cap) 'advice)
- (if quick (return-from %advised-p cap))
- (when (or (and (null when)(null advice-name))
- (and (eq when (encapsulation-advice-when cap))
- (equal advice-name (encapsulation-advice-name cap))=
))
- (push cap val)))
- (setq nx (encapsulation-symbol cap)))
- val)) =
-
+(defun %advised-p (thing)
+ (loop for nx =3D thing then (encapsulation-symbol cap)
+ as cap =3D (get-encapsulation nx) while cap
+ thereis (eq (encapsulation-type cap) 'advice)))
+
+(defun %advice-encapsulations (thing when advice-name)
+ (loop for nx =3D thing then (encapsulation-symbol cap)
+ as cap =3D (get-encapsulation nx) while cap
+ when (and (eq (encapsulation-type cap) 'advice)
+ (or (null when) (eq when (encapsulation-advice-when cap)))
+ (or (null advice-name) (equal advice-name (encapsulation-adv=
ice-name cap))))
+ collect cap))
=
(defun advise-2 (newdef newsym method-p function-spec when advice-name def=
ine-if-not) =
- (let (advise-thing def orig-sym orig-def)
- (multiple-value-setq (def advise-thing) =
- (%trace-function-spec-p function-spec define-if-not))
- (when (not def)(error "Advise does not understand ~s." function-spec))
+ (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
+ orig-sym)
+ (let ((capsules (%advice-encapsulations advise-thing when advice-name)=
))
+ (when capsules =
+ (unadvise-capsules capsules)))
(when (%traced-p advise-thing)
+ ; make traced call advised
(setq orig-sym
- (encapsulation-symbol (function-encapsulation advise-thing)))
- (setq orig-def (fboundp orig-sym)))
- (let ((capsules (%advised-p advise-thing when advice-name)))
- (when capsules =
- (unadvise-capsules capsules)
- ; get the right def you fool!
- (setq def (%trace-function-spec-p function-spec))))
- (without-interrupts
- (multiple-value-bind (ignore gf-dcode)
- (encapsulate (or orig-sym advise-thing) (or orig=
-def def) =
- 'advice function-spec newsym
- advice-name when)
- (declare (ignore ignore))
- (lfun-name newdef `(advised ',function-spec))
- (if method-p (copy-method-function-bits def newdef))
- (if gf-dcode (setq newdef (%cons-combined-method def (cons newdef g=
f-dcode)
- #'%%call-gf-encaps=
ulation))) =
- (cond (orig-sym
- (%fhave orig-sym newdef)) ; make traced call advised
- (t (cond (gf-dcode (setf (%gf-dcode def) newdef))
- ((symbolp advise-thing)
- (%fhave advise-thing newdef))
- ((typep advise-thing 'method)
- (progn =
- (setf (%method-function advise-thing) newdef)
- (remove-obsoleted-combined-methods advise-thing)
- newdef)))))))))
-
-(defmacro advise (function form &key (when :before) name define-if-not)
+ (encapsulation-symbol (get-encapsulation advise-thing))))
+ (lfun-name newdef `(advised ',function-spec))
+ (if method-p (copy-method-function-bits (%encap-binding advise-thing) =
newdef))
+ (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec n=
ewsym advice-name when)
+ newdef))
+
+(defmacro advise (function form &key (when :before) name define-if-not dyn=
amic-extent-arglist)
(let* ((newsym (gensym "ADVICE"))
; WAS typep advise-thing 'method
(method-p (or (typep function 'method) ; can this happen?
(and (consp function)(eq (car function) :method))))
- (newdef (advise-global-def function newsym when form method-p)))
+ (newdef (advise-global-def newsym when form method-p dynamic-exte=
nt-arglist)))
`(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
,define-if-not)))
=
(defmacro advisedp (function-spec &key when name)
`(advisedp-1 ',function-spec ',when ',name))
=
+(defun encapsulation-advice-spec (cap)
+ (list (encapsulation-spec cap)
+ (encapsulation-advice-when cap)
+ (encapsulation-advice-name cap)))
+ =
(defun advisedp-1 (function-spec when name)
- (let (val)
- (flet ((xtract-capsule (c)
- (list (encapsulation-spec c)
- (encapsulation-advice-when c)
- (encapsulation-advice-name c))))
- (cond ((eq t function-spec)
- (dolist (c *advise-alist*)
- (when (and
- (or (null when)(eq when (encapsulation-advice-when c=
)))
- (or (null name)(equal name (encapsulation-advice-nam=
e c))))
- (push (xtract-capsule c) val))))
- (t (let* ((advise-thing (nth-value 1 (%trace-function-spec-p =
function-spec)))
- (capsules (%advised-p advise-thing when name)))
- (dolist (capsule capsules)
- (push (xtract-capsule capsule) val)))))
- val))) =
-
-
-(defun unadvise-1 (function-spec &optional when advice-name ignore)
+ (cond ((eq t function-spec)
+ (loop for c being the hash-value of *encapsulation-table*
+ when (and (eq (encapsulation-type c) 'advice)
+ (or (null when)(eq when (encapsulation-advice-when c)=
))
+ (or (null name)(equal name (encapsulation-advice-name=
c))))
+ collect (encapsulation-advice-spec c)))
+ (t (let* ((advise-thing (%encapsulation-thing function-spec))
+ (capsules (%advice-encapsulations advise-thing when name=
)))
+ (mapcar #'encapsulation-advice-spec capsules)))))
+
+(defun %unadvise-1 (function-spec &optional when advice-name ignore)
(declare (ignore ignore))
- (let ((advise-thing (nth-value 1 (%trace-function-spec-p function-spec))=
))
- (let ((capsules (%advised-p advise-thing when advice-name)))
+ (let ((advise-thing (%encapsulation-thing function-spec)))
+ (let ((capsules (%advice-encapsulations advise-thing when advice-name)=
))
(when capsules (unadvise-capsules capsules)))))
=
(defun unadvise-capsules (capsules)
(let (val)
(dolist (capsule capsules)
- (push (list (encapsulation-spec capsule)
- (encapsulation-advice-when capsule)
- (encapsulation-advice-name capsule))
- val)
+ (push (encapsulation-advice-spec capsule) val)
(remove-encapsulation capsule))
val))
=
(defmacro unadvise (function &key when name)
(cond ((neq function t)
- `(unadvise-1 ',function ',when ',name))
+ `(%unadvise-1 ',function ',when ',name))
(t '(%unadvise-all))))
=
(defun %unadvise-all ()
- (unadvise-capsules *advise-alist*))
-
-(defun %set-unencapsulated-definition (spec newdef)
- (let (foo)
- (while (setq foo (function-encapsulation spec))
- (setq spec (encapsulation-symbol foo)))
- (typecase spec
- (symbol
- (%fhave spec newdef)) ;; or fset ?? =
- (method
- (setf (%method-function spec) newdef)
- (remove-obsoleted-combined-methods spec)
- newdef))))
-
-
-;; return t if we defined it, nil otherwise
-
+ (loop for cap being the hash-value of *encapsulation-table*
+ when (eq (encapsulation-type cap) 'advice)
+ collect (progn
+ (remove-encapsulation cap)
+ (encapsulation-advice-spec cap))))
+
+;; Called from %defun. Return t if we defined it, nil otherwise
(defun %defun-encapsulated-maybe (name newdef)
- (let ((def (fboundp name)))
- (when (and def (function-encapsulated-p name))
- (cond ((or *loading-files* (typep def 'standard-generic-function))
+ (assert (not (get-encapsulation newdef)))
+ (let ((old-def (fboundp name)) cap)
+ (when (and old-def (setq cap (get-encapsulation name)))
+ (cond ((or (and *loading-files* *loading-removes-encapsulation*)
+ ;; redefining a gf as a fn.
+ (typep old-def 'standard-generic-function))
(forget-encapsulations name)
nil)
- (t (%set-unencapsulated-definition name newdef)
+ (t (set-unencapsulated-definition cap newdef)
T)))))
=
-(defun %move-method-encapsulations-maybe (oldmethod newmethod)
- ;; deal with method redefinition
- (let (cap newdef olddef old-inner-def)
- (when (and (setq cap (function-encapsulation oldmethod))
- (neq oldmethod newmethod)) =
- (cond (*loading-files*
- (when (%traced-p oldmethod)
- (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
- (when (%advised-p oldmethod nil nil t)
- (format t "~%... Unadvising ~s" (unadvise-1 oldmethod))))
- (t (setq newdef (%method-function newmethod))
- (setq olddef (%method-function oldmethod))
- (setq old-inner-def (find-unencapsulated-definition oldmeth=
od))
- ;; make last encapsulation call new definition =
- (%set-unencapsulated-definition oldmethod newdef)
- (setf (%method-function newmethod) olddef)
- (remove-encapsulation cap t)
- (put-encapsulation newmethod cap)
- (setf (%method-function oldmethod) old-inner-def)
- (advise-set-method-bits newmethod newdef)
- )))))
-
-(defun advise-set-method-bits (spec newdef)
- ;; spec is a symbol, function, or method object
- (let (foo)
- (while (setq foo (function-encapsulation spec)) =
- (let ((def (typecase spec
- (symbol (fboundp spec))
- (method (%method-function spec))
- (t nil))))
- (if def
- (copy-method-function-bits newdef def)
- (error "whats going on here anyway")))
- (setq spec (encapsulation-symbol foo)))))
-
+;; Called from clos when change dcode
+(defun %set-encapsulated-gf-dcode (gf new-dcode)
+ (loop with cap =3D (get-encapsulation gf)
+ for gf-copy =3D (encapsulation-old-def cap)
+ as cur-dcode =3D (%gf-dcode gf-copy)
+ do (setq cap (get-encapsulation cur-dcode))
+ ;; refresh all the gf copies, in case other info in gf changed
+ do (%copy-function gf gf-copy)
+ do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
+ while cap))
+
+;; Called from clos when oldmethod is being replaced by newmethod in a gf.
+(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
+ (unless (eq oldmethod newmethod)
+ (cond ((and *loading-removes-encapsulation* *loading-files*)
+ (when (%traced-p oldmethod)
+ (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
+ (when (%advised-p oldmethod)
+ (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
+ (t (when (setq cap (get-encapsulation oldmethod))
+ (let* ((old-inner-def (find-unencapsulated-definition oldme=
thod))
+ (newdef (%method-function newmethod))
+ (olddef (%method-function oldmethod)))
+ ;; make last encapsulation call new definition
+ (set-unencapsulated-definition cap newdef)
+ (setf (%method-function newmethod) olddef)
+ (set-encapsulation-owner olddef newmethod)
+ (setf (%method-function oldmethod) old-inner-def)
+ (loop
+ for def =3D olddef then (encapsulation-old-def cap)
+ for cap =3D (get-encapsulation def) while cap
+ do (copy-method-function-bits newdef def))))))))
=
#|
- Change History (most recent last):
- 2 12/29/94 akh merge with d13
+ Change History (most recent last):
+ 2 12/29/94 akh merge with d13
|# ;(do not edit past this line!!)
More information about the Openmcl-cvs-notifications
mailing list