X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=99e2ef896c56e44f750d3a2b86d624fca21124bb;hb=0cff6b0b7e6f1d148586f81f620b9c86ed217caa;hp=695a9b6c65eac2ea8063dc1b1f839c007ea6819c;hpb=cb534036e501667da3b229627bf5169d7fb5a01c;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 695a9b6..99e2ef8 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -391,37 +391,35 @@
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 
-(declaim (ftype (sfunction (node &optional (or null component)) boolean)
-                use-good-for-dx-p))
-(declaim (ftype (sfunction (lvar &optional (or null component)) boolean)
-                lvar-good-for-dx-p))
-(defun use-good-for-dx-p (use &optional component)
+(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))
+                           boolean) lvar-good-for-dx-p))
+(defun use-good-for-dx-p (use dx &optional component)
   ;; FIXME: Can casts point to LVARs in other components?
-  ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that
-  ;; is, that the PRINCIPAL-LVAR is always in the same component
-  ;; as the original one. It would be either good to have an
-  ;; explanation of why casts don't point across components, or an
-  ;; explanation of when they do it. ...in the meanwhile AVER that
-  ;; our assumption holds true.
+  ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
+  ;; PRINCIPAL-LVAR is always in the same component as the original one. It
+  ;; would be either good to have an explanation of why casts don't point
+  ;; across components, or an explanation of when they do it. ...in the
+  ;; meanwhile AVER that our assumption holds true.
   (aver (or (not component) (eq component (node-component use))))
   (or (and (combination-p use)
            (eq (combination-kind use) :known)
-           (awhen (fun-info-stack-allocate-result
-                   (combination-fun-info use))
-             (funcall it use))
+           (awhen (fun-info-stack-allocate-result (combination-fun-info use))
+             (funcall it use dx))
            t)
       (and (cast-p use)
            (not (cast-type-check use))
-           (lvar-good-for-dx-p (cast-value use) component)
+           (lvar-good-for-dx-p (cast-value use) dx component)
            t)))
 
-(defun lvar-good-for-dx-p (lvar &optional component)
+(defun lvar-good-for-dx-p (lvar dx &optional component)
   (let ((uses (lvar-uses lvar)))
     (if (listp uses)
         (every (lambda (use)
-                 (use-good-for-dx-p use component))
+                 (use-good-for-dx-p use dx component))
                uses)
-        (use-good-for-dx-p uses component))))
+        (use-good-for-dx-p uses dx component))))
 
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
@@ -1928,14 +1926,14 @@
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))
 
-;;; True if LVAR is for 'NAME, or #'NAME (global, not local)
-(defun lvar-for-named-function (lvar name)
-  (if (constant-lvar-p lvar)
-      (eq name (lvar-value lvar))
-      (let ((use (lvar-uses lvar)))
-        (and (not (listp use))
-             (ref-p use)
-             (let ((leaf (ref-leaf use)))
-               (and (global-var-p leaf)
-                    (eq :global-function (global-var-kind leaf))
-                    (eq name (leaf-source-name leaf))))))))
+;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
+;;; global function with one of the specified NAMES.
+(defun lvar-fun-is (lvar names)
+  (declare (type lvar lvar) (list names))
+  (let ((use (lvar-uses lvar)))
+    (and (ref-p use)
+         (let ((leaf (ref-leaf use)))
+           (and (global-var-p leaf)
+                (eq (global-var-kind leaf) :global-function)
+                (not (null (member (leaf-source-name leaf) names
+                                   :test #'equal))))))))