X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=5e14d26d4d733b95fc671ee774c9f5d1e1581945;hb=61c18727668ff0c3263a3d363e609d4522d545cc;hp=e0477c2ee5611e660ad9b23fdf195ea8820ee987;hpb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index e0477c2..5e14d26 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -131,12 +131,11 @@
 (defun immediately-used-p (lvar node)
   (declare (type lvar lvar) (type node node))
   (aver (eq (node-lvar node) lvar))
-  (and (eq (lvar-dest lvar)
-           (acond ((node-next node)
-                   (ctran-next it))
-                  (t (let* ((block (node-block node))
-                            (next-block (first (block-succ block))))
-                       (block-start-node next-block)))))))
+  (let ((dest (lvar-dest lvar)))
+    (acond ((node-next node)
+            (eq (ctran-next it) dest))
+           (t (eq (block-start (first (block-succ (node-block node))))
+                  (node-prev dest))))))
 
 ;;;; lvar substitution
 
@@ -773,20 +772,31 @@
     (clambda (delete-lambda fun)))
   (values))
 
-;;; Deal with deleting the last reference to a CLAMBDA. Since there is
-;;; only one way into a CLAMBDA, deleting the last reference to a
-;;; CLAMBDA ensures that there is no way to reach any of the code in
-;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
-;;; :DELETED, causing IR1 optimization to delete blocks in that
-;;; CLAMBDA.
+;;; Deal with deleting the last reference to a CLAMBDA. It is called
+;;; in two situations: when the lambda is unreachable (so that its
+;;; body may be deleted), and when it is an effectless LET (in this
+;;; case its body is reachable and is not completely "its"). We set
+;;; FUNCTIONAL-KIND to :DELETED and rely on IR1-OPTIMIZE to delete its
+;;; blocks.
 (defun delete-lambda (clambda)
   (declare (type clambda clambda))
   (let ((original-kind (functional-kind clambda))
 	(bind (lambda-bind clambda)))
-    (aver (not (member original-kind '(:deleted :optional :toplevel))))
+    (aver (not (member original-kind '(:deleted :toplevel))))
     (aver (not (functional-has-external-references-p clambda)))
     (setf (functional-kind clambda) :deleted)
     (setf (lambda-bind clambda) nil)
+
+    (when bind              ; CLAMBDA is deleted due to unreachability
+      (labels ((delete-children (lambda)
+                 (dolist (child (lambda-children lambda))
+                   (cond ((eq (functional-kind child) :deleted)
+                          (delete-children child))
+                         (t
+                          (delete-lambda child))))
+                 (setf (lambda-children lambda) nil)
+                 (setf (lambda-parent lambda) nil)))
+        (delete-children clambda)))
     (dolist (let (lambda-lets clambda))
       (setf (lambda-bind let) nil)
       (setf (functional-kind let) :deleted))
@@ -829,7 +839,7 @@
 		  (delete clambda (tail-set-funs tails)))
 	    (setf (lambda-tail-set clambda) nil))
 	  (setf (component-lambdas component)
-		(delete clambda (component-lambdas component)))))
+		(delq clambda (component-lambdas component)))))
 
     ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
     ;; ENTRY-FUN so that people will know that it is not an entry
@@ -996,7 +1006,7 @@
   (do-nodes-carefully (node block)
     (when (valued-node-p node)
       (delete-lvar-use node))
-    (typecase node
+    (etypecase node
       (ref (delete-ref node))
       (cif (flush-dest (if-test node)))
       ;; The next two cases serve to maintain the invariant that a LET
@@ -1029,6 +1039,11 @@
          (when entry
            (setf (entry-exits entry)
                  (delq node (entry-exits entry))))))
+      (entry
+       (dolist (exit (entry-exits node))
+         (mark-for-deletion (node-block exit)))
+       (let ((home (node-home-lambda node)))
+         (setf (lambda-entries home) (delq node (lambda-entries home)))))
       (creturn
        (flush-dest (return-result node))
        (delete-return node))
@@ -1227,10 +1242,11 @@
   (do-blocks (block component)
     (setf (block-delete-p block) t))
   (dolist (fun (component-lambdas component))
-    (setf (functional-kind fun) nil)
-    (setf (functional-entry-fun fun) nil)
-    (setf (leaf-refs fun) nil)
-    (delete-functional fun))
+    (unless (eq (functional-kind fun) :deleted)
+      (setf (functional-kind fun) nil)
+      (setf (functional-entry-fun fun) nil)
+      (setf (leaf-refs fun) nil)
+      (delete-functional fun)))
   (do-blocks (block component)
     (delete-block block))
   (values))
@@ -1498,6 +1514,18 @@
               ;; LET-converted functionals are even worse.
               (eql (functional-kind functional) :deleted)))
     (throw 'locall-already-let-converted functional)))
+
+(defun call-full-like-p (call)
+  (declare (type combination call))
+  (let ((kind (basic-combination-kind call)))
+    (or (eq kind :full)
+        (and (fun-info-p kind)
+             (not (fun-info-ir2-convert kind))
+             (dolist (template (fun-info-templates kind) t)
+               (when (eq (template-ltn-policy template) :fast-safe)
+                 (multiple-value-bind (val win)
+                     (valid-fun-use call (template-type template))
+                   (when (or val (not win)) (return nil)))))))))
 
 ;;;; careful call