1.0.32.29: Add build flag :sb-xref-for-internals.

[sbcl.git] / src / compiler / ir1util.lisp

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 046c7bf..257fbe5 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -429,7 +429,7 @@
     (lvar-dynamic-extent it)))
 
 (defun flushable-combination-p (call)
-  (declare (combination call))
+  (declare (type combination call))
   (let ((kind (combination-kind call))
         (info (combination-fun-info call)))
     (when (and (eq kind :known) (fun-info-p info))
@@ -444,6 +444,8 @@
                        (ir1-attributep attr unsafely-flushable)))
           t)))))
 
+;;;; DYNAMIC-EXTENT related
+
 (defun note-no-stack-allocation (lvar &key flush)
   (do-uses (use (principal-lvar lvar))
     (unless (or
@@ -455,7 +457,6 @@
         (compiler-notify "could not stack allocate the result of ~S"
                          (find-original-source (node-source-path use)))))))
 
-
 (declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component))
                            boolean) use-good-for-dx-p))
 (declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component))
@@ -566,6 +567,43 @@
               when (eq var this)
               return arg)))))
 
+;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
+(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component)
+  (let ((uses (lvar-uses lvar)))
+    ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
+    ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
+    ;; to process uses of single-use LVARs.
+    (when (node-p uses)
+      (node-ends-block uses))
+    ;; If this LVAR's USE is good for DX, it is either a CAST, or it
+    ;; must be a regular combination whose arguments are potentially DX as well.
+    (flet ((recurse (use)
+             (etypecase use
+               (cast
+                (handle-nested-dynamic-extent-lvars
+                 dx (cast-value use) recheck-component))
+               (combination
+                (loop for arg in (combination-args use)
+                      ;; deleted args show up as NIL here
+                      when (and arg
+                                (lvar-good-for-dx-p arg dx recheck-component))
+                      append (handle-nested-dynamic-extent-lvars
+                              dx arg recheck-component)))
+               (ref
+                (let* ((other (trivial-lambda-var-ref-lvar use)))
+                  (unless (eq other lvar)
+                    (handle-nested-dynamic-extent-lvars
+                     dx other recheck-component)))))))
+      (cons (cons dx lvar)
+            (if (listp uses)
+                (loop for use in uses
+                      when (use-good-for-dx-p use dx recheck-component)
+                      nconc (recurse use))
+                (when (use-good-for-dx-p uses dx recheck-component)
+                  (recurse uses)))))))
+
+;;;;; BLOCK UTILS
+
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)
@@ -765,7 +803,8 @@
                          (handled-conditions (lexenv-handled-conditions default))
                          (disabled-package-locks
                           (lexenv-disabled-package-locks default))
-                         (policy (lexenv-policy default)))
+                         (policy (lexenv-policy default))
+                         (user-data (lexenv-user-data default)))
   (macrolet ((frob (var slot)
                `(let ((old (,slot default)))
                   (if ,var
@@ -777,8 +816,10 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup handled-conditions
-     disabled-package-locks policy)))
+     lambda
+     cleanup handled-conditions disabled-package-locks
+     policy
+     user-data)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
 ;;; macroexpander
@@ -812,7 +853,8 @@
      nil
      (lexenv-handled-conditions lexenv)
      (lexenv-disabled-package-locks lexenv)
-     (lexenv-policy lexenv))))
+     (lexenv-policy lexenv)
+     (lexenv-user-data lexenv))))
 \f
 ;;;; flow/DFO/component hackery
 
@@ -1919,12 +1961,13 @@ is :ANY, the function name is not checked."
         (name1 uses)
         (mapcar #'name1 uses)))))
 
-;;; Return the source name of a combination. (This is an idiom
-;;; which was used in CMU CL. I gather it always works. -- WHN)
+;;; Return the source name of a combination -- or signals an error
+;;; if the function leaf is anonymous.
 (defun combination-fun-source-name (combination &optional (errorp t))
   (let ((leaf (ref-leaf (lvar-uses (combination-fun combination)))))
-    (when (or errorp (leaf-has-source-name-p leaf))
-      (leaf-source-name leaf))))
+    (if (or errorp (leaf-has-source-name-p leaf))
+        (values (leaf-source-name leaf) t)
+        (values nil nil))))
 
 ;;; Return the COMBINATION node that is the call to the LET FUN.
 (defun let-combination (fun)
@@ -2151,7 +2194,8 @@ is :ANY, the function name is not checked."
   (let ((use (lvar-use lvar)))
     (and (combination-p use)
          (or (not fun-names)
-             (member (combination-fun-source-name use)
-                     fun-names :test #'eq))
+             (multiple-value-bind (name ok)
+                 (combination-fun-source-name use nil)
+               (and ok (member name fun-names :test #'eq))))
          (or (not arg-count)
              (= arg-count (length (combination-args use)))))))