X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=eb1531d602a79542aa427b4c474e8e10c88a839c;hb=619ee68faffc3990c5108611762ef54bf8cbbd1e;hp=c98f2bfc5c4ea0946d163ae56b24f4114e5b8a5b;hpb=800e2822d7004944c3aca5d12a7596ac8c6caca6;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index c98f2bf..eb1531d 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -387,7 +387,8 @@
 ;;; slot values. Values for the alist slots are NCONCed to the
 ;;; beginning of the current value, rather than replacing it entirely.
 (defun make-lexenv (&key (default *lexenv*)
-			 funs vars blocks tags type-restrictions
+			 funs vars blocks tags
+                         type-restrictions weakend-type-restrictions
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
 			 (policy (lexenv-policy default)))
@@ -402,6 +403,7 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
+     (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
      lambda cleanup policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
@@ -429,6 +431,7 @@
      nil
      nil
      (lexenv-type-restrictions lexenv) ; XXX
+     (lexenv-weakend-type-restrictions lexenv)
      nil
      nil
      (lexenv-policy lexenv))))
@@ -586,7 +589,7 @@
 	(link-blocks block new-block)
 	(add-to-dfo new-block block)
 	(setf (component-reanalyze (block-component block)) t)
-	
+
 	(do ((cont start (node-cont (continuation-next cont))))
 	    ((eq cont last-cont)
 	     (when (eq (continuation-kind last-cont) :inside-block)
@@ -600,7 +603,7 @@
 
 ;;;; deleting stuff
 
-;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. 
+;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
 (defun delete-lambda-var (leaf)
   (declare (type lambda-var leaf))
 
@@ -679,6 +682,12 @@
       (setf (lambda-bind let) nil)
       (setf (functional-kind let) :deleted))
 
+    ;; LET may be deleted if its BIND is unreachable. Autonomous
+    ;; function may be deleted if it has no reachable references.
+    (unless (member original-kind '(:let :mv-let :assignment))
+      (dolist (ref (lambda-refs clambda))
+        (mark-for-deletion (node-block ref))))
+
     ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
     ;; that we're using the old value of the KIND slot, not the
     ;; current slot value, which has now been set to :DELETED.)
@@ -693,17 +702,17 @@
 	;; referenced, we give a note.
 	(let* ((bind-block (node-block bind))
 	       (component (block-component bind-block))
-	       (return (lambda-return clambda)))
-          (dolist (ref (lambda-refs clambda))
-            (let ((home (node-home-lambda ref)))
-              (aver (eq home clambda))))
+	       (return (lambda-return clambda))
+               (return-block (and return (node-block return))))
 	  (unless (leaf-ever-used clambda)
 	    (let ((*compiler-error-context* bind))
 	      (compiler-note "deleting unused function~:[.~;~:*~%  ~S~]"
 			     (leaf-debug-name clambda))))
-	  (unlink-blocks (component-head component) bind-block)
-	  (when return
-	    (unlink-blocks (node-block return) (component-tail component)))
+          (unless (block-delete-p bind-block)
+            (unlink-blocks (component-head component) bind-block))
+	  (when (and return-block (not (block-delete-p return-block)))
+            (mark-for-deletion return-block)
+	    (unlink-blocks return-block (component-tail component)))
 	  (setf (component-reanalyze component) t)
 	  (let ((tails (lambda-tail-set clambda)))
 	    (setf (tail-set-funs tails)
@@ -840,11 +849,17 @@
 ;;; blocks with the DELETE-P flag.
 (defun mark-for-deletion (block)
   (declare (type cblock block))
-  (unless (block-delete-p block)
-    (setf (block-delete-p block) t)
-    (setf (component-reanalyze (block-component block)) t)
-    (dolist (pred (block-pred block))
-      (mark-for-deletion pred)))
+  (let* ((component (block-component block))
+         (head (component-head component)))
+    (labels ((helper (block)
+               (setf (block-delete-p block) t)
+               (dolist (pred (block-pred block))
+                 (unless (or (block-delete-p pred)
+                             (eq pred head))
+                   (helper pred)))))
+      (unless (block-delete-p block)
+        (helper block)
+        (setf (component-reanalyze component) t))))
   (values))
 
 ;;; Delete CONT, eliminating both control and value semantics. We set
@@ -883,6 +898,7 @@
   (setf (continuation-next cont) nil)
   (setf (continuation-asserted-type cont) *empty-type*)
   (setf (continuation-%derived-type cont) *empty-type*)
+  (setf (continuation-type-to-check cont) *empty-type*)
   (setf (continuation-use cont) nil)
   (setf (continuation-block cont) nil)
   (setf (continuation-reoptimize cont) nil)
@@ -950,7 +966,6 @@
       (bind
        (let ((lambda (bind-lambda node)))
 	 (unless (eq (functional-kind lambda) :deleted)
-	   (aver (functional-somewhat-letlike-p lambda))
 	   (delete-lambda lambda))))
       (exit
        (let ((value (exit-value node))
@@ -1219,6 +1234,7 @@
 	  (setf (node-derived-type inside) *wild-type*)
 	  (flush-dest cont)
 	  (setf (continuation-asserted-type cont) *wild-type*)
+          (setf (continuation-type-to-check cont) *wild-type*)
 	  (values))))))
 
 ;;;; leaf hackery