0.pre8.103:

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 4988282..6805e4f 100644 (file)
--- 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))))
 \f
 ;;;; 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))
@@ -382,6 +384,11 @@
 (defun continuation-home-lambda (cont)
   (the clambda
     (continuation-home-lambda-or-null cont)))
+
+#!-sb-fluid (declaim (inline continuation-single-value-p))
+(defun continuation-single-value-p (cont)
+  (not (typep (continuation-dest cont)
+              '(or creturn exit mv-combination))))
 \f
 ;;; Return a new LEXENV just like DEFAULT except for the specified
 ;;; slot values. Values for the alist slots are NCONCed to the
@@ -554,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)
@@ -1125,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
@@ -1230,7 +1240,8 @@
                (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*)
@@ -1289,6 +1300,21 @@
                     :type (ctype-of object)
                     :where-from :defined)))
 \f
+;;; 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)
@@ -1506,8 +1532,3 @@
 
   (let ((action (event-info-action info)))
     (when action (funcall action node))))
-
-;;; It should be in locall.lisp, but is used before in ir1opt.lisp.
-(define-optimization-quality verify-arg-count
-    (if (zerop safety) 0 3)
-  ("no" "maybe" "yes" "yes"))