X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=bf6c409fb1d257dbc8fab41f7befd27d03cf8b90;hb=f1407e424f1063203af07d2e61ceef58515a4797;hp=0257739250b227ab7c02bede0b3823a22e26c447;hpb=a74b0bdb483504f6faddf8089f848f61ed94b92a;p=sbcl.git

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 0257739..bf6c409 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -34,17 +34,14 @@
 ;;; continuations.
 (defun propagate-to-args (call fun)
   (declare (type combination call) (type clambda fun))
-  (do ((args (basic-combination-args call) (cdr args))
-       (vars (lambda-vars fun) (cdr vars)))
-      ((null args))
-    (let ((arg (car args))
-	  (var (car vars)))
-      (cond ((leaf-refs var)
-	     (assert-continuation-type arg (leaf-type var)
-                                       (lexenv-policy (node-lexenv call))))
-	    (t
-	     (flush-dest arg)
-	     (setf (car args) nil)))))
+  (loop with policy = (lexenv-policy (node-lexenv call))
+        for args on (basic-combination-args call)
+        and var in (lambda-vars fun)
+        for arg =  (assert-continuation-type (car args)
+                                             (leaf-type var) policy)
+        do (unless (leaf-refs var)
+             (flush-dest (car args))
+             (setf (car args) nil)))
 
   (values))
 
@@ -112,9 +109,9 @@
 ;;;
 ;;; If there is a &MORE arg, then there are a couple of optimizations
 ;;; that we make (more for space than anything else):
-;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since 
+;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since
 ;;;    no argument count error is possible.
-;;; -- We can omit the = clause for the last entry-point, allowing the 
+;;; -- We can omit the = clause for the last entry-point, allowing the
 ;;;    case of 0 more args to fall through to the more entry.
 ;;;
 ;;; We don't bother to policy conditionalize wrong arg errors in
@@ -442,8 +439,7 @@
 
       (assert-continuation-type
        (first (basic-combination-args call))
-       (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
-			 :rest *universal-type*)
+       (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
        (lexenv-policy (node-lexenv call)))))
   (values))
 
@@ -637,7 +633,7 @@
       (collect ((call-args))
 	(do ((var arglist (cdr var))
 	     (temp temps (cdr temp)))
-	    (())
+	    ((null var))
 	  (let ((info (lambda-var-arg-info (car var))))
 	    (if info
 		(ecase (arg-info-kind info)
@@ -708,7 +704,7 @@
 	(join-components component clambda-component)))
     (let ((*current-component* component))
       (node-ends-block call))
-    ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other 
+    ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
     ;; uses of '=.*length' which could also be converted to use
     ;; DESTRUCTURING-BIND or PROPER-LIST-OF-LENGTH-P.
     (aver (= (length (block-succ call-block)) 1))
@@ -832,15 +828,6 @@
 ;;; node, and change the control flow to transfer to NEXT-BLOCK
 ;;; instead. Move all the uses of the result continuation to CALL's
 ;;; CONT.
-;;;
-;;; If the actual continuation is only used by the LET call, then we
-;;; intersect the type assertion on the dummy continuation with the
-;;; assertion for the actual continuation; in all other cases
-;;; assertions on the dummy continuation are lost.
-;;;
-;;; We also intersect the derived type of the CALL with the derived
-;;; type of all the dummy continuation's uses. This serves mainly to
-;;; propagate TRULY-THE through LETs.
 (defun move-return-uses (fun call next-block)
   (declare (type clambda fun) (type basic-combination call)
 	   (type cblock next-block))
@@ -854,13 +841,9 @@
     (let ((result (return-result return))
 	  (cont (node-cont call))
 	  (call-type (node-derived-type call)))
-      (when (eq (continuation-use cont) call)
-        (set-continuation-type-assertion
-         cont
-         (continuation-asserted-type result)
-         (continuation-type-to-check result)))
       (unless (eq call-type *wild-type*)
-	(do-uses (use result)
+        ;; FIXME: Replace the call with unsafe CAST. -- APD, 2002-01-26
+        (do-uses (use result)
 	  (derive-node-type use call-type)))
       (substitute-continuation-uses cont result)))
   (values))
@@ -944,12 +927,25 @@
     (cond ((not return))
 	  ((or next-block call-return)
 	   (unless (block-delete-p (node-block return))
+             (when (and (node-tail-p call)
+                        call-return
+                        (not (eq (node-cont call)
+                                 (return-result call-return))))
+               ;; We do not care to give a meaningful continuation to
+               ;; a tail combination, but here we need it.
+               (delete-continuation-use call)
+               (add-continuation-use call (return-result call-return)))
 	     (move-return-uses fun call
-			       (or next-block (node-block call-return)))))
+			       (or next-block
+                                   (let ((block (node-block call-return)))
+                                     (when (block-delete-p block)
+                                       (setf (block-delete-p block) nil))
+                                     block)))))
 	  (t
 	   (aver (node-tail-p call))
 	   (setf (lambda-return call-fun) return)
-	   (setf (return-lambda return) call-fun))))
+	   (setf (return-lambda return) call-fun)
+           (setf (lambda-return fun) nil))))
   (move-let-call-cont fun)
   (values))