X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=c98f2bfc5c4ea0946d163ae56b24f4114e5b8a5b;hb=c41d75f1d2defd6234e644ef2b40440a5d1526c5;hp=926e183a0d53222292affc8519e42c65548cc9e4;hpb=dea9bd5c1afe23d9e061c60db654b88187ba9a5e;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 926e183..c98f2bf 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -151,7 +151,8 @@
 		 (nsubst new old (basic-combination-args dest))))))
 
     (flush-dest old)
-    (setf (continuation-dest new) dest))
+    (setf (continuation-dest new) dest)
+    (setf (continuation-%externally-checkable-type new) nil))
   (values))
 
 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
@@ -386,7 +387,7 @@
 ;;; 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
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
 			 (policy (lexenv-policy default)))
@@ -401,8 +402,36 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup policy 
-     (frob options lexenv-options))))
+     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
+     nil
+     nil
+     (lexenv-policy lexenv))))
 
 ;;;; flow/DFO/component hackery
 
@@ -469,7 +498,10 @@
 		      `(when (eq (,slot last) old)
 			 (setf (,slot last) new))))
 	   (frob if-consequent)
-	   (frob if-alternative))))
+	   (frob if-alternative)
+           (when (eq (if-consequent last)
+                     (if-alternative last))
+             (setf (component-reoptimize (block-component block)) t)))))
       (t
        (unless (member new (block-succ block) :test #'eq)
 	 (link-blocks block new)))))
@@ -791,6 +823,7 @@
   (unless (eq (continuation-kind cont) :deleted)
     (aver (continuation-dest cont))
     (setf (continuation-dest cont) nil)
+    (setf (continuation-%externally-checkable-type cont) nil)
     (do-uses (use cont)
       (let ((prev (node-prev use)))
 	(unless (eq (continuation-kind prev) :deleted)
@@ -846,6 +879,7 @@
 
   (setf (continuation-kind cont) :deleted)
   (setf (continuation-dest cont) nil)
+  (setf (continuation-%externally-checkable-type cont) nil)
   (setf (continuation-next cont) nil)
   (setf (continuation-asserted-type cont) *empty-type*)
   (setf (continuation-%derived-type cont) *empty-type*)
@@ -1174,7 +1208,8 @@
 	       (before-args (subseq outside-args 0 arg-position))
 	       (after-args (subseq outside-args (1+ arg-position))))
 	  (dolist (arg inside-args)
-	    (setf (continuation-dest arg) outside))
+	    (setf (continuation-dest arg) outside)
+            (setf (continuation-%externally-checkable-type arg) nil))
 	  (setf (combination-args inside) nil)
 	  (setf (combination-args outside)
 		(append before-args inside-args after-args))