X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=690cc2a4394c1913bc05882b02b1e356f961f6e4;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=683bca891331d6fbdb7b9c47a2aec75f44e50c76;hpb=a74b0bdb483504f6faddf8089f848f61ed94b92a;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 683bca8..690cc2a 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -37,17 +37,19 @@
 	   (type (or cleanup null) cleanup))
   (setf (component-reanalyze (block-component block1)) t)
   (with-ir1-environment-from-node node
-    (let* ((start (make-continuation))
-	   (block (continuation-starts-block start))
-	   (cont (make-continuation))
-	   (*lexenv* (if cleanup
-			 (make-lexenv :cleanup cleanup)
-			 *lexenv*)))
-      (change-block-successor block1 block2 block)
-      (link-blocks block block2)
-      (ir1-convert start cont form)
-      (setf (block-last block) (continuation-use cont))
-      block)))
+    (with-component-last-block (*current-component*
+                                (block-next (component-head *current-component*)))
+      (let* ((start (make-continuation))
+             (block (continuation-starts-block start))
+             (cont (make-continuation))
+             (*lexenv* (if cleanup
+                           (make-lexenv :cleanup cleanup)
+                           *lexenv*)))
+        (change-block-successor block1 block2 block)
+        (link-blocks block block2)
+        (ir1-convert start cont form)
+        (setf (block-last block) (continuation-use cont))
+        block))))
 
 ;;;; continuation use hacking
 
@@ -190,16 +192,16 @@
   (ecase (continuation-kind cont)
     (:unused
      (aver (not (continuation-block cont)))
-     (let* ((head (component-head *current-component*))
-	    (next (block-next head))
-	    (new-block (make-block cont)))
+     (let* ((next (component-last-block *current-component*))
+            (prev (block-prev next))
+            (new-block (make-block cont)))
        (setf (block-next new-block) next
-	     (block-prev new-block) head
-	     (block-prev next) new-block
-	     (block-next head) new-block
-	     (continuation-block cont) new-block
-	     (continuation-use cont) nil
-	     (continuation-kind cont) :block-start)
+             (block-prev new-block) prev
+             (block-prev next) new-block
+             (block-next prev) new-block
+             (continuation-block cont) new-block
+             (continuation-use cont) nil
+             (continuation-kind cont) :block-start)
        new-block))
     (:block-start
      (continuation-block cont))))
@@ -210,7 +212,7 @@
 ;;;    CONT of LAST in its block, then we make it the start of a new
 ;;;    deleted block.
 ;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we
-;;;    split the block using Node-Ends-Block, which makes the
+;;;    split the block using NODE-ENDS-BLOCK, which makes the
 ;;;    continuation be a :BLOCK-START.
 (defun ensure-block-start (cont)
   (declare (type continuation cont))
@@ -559,7 +561,7 @@
 (defun make-empty-component ()
   (let* ((head (make-block-key :start nil :component nil))
 	 (tail (make-block-key :start nil :component nil))
-	 (res (make-component :head head :tail tail)))
+	 (res (make-component head tail)))
     (setf (block-flag head) t)
     (setf (block-flag tail) t)
     (setf (block-component head) res)
@@ -1130,7 +1132,10 @@
 		  (setf (continuation-next prev) nil))
 		 (t
 		  (setf (continuation-next prev) next)
-		  (setf (node-prev next) prev)))
+		  (setf (node-prev next) prev)
+                  (when (and (if-p next) ; AOP wanted
+                             (eq prev (if-test next)))
+                    (reoptimize-continuation prev))))
 	   (setf (node-prev node) nil)
 	   nil)
 	  (t
@@ -1235,12 +1240,22 @@
 		(append before-args inside-args after-args))
 	  (change-ref-leaf (continuation-use inside-fun)
 			   (find-free-fun 'list "???"))
-	  (setf (combination-kind inside) :full)
+	  (setf (combination-kind inside)
+                (info :function :info 'list))
 	  (setf (node-derived-type inside) *wild-type*)
 	  (flush-dest cont)
 	  (setf (continuation-asserted-type cont) *wild-type*)
           (setf (continuation-type-to-check cont) *wild-type*)
 	  (values))))))
+
+(defun flush-combination (combination)
+  (declare (type combination combination))
+  (flush-dest (combination-fun combination))
+  (dolist (arg (combination-args combination))
+    (flush-dest arg))
+  (unlink-node combination)
+  (values))
+
 
 ;;;; leaf hackery
 
@@ -1253,7 +1268,10 @@
     (setf (ref-leaf ref) leaf)
     (setf (leaf-ever-used leaf) t)
     (let ((ltype (leaf-type leaf)))
-      (if (fun-type-p ltype)
+      (if (let* ((cont (node-cont ref))
+                 (dest (continuation-dest cont)))
+            (and (basic-combination-p dest)
+                 (eq cont (basic-combination-fun dest))))
 	  (setf (node-derived-type ref) ltype)
 	  (derive-node-type ref ltype)))
     (reoptimize-continuation (node-cont ref)))
@@ -1294,6 +1312,21 @@
 		     :type (ctype-of object)
 		     :where-from :defined)))
 
+;;; Return true if VAR would have to be closed over if environment
+;;; analysis ran now (i.e. if there are any uses that have a different
+;;; home lambda than VAR's home.)
+(defun closure-var-p (var)
+  (declare (type lambda-var var))
+  (let ((home (lambda-var-home var)))
+    (cond ((eq (functional-kind home) :deleted)
+           nil)
+          (t (let ((home (lambda-home home)))
+               (flet ((frob (l)
+                        (find home l :key #'node-home-lambda
+                              :test-not #'eq)))
+                 (or (frob (leaf-refs var))
+                     (frob (basic-var-sets var)))))))))
+
 ;;; If there is a non-local exit noted in ENTRY's environment that
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (entry cont)