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.

diff --git a/NEWS b/NEWS
index a1f166b..f94e99c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"