X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=2a7f9a1005d176342889c0c8b1109bd2a926a3a0;hb=a74b0bdb483504f6faddf8089f848f61ed94b92a;hp=d95c91e462f73d7f4707df5a05290494145195b8;hpb=f3c33b9dccb849bedd48f82bc67102484d1ede79;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index d95c91e..2a7f9a1 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -159,7 +159,7 @@
 ;;;; interface routines used by optimizers
 
 ;;; This function is called by optimizers to indicate that something
-;;; interesting has happened to the value of Cont. Optimizers must
+;;; interesting has happened to the value of CONT. Optimizers must
 ;;; make sure that they don't call for reoptimization when nothing has
 ;;; happened, since optimization will fail to terminate.
 ;;;
@@ -168,7 +168,7 @@
 ;;; is deleted (in which case we do nothing.)
 ;;;
 ;;; Since this can get called during IR1 conversion, we have to be
-;;; careful not to fly into space when the Dest's Prev is missing.
+;;; careful not to fly into space when the DEST's PREV is missing.
 (defun reoptimize-continuation (cont)
   (declare (type continuation cont))
   (unless (member (continuation-kind cont) '(:deleted :unused))
@@ -378,6 +378,7 @@
 	     (derive-node-type node (continuation-derived-type value)))))
 	(cset
 	 (ir1-optimize-set node)))))
+
   (values))
 
 ;;; Try to join with a successor block. If we succeed, we return true,
@@ -579,7 +580,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
@@ -1184,15 +1185,21 @@
   (values))
 
 ;;; Replace a call to a foldable function of constant arguments with
-;;; the result of evaluating the form. We insert the resulting
-;;; constant node after the call, stealing the call's continuation. We
-;;; give the call a continuation with no DEST, which should cause it
-;;; and its arguments to go away. If there is an error during the
+;;; the result of evaluating the form. If there is an error during the
 ;;; evaluation, we give a warning and leave the call alone, making the
 ;;; call a :ERROR call.
 ;;;
 ;;; If there is more than one value, then we transform the call into a
 ;;; VALUES form.
+;;;
+;;; An old commentary also said:
+;;;
+;;;   We insert the resulting constant node after the call, stealing
+;;;   the call's continuation. We give the call a continuation with no
+;;;   DEST, which should cause it and its arguments to go away.
+;;;
+;;; This seems to be more efficient, than the current code. Maybe we
+;;; should really implement it? -- APD, 2002-12-23
 (defun constant-fold-call (call)
   (let ((args (mapcar #'continuation-value (combination-args call)))
 	(fun-name (combination-fun-source-name call)))
@@ -1226,22 +1233,35 @@
 		      ;; when the compiler tries to constant-fold (<=
 		      ;; END SIZE).
 		      ;;
-		      ;; So, with or without bug 173, it'd be 
+		      ;; So, with or without bug 173, it'd be
 		      ;; unnecessarily evil to do a full
 		      ;; COMPILER-WARNING (and thus return FAILURE-P=T
 		      ;; from COMPILE-FILE) for legal code, so we we
 		      ;; use a wimpier COMPILE-STYLE-WARNING instead.
 		      #'compiler-style-warn
 		      "constant folding")
-      (if (not win)
-	  (setf (combination-kind call) :error)
-	  (let ((dummies (make-gensym-list (length args))))
-	    (transform-call
-	     call
-	     `(lambda ,dummies
-		(declare (ignore ,@dummies))
-		(values ,@(mapcar (lambda (x) `',x) values)))
-	     fun-name)))))
+      (cond ((not win)
+             (setf (combination-kind call) :error))
+            ((and (proper-list-of-length-p values 1)
+                  (eq (continuation-kind (node-cont call)) :inside-block))
+             (with-ir1-environment-from-node call
+               (let* ((cont (node-cont call))
+                      (next (continuation-next cont))
+                      (prev (make-continuation)))
+                 (delete-continuation-use call)
+                 (add-continuation-use call prev)
+                 (reference-constant prev cont (first values))
+                 (setf (continuation-next cont) next)
+                 ;; FIXME: type checking?
+                 (reoptimize-continuation cont)
+                 (reoptimize-continuation prev))))
+            (t (let ((dummies (make-gensym-list (length args))))
+                 (transform-call
+                  call
+                  `(lambda ,dummies
+                     (declare (ignore ,@dummies))
+                     (values ,@(mapcar (lambda (x) `',x) values)))
+                  fun-name))))))
   (values))
 
 ;;;; local call optimization
@@ -1262,13 +1282,16 @@
       (values))))
 
 ;;; Figure out the type of a LET variable that has sets. We compute
-;;; the union of the initial value Type and the types of all the set
+;;; the union of the initial value TYPE and the types of all the set
 ;;; values and to a PROPAGATE-TO-REFS with this type.
 (defun propagate-from-sets (var type)
   (collect ((res type type-union))
     (dolist (set (basic-var-sets var))
-      (res (continuation-type (set-value set)))
-      (setf (node-reoptimize set) nil))
+      (let ((type (continuation-type (set-value set))))
+        (res type)
+        (when (node-reoptimize set)
+          (derive-node-type set type)
+          (setf (node-reoptimize set) nil))))
     (propagate-to-refs var (res)))
   (values))
 
@@ -1299,11 +1322,14 @@
        (null (lambda-var-sets leaf)))
       (defined-fun
        (not (eq (defined-fun-inlinep leaf) :notinline)))
-      #!+(and (not sb-fluid) (not sb-xc-host))
       (global-var
        (case (global-var-kind leaf)
-	 (:global-function (eq (symbol-package (leaf-source-name leaf))
-                               *cl-package*)))))))
+	 (:global-function
+          (let ((name (leaf-source-name leaf)))
+            (or #-sb-xc-host
+                (eq (symbol-package (fun-name-block-name name))
+                    *cl-package*)
+                (info :function :info name)))))))))
 
 ;;; If we have a non-set LET var with a single use, then (if possible)
 ;;; replace the variable reference's CONT with the arg continuation.
@@ -1314,7 +1340,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
@@ -1328,7 +1354,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))
@@ -1429,9 +1455,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))
@@ -1600,7 +1626,7 @@
 	    (return-from ir1-optimize-mv-call)))
 
 	(let ((count (cond (total-nvals)
-			   ((and (policy node (zerop safety))
+			   ((and (policy node (zerop verify-arg-count))
 				 (eql min max))
 			    min)
 			   (t nil))))
@@ -1654,7 +1680,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)
@@ -1687,6 +1713,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)
@@ -1708,8 +1736,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