X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=7d9f2f3d4842fe0449cf891513d32e744b220df5;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=d0df90321a831f3eedc7c4f28f21e52640b2abfa;hpb=63690d6dc4617f2140f229a142728d1784efd0b5;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d0df903..7d9f2f3 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -110,7 +110,7 @@
                       (first new-uses)
                       new-uses)))
           (setf (lvar-uses lvar) nil))
-      (setf (node-lvar node) nil)))
+      (flush-node node)))
   (values))
 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
 ;;; its DEST's block, which must be unreachable.
@@ -797,6 +797,30 @@
         (values nil nil)
         (values (node-source-form use) t))))
 
+(defun common-suffix (x y)
+  (let ((mismatch (mismatch x y :from-end t)))
+    (if mismatch
+        (subseq x mismatch)
+        x)))
+
+;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
+;;; singleton.  Otherwise, return a list of the lowest common
+;;; ancestor source form of all the uses (if it can be found),
+;;; followed by all the uses' source forms.
+(defun lvar-all-sources (lvar)
+  (let ((use (lvar-uses lvar)))
+    (if (listp use)
+        (let ((forms  '())
+              (path   (node-source-path (first use))))
+          (dolist (use use (cons (if (find 'original-source-start path)
+                                     (find-original-source path)
+                                     "a hairy form")
+                                 forms))
+            (pushnew (node-source-form use) forms)
+            (setf path (common-suffix path
+                                      (node-source-path use)))))
+        (list (node-source-form use)))))
+
 ;;; Return the unique node, delivering a value to LVAR.
 #!-sb-fluid (declaim (inline lvar-use))
 (defun lvar-use (lvar)
@@ -1397,6 +1421,20 @@
 
   (values))
 
+;;; This function is called to unlink a node from its LVAR;
+;;; we assume that the LVAR's USE list has already been updated,
+;;; and that we only have to mark the node as up for dead code
+;;; elimination, and to clear it LVAR slot.
+(defun flush-node (node)
+  (declare (type node node))
+  (let* ((prev (node-prev node))
+         (block (ctran-block prev)))
+    (reoptimize-component (block-component block) t)
+    (setf (block-attributep (block-flags block)
+                            flush-p type-asserted type-check)
+          t))
+  (setf (node-lvar node) nil))
+
 ;;; This function is called by people who delete nodes; it provides a
 ;;; way to indicate that the value of a lvar is no longer used. We
 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
@@ -1409,13 +1447,7 @@
     (setf (lvar-dest lvar) nil)
     (flush-lvar-externally-checkable-type lvar)
     (do-uses (use lvar)
-      (let ((prev (node-prev use)))
-        (let ((block (ctran-block prev)))
-          (reoptimize-component (block-component block) t)
-          (setf (block-attributep (block-flags block)
-                                  flush-p type-asserted type-check)
-                t)))
-      (setf (node-lvar use) nil))
+      (flush-node use))
     (setf (lvar-uses lvar) nil))
   (values))
 
@@ -1862,7 +1894,7 @@ is :ANY, the function name is not checked."
 ;;;; leaf hackery
 
 ;;; Change the LEAF that a REF refers to.
-(defun change-ref-leaf (ref leaf)
+(defun change-ref-leaf (ref leaf &key recklessly)
   (declare (type ref ref) (type leaf leaf))
   (unless (eq (ref-leaf ref) leaf)
     (push ref (leaf-refs leaf))
@@ -1877,7 +1909,7 @@ is :ANY, the function name is not checked."
                  (eq lvar (basic-combination-fun dest))
                  (csubtypep ltype (specifier-type 'function))))
           (setf (node-derived-type ref) vltype)
-          (derive-node-type ref vltype)))
+          (derive-node-type ref vltype :from-scratch recklessly)))
     (reoptimize-lvar (node-lvar ref)))
   (values))