X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=946c32b4ae9d8ed20338524525f3c82f0378f49d;hb=b0642df835dc2fca3e4cf47aff978ecdc88799d5;hp=c608b669dfcf4c85ed68e16265053380f1d351f6;hpb=ae97d229fa1b74032a5c7cba21840598da6726c8;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index c608b66..946c32b 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -37,17 +37,19 @@
 	   (type (or cleanup null) cleanup))
   (setf (component-reanalyze (block-component block1)) t)
   (with-ir1-environment-from-node node
-    (let* ((start (make-continuation))
-	   (block (continuation-starts-block start))
-	   (cont (make-continuation))
-	   (*lexenv* (if cleanup
-			 (make-lexenv :cleanup cleanup)
-			 *lexenv*)))
-      (change-block-successor block1 block2 block)
-      (link-blocks block block2)
-      (ir1-convert start cont form)
-      (setf (block-last block) (continuation-use cont))
-      block)))
+    (with-component-last-block (*current-component*
+                                (block-next (component-head *current-component*)))
+      (let* ((start (make-continuation))
+             (block (continuation-starts-block start))
+             (cont (make-continuation))
+             (*lexenv* (if cleanup
+                           (make-lexenv :cleanup cleanup)
+                           *lexenv*)))
+        (change-block-successor block1 block2 block)
+        (link-blocks block block2)
+        (ir1-convert start cont form)
+        (setf (block-last block) (continuation-use cont))
+        block))))
 
 ;;;; continuation use hacking
 
@@ -190,16 +192,16 @@
   (ecase (continuation-kind cont)
     (:unused
      (aver (not (continuation-block cont)))
-     (let* ((head (component-head *current-component*))
-	    (next (block-next head))
-	    (new-block (make-block cont)))
+     (let* ((next (component-last-block *current-component*))
+            (prev (block-prev next))
+            (new-block (make-block cont)))
        (setf (block-next new-block) next
-	     (block-prev new-block) head
-	     (block-prev next) new-block
-	     (block-next head) new-block
-	     (continuation-block cont) new-block
-	     (continuation-use cont) nil
-	     (continuation-kind cont) :block-start)
+             (block-prev new-block) prev
+             (block-prev next) new-block
+             (block-next prev) new-block
+             (continuation-block cont) new-block
+             (continuation-use cont) nil
+             (continuation-kind cont) :block-start)
        new-block))
     (:block-start
      (continuation-block cont))))
@@ -210,7 +212,7 @@
 ;;;    CONT of LAST in its block, then we make it the start of a new
 ;;;    deleted block.
 ;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we
-;;;    split the block using Node-Ends-Block, which makes the
+;;;    split the block using NODE-ENDS-BLOCK, which makes the
 ;;;    continuation be a :BLOCK-START.
 (defun ensure-block-start (cont)
   (declare (type continuation cont))
@@ -382,12 +384,18 @@
 (defun continuation-home-lambda (cont)
   (the clambda
     (continuation-home-lambda-or-null cont)))
+
+#!-sb-fluid (declaim (inline continuation-single-value-p))
+(defun continuation-single-value-p (cont)
+  (not (typep (continuation-dest cont)
+              '(or creturn exit mv-combination))))
 
 ;;; Return a new LEXENV just like DEFAULT except for the specified
 ;;; 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 options
+			 funs vars blocks tags
+                         type-restrictions weakend-type-restrictions
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
 			 (policy (lexenv-policy default)))
@@ -402,8 +410,38 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup policy 
-     (frob options lexenv-options))))
+     (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
+     lambda cleanup policy)))
+
+;;; Makes a LEXENV, suitable for using in a MACROLET introduced
+;;; macroexpander
+(defun make-restricted-lexenv (lexenv)
+  (flet ((fun-good-p (fun)
+           (destructuring-bind (name . thing) fun
+             (declare (ignore name))
+             (etypecase thing
+               (functional nil)
+               (global-var t)
+               (cons (aver (eq (car thing) 'macro))
+                     t))))
+         (var-good-p (var)
+           (destructuring-bind (name . thing) var
+             (declare (ignore name))
+             (etypecase thing
+               (leaf nil)
+               (cons (aver (eq (car thing) 'macro))
+                     t)
+               (heap-alien-info nil)))))
+    (internal-make-lexenv
+     (remove-if-not #'fun-good-p (lexenv-funs lexenv))
+     (remove-if-not #'var-good-p (lexenv-vars lexenv))
+     nil
+     nil
+     (lexenv-type-restrictions lexenv) ; XXX
+     (lexenv-weakend-type-restrictions lexenv)
+     nil
+     nil
+     (lexenv-policy lexenv))))
 
 ;;;; flow/DFO/component hackery
 
@@ -523,7 +561,7 @@
 (defun make-empty-component ()
   (let* ((head (make-block-key :start nil :component nil))
 	 (tail (make-block-key :start nil :component nil))
-	 (res (make-component :head head :tail tail)))
+	 (res (make-component head tail)))
     (setf (block-flag head) t)
     (setf (block-flag tail) t)
     (setf (block-component head) res)
@@ -558,7 +596,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)
@@ -572,7 +610,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))
 
@@ -651,6 +689,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.)
@@ -665,17 +709,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)
@@ -812,11 +856,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
@@ -855,6 +905,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)
@@ -922,7 +973,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))
@@ -1191,6 +1241,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
@@ -1202,6 +1253,7 @@
     (push ref (leaf-refs leaf))
     (delete-ref ref)
     (setf (ref-leaf ref) leaf)
+    (setf (leaf-ever-used leaf) t)
     (let ((ltype (leaf-type leaf)))
       (if (fun-type-p ltype)
 	  (setf (node-derived-type ref) ltype)