X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=909cd1f96a998c3072790f399006254c59553149;hb=f705c517d8606a9a72edd11a96725f9c4e4be93d;hp=6fe4c361e4efd29cf197ae2dcc8b220ac4fd6f79;hpb=de66d0244088badaf0898195d3112b62e11727ea;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 6fe4c36..909cd1f 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -336,12 +336,16 @@
               ;; thus the control transfer is a non-local exit.
               (not (eq (block-home-lambda block)
                        (block-home-lambda next)))
-              ;; Stack analysis phase wants ENTRY to start a block.
+              ;; Stack analysis phase wants ENTRY to start a block...
               (entry-p (block-start-node next))
               (let ((last (block-last block)))
                 (and (valued-node-p last)
                      (awhen (node-lvar last)
-                       (consp (lvar-uses it))))))
+                       (or 
+                        ;; ... and a DX-allocator to end a block.
+                        (lvar-dynamic-extent it)
+                        ;; FIXME: This is a partial workaround for bug 303.
+                        (consp (lvar-uses it)))))))
              nil)
             (t
              (join-blocks block next)
@@ -818,10 +822,11 @@
 	     ;; called semi-inlining? A more descriptive name would
 	     ;; be nice. -- WHN 2002-01-07
 	     (frob ()
-	       (let ((res (ir1-convert-lambda-for-defun
-			   (defined-fun-inline-expansion leaf)
-			   leaf t
-			   #'ir1-convert-inline-lambda)))
+	       (let ((res (let ((*allow-instrumenting* t))
+                            (ir1-convert-lambda-for-defun
+                             (defined-fun-inline-expansion leaf)
+                             leaf t
+                             #'ir1-convert-inline-lambda))))
 		 (setf (defined-fun-functional leaf) res)
 		 (change-ref-leaf ref res))))
 	(if ir1-converting-not-optimizing-p
@@ -977,7 +982,7 @@
 	       (:aborted
 		(setf (combination-kind node) :error)
 		(when args
-		  (apply #'compiler-warn args))
+		  (apply #'warn args))
 		(remhash node table)
 		nil)
 	       (:failure
@@ -1084,10 +1089,9 @@
                                 (block-next (node-block call)))
       (let ((new-fun (ir1-convert-inline-lambda
 		      res
-		      :debug-name (debug-namify "LAMBDA-inlined ~A"
-						(as-debug-name
-						 source-name
-						 "<unknown function>"))))
+		      :debug-name (debug-namify "LAMBDA-inlined "
+						source-name
+						"<unknown function>")))
 	    (ref (lvar-use (combination-fun call))))
 	(change-ref-leaf ref new-fun)
 	(setf (combination-kind call) :full)
@@ -1311,7 +1315,8 @@
              (dest (lvar-dest lvar)))
     (when (and
            ;; Think about (LET ((A ...)) (IF ... A ...)): two
-           ;; LVAR-USEs should not be met on one path.
+           ;; LVAR-USEs should not be met on one path. Another problem
+           ;; is with dynamic-extent.
            (eq (lvar-uses lvar) ref)
            (typecase dest
              ;; we should not change lifetime of unknown values lvars
@@ -1336,7 +1341,9 @@
            (eq (node-home-lambda ref)
                (lambda-home (lambda-var-home var))))
       (setf (node-derived-type ref) *wild-type*)
-      (substitute-lvar-uses lvar arg)
+      (substitute-lvar-uses lvar arg
+                            ;; Really it is (EQ (LVAR-USES LVAR) REF):
+                            t)
       (delete-lvar-use ref)
       (change-ref-leaf ref (find-constant nil))
       (delete-ref ref)
@@ -1752,7 +1759,9 @@
                   (unless next-block
                     (when ctran (ensure-block-start ctran))
                     (setq next-block (first (block-succ (node-block cast))))
-                    (ensure-block-start (node-prev cast)))
+                    (ensure-block-start (node-prev cast))
+                    (reoptimize-lvar lvar)
+                    (setf (lvar-%derived-type value) nil))
                   (%delete-lvar-use use)
                   (add-lvar-use use lvar)
                   (unlink-blocks (node-block use) (node-block cast))
@@ -1773,7 +1782,9 @@
           ;; FIXME: Do it in one step.
           (filter-lvar
            value
-           `(multiple-value-call #'list 'dummy))
+           (if (cast-single-value-p cast)
+               `(list 'dummy)
+               `(multiple-value-call #'list 'dummy)))
           (filter-lvar
            (cast-value cast)
            ;; FIXME: Derived type.