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

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 2a7f9a1..d585c20 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))
@@ -213,6 +214,11 @@
 		~%  ~S~%*** possible internal error? Please report this."
 	       (type-specifier rtype) (type-specifier node-type))))
 	  (setf (node-derived-type node) int)
+          (when (and (ref-p node)
+                     (member-type-p int)
+                     (null (rest (member-type-members int)))
+                     (lambda-var-p (ref-leaf node)))
+            (change-ref-leaf node (find-constant (first (member-type-members int)))))
 	  (reoptimize-continuation (node-cont node))))))
   (values))
 
@@ -311,9 +317,15 @@
           (let ((last (block-last block)))
             (typecase last
               (cif
-               (flush-dest (if-test last))
-               (when (unlink-node last)
-                 (return)))
+               (if (memq (continuation-type-check (if-test last))
+                         '(nil :deleted))
+                   ;; FIXME: Remove the test above when the bug 203
+                   ;; will be fixed.
+                   (progn
+                     (flush-dest (if-test last))
+                     (when (unlink-node last)
+                       (return)))
+                   (return)))
               (exit
                (when (maybe-delete-exit last)
                  (return)))))
@@ -508,10 +520,7 @@
                                                   :lossage-fun nil
                                                   :unwinnage-fun nil))
                               (ir1-attributep attr unsafely-flushable)))
-		 (flush-dest (combination-fun node))
-		 (dolist (arg (combination-args node))
-		   (flush-dest arg))
-		 (unlink-node node))))))
+                 (flush-combination node))))))
 	(mv-combination
 	 (when (eq (basic-combination-kind node) :local)
 	   (let ((fun (combination-lambda node)))
@@ -627,22 +636,25 @@
 	  (convert-if-if use node)
 	  (when (continuation-use test) (return)))))
 
-    (let* ((type (continuation-type test))
-	   (victim
-	    (cond ((constant-continuation-p test)
-		   (if (continuation-value test)
-		       (if-alternative node)
-		       (if-consequent node)))
-		  ((not (types-equal-or-intersect type (specifier-type 'null)))
-		   (if-alternative node))
-		  ((type= type (specifier-type 'null))
-		   (if-consequent node)))))
-      (when victim
-	(flush-dest test)
-	(when (rest (block-succ block))
-	  (unlink-blocks block victim))
-	(setf (component-reanalyze (node-component node)) t)
-	(unlink-node node))))
+    (when (memq (continuation-type-check test)
+                '(nil :deleted))
+      ;; FIXME: Remove the test above when the bug 203 will be fixed.
+      (let* ((type (continuation-type test))
+             (victim
+              (cond ((constant-continuation-p test)
+                     (if (continuation-value test)
+                         (if-alternative node)
+                         (if-consequent node)))
+                    ((not (types-equal-or-intersect type (specifier-type 'null)))
+                     (if-alternative node))
+                    ((type= type (specifier-type 'null))
+                     (if-consequent node)))))
+        (when victim
+          (flush-dest test)
+          (when (rest (block-succ block))
+            (unlink-blocks block victim))
+          (setf (component-reanalyze (node-component node)) t)
+          (unlink-node node)))))
   (values))
 
 ;;; Create a new copy of an IF node that tests the value of the node
@@ -1167,21 +1179,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
@@ -1254,7 +1269,8 @@
                  (setf (continuation-next cont) next)
                  ;; FIXME: type checking?
                  (reoptimize-continuation cont)
-                 (reoptimize-continuation prev))))
+                 (reoptimize-continuation prev)
+                 (flush-combination call))))
             (t (let ((dummies (make-gensym-list (length args))))
                  (transform-call
                   call
@@ -1700,7 +1716,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:
@@ -1720,6 +1737,8 @@
     (when (and (combination-p use)
 	       (eq (continuation-fun-name (combination-fun use))
 		   'list))
+
+      ;; FIXME: VALUES might not satisfy an assertion on NODE-CONT.
       (change-ref-leaf (continuation-use (combination-fun node))
 		       (find-free-fun 'values "in a strange place"))
       (setf (combination-kind node) :full)