0.7.8.53:

[sbcl.git] / src / compiler / ir1util.lisp

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 926e183..c98f2bf 100644 (file)
--- 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))))
 \f
 ;;;; 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))