X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1opt.lisp;h=8607e6844387f8f0c04b0c2773c269c06034f230;hb=b870615b146940f661e5d0e9069ca4e16e9f483d;hp=02b83404f7121a28e73546816a787c2d4a42f4a7;hpb=25e76ec2b1083ac6a4bba42af7ad7b5a8239f2b8;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 02b8340..8607e68 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -134,6 +134,7 @@
           (let* ((fun (combination-fun dest))
                  (args (combination-args dest))
                  (fun-type (continuation-type fun)))
+            (setf (continuation-%externally-checkable-type fun) *wild-type*)
             (if (or (not (fun-type-p fun-type))
                     ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
                     (fun-type-wild-args fun-type))
@@ -580,7 +581,7 @@
 ;;; all functions in the tail set to be equivalent, this amounts to
 ;;; bringing the entire tail set up to date. We iterate over the
 ;;; returns for all the functions in the tail set, reanalyzing them
-;;; all (not treating Node specially.)
+;;; all (not treating NODE specially.)
 ;;;
 ;;; When we are done, we check whether the new type is different from
 ;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
@@ -1167,21 +1168,24 @@
 ;;; possible to do this starting from debug names as well as source
 ;;; names, but as of sbcl-0.7.1.5, there was no need for this
 ;;; generality, since source names are always known to our callers.)
-(defun transform-call (node res source-name)
-  (declare (type combination node) (list res))
+(defun transform-call (call res source-name)
+  (declare (type combination call) (list res))
   (aver (and (legal-fun-name-p source-name)
 	     (not (eql source-name '.anonymous.))))
-  (with-ir1-environment-from-node node
+  (node-ends-block call)
+  (with-ir1-environment-from-node call
+    (with-component-last-block (*current-component*
+                                (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>"))))
-	    (ref (continuation-use (combination-fun node))))
+	    (ref (continuation-use (combination-fun call))))
 	(change-ref-leaf ref new-fun)
-	(setf (combination-kind node) :full)
-	(locall-analyze-component *current-component*)))
+	(setf (combination-kind call) :full)
+	(locall-analyze-component *current-component*))))
   (values))
 
 ;;; Replace a call to a foldable function of constant arguments with
@@ -1340,7 +1344,7 @@
 ;;; -- either continuation has a funky TYPE-CHECK annotation.
 ;;; -- the continuations have incompatible assertions, so the new asserted type
 ;;;    would be NIL.
-;;; -- the var's DEST has a different policy than the ARG's (think safety).
+;;; -- the VAR's DEST has a different policy than the ARG's (think safety).
 ;;;
 ;;; We change the REF to be a reference to NIL with unused value, and
 ;;; let it be flushed as dead code. A side effect of this substitution
@@ -1354,7 +1358,7 @@
 	 (dest (continuation-dest cont)))
     (when (and (eq (continuation-use cont) ref)
 	       dest
-	       (not (typep dest '(or creturn exit mv-combination)))
+	       (continuation-single-value-p cont)
 	       (eq (node-home-lambda ref)
 		   (lambda-home (lambda-var-home var)))
 	       (member (continuation-type-check arg) '(t nil))
@@ -1455,9 +1459,9 @@
 ;;; If the function has an XEP, then we don't do anything, since we
 ;;; won't discover anything.
 ;;;
-;;; We can clear the Continuation-Reoptimize flags for arguments in
-;;; all calls corresponding to changed arguments in Call, since the
-;;; only use in IR1 optimization of the Reoptimize flag for local call
+;;; We can clear the CONTINUATION-REOPTIMIZE flags for arguments in
+;;; all calls corresponding to changed arguments in CALL, since the
+;;; only use in IR1 optimization of the REOPTIMIZE flag for local call
 ;;; args is right here.
 (defun propagate-local-call-args (call fun)
   (declare (type combination call) (type clambda fun))
@@ -1680,7 +1684,7 @@
 		   (setf (node-prev use) nil)
 		   (setf (continuation-next node-prev) nil)
 		   (collect ((res vals))
-		     (loop as cont = (make-continuation use)
+		     (loop for cont = (make-continuation use)
 			   and prev = node-prev then cont
 			   repeat (- nvars nvals)
 			   do (reference-constant prev cont nil)
@@ -1700,7 +1704,8 @@
 	(unlink-node call)
 	(when vals
 	  (reoptimize-continuation (first vals)))
-	(propagate-to-args use fun))
+	(propagate-to-args use fun)
+        (reoptimize-call use))
       t)))
 
 ;;; If we see:
@@ -1713,6 +1718,8 @@
 ;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
 ;;; args of the VALUES-LIST call, flushing the old argument
 ;;; continuation (allowing the LIST to be flushed.)
+;;;
+;;; FIXME: Thus we lose possible type assertions on (LIST ...).
 (defoptimizer (values-list optimizer) ((list) node)
   (let ((use (continuation-use list)))
     (when (and (combination-p use)
@@ -1734,8 +1741,7 @@
 ;;; to a PROG1. This allows the computation of the additional values
 ;;; to become dead code.
 (deftransform values ((&rest vals) * * :node node)
-  (when (typep (continuation-dest (node-cont node))
-	       '(or creturn exit mv-combination))
+  (unless (continuation-single-value-p (node-cont node))
     (give-up-ir1-transform))
   (setf (node-derived-type node) *wild-type*)
   (if vals