From fa68810289c5be55f47f6cbd5324a5d91c20e865 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 19 Mar 2010 21:33:08 +0000 Subject: [PATCH] 1.0.36.34: WHO-CALLS information for source transformed calls * Generalize the solution used for macroexpansion XREFs to take care of other source-level stuff: this includes both source-transforms and compiler-macros. Fixes launchpad bug #542174. Note re. 1.0.36.33: the commit message is erronous. The real commit message would have noted that since FIND-OPTIONAL-DISPATCH-TYPES doesn't rightly consider &REST mismatch a lossage in the presence of &KEY, we need to make sure the type assigned to the leaf has a &REST type if the function actually has a &REST argument. --- NEWS | 2 ++ contrib/sb-introspect/xref-test-data.lisp | 7 ++++++- contrib/sb-introspect/xref-test.lisp | 9 +++++++++ src/compiler/ir1tran.lisp | 23 ++++++++++++++--------- src/compiler/node.lisp | 5 +++-- src/compiler/xref.lisp | 18 +++++++++++------- version.lisp-expr | 2 +- 7 files changed, 46 insertions(+), 20 deletions(-) diff --git a/NEWS b/NEWS index a1f166b..f94e99c 100644 --- a/NEWS +++ b/NEWS @@ -57,6 +57,8 @@ changes relative to sbcl-1.0.36: parsing. (lp#309128) * bug fix: missing &REST type in a proclamation for a function with both &REST and &KEY in lambda-list caused miscompilation (lp#458354) + * bug fix: WHO-CALLS information for source-transformed and compiler-macro + expanded calls (lp#542174) changes in sbcl-1.0.36 relative to sbcl-1.0.35: * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and diff --git a/contrib/sb-introspect/xref-test-data.lisp b/contrib/sb-introspect/xref-test-data.lisp index ff44e10..aebc327 100644 --- a/contrib/sb-introspect/xref-test-data.lisp +++ b/contrib/sb-introspect/xref-test-data.lisp @@ -194,8 +194,13 @@ (defun inline/4-user () (inline/4 :a :b :c)) -;;; Test references to / from compiler-macros +;;; Test references to / from compiler-macros and source-transforms +(define-compiler-macro cmacro (x) + `(+ ,x 42)) +(defstruct struct slot) +(defun source-user (x) + (cmacro (struct-slot x))) ;;; Test specialization diff --git a/contrib/sb-introspect/xref-test.lisp b/contrib/sb-introspect/xref-test.lisp index 923ce81..a93740d 100644 --- a/contrib/sb-introspect/xref-test.lisp +++ b/contrib/sb-introspect/xref-test.lisp @@ -114,6 +114,15 @@ (inline/1)) +(define-xref-test who-calls.struct-slot.1 + (who-calls 'struct-slot) + (source-user)) + +(define-xref-test who-calls.cmacro.1 + (who-calls 'cmacro) + (source-user)) + + (define-xref-test who-specializes-directly.1 (who-specializes-directly 'a-class) ((method a-gf-1) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 9ac65b6..728a23a 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -712,9 +712,12 @@ ;; suppresses compiler-macros. (not (fun-lexically-notinline-p cmacro-fun-name))) (let ((res (careful-expand-macro cmacro-fun form))) - (if (eq res form) - (ir1-convert-common-functoid start next result form op) - (ir1-convert start next result res))) + (cond ((eq res form) + (ir1-convert-common-functoid start next result form op)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call cmacro-fun-name (ctran-block start) *current-path*)) + (ir1-convert start next result res)))) (ir1-convert-common-functoid start next result form op))))))) ;;; Handles the "common" cases: any other forms except special forms @@ -1021,14 +1024,16 @@ (defined-fun-inlinep var)))) (if (eq inlinep :notinline) (ir1-convert-combination start next result form var) - (let ((transform (info :function - :source-transform - (leaf-source-name var)))) + (let* ((name (leaf-source-name var)) + (transform (info :function :source-transform name))) (if transform (multiple-value-bind (transformed pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start next result form var) - (ir1-convert start next result transformed))) + (cond (pass + (ir1-convert-maybe-predicate start next result form var)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call name (ctran-block start) *current-path*)) + (ir1-convert start next result transformed)))) (ir1-convert-maybe-predicate start next result form var)))))) ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 8253e8e..41964ad 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -248,8 +248,9 @@ (flag nil) ;; some kind of info used by the back end (info nil) - ;; what macroexpansions happened "in" this block, used for xref - (macroexpands nil :type list) + ;; what macroexpansions and source transforms happened "in" this block, used + ;; for xref + (xrefs nil :type list) ;; Cache the physenv of a block during lifetime analysis. :NONE if ;; no cached value has been stored yet. (physenv-cache :none :type (or null physenv (member :none)))) diff --git a/src/compiler/xref.lisp b/src/compiler/xref.lisp index 5140421..2e8966f 100644 --- a/src/compiler/xref.lisp +++ b/src/compiler/xref.lisp @@ -28,11 +28,11 @@ (loop for ctran = start then (node-next (ctran-next ctran)) while ctran do (record-node-xrefs (ctran-next ctran) functional)) - ;; Properly record the deferred macroexpansion information - ;; that's been stored in the block. - (dolist (xref-data (block-macroexpands block)) - (record-xref :macroexpands - (car xref-data) + ;; Properly record the deferred macroexpansion and source + ;; transform information that's been stored in the block. + (dolist (xref-data (block-xrefs block)) + (record-xref (car xref-data) + (cadr xref-data) ;; We use the debug-name of the functional ;; as an identifier. This works quite nicely, ;; except for (fast/slow)-methods with non-symbol, @@ -41,7 +41,7 @@ ;; to the fdefinition of the method. functional nil - (cdr xref-data))))) + (cddr xref-data))))) (call-with-block-external-functionals block #'handle-node))))) (defun call-with-block-external-functionals (block fun) @@ -169,7 +169,11 @@ (defun record-macroexpansion (what block path) (unless (internal-name-p what) - (push (cons what path) (block-macroexpands block)))) + (push (list :macroexpands what path) (block-xrefs block)))) + +(defun record-call (what block path) + (unless (internal-name-p what) + (push (list :calls what path) (block-xrefs block)))) ;;; Pack the xref table that was stored for a functional into a more ;;; space-efficient form, and return that packed form. diff --git a/version.lisp-expr b/version.lisp-expr index c2a2ebb..064721f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.36.33" +"1.0.36.34" -- 1.7.10.4