1.0.28.51: better MAKE-ARRAY transforms

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 57caf17..d501d67 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -20,7 +20,7 @@
 (defun node-enclosing-cleanup (node)
   (declare (type node node))
   (do ((lexenv (node-lexenv node)
 (defun node-enclosing-cleanup (node)
   (declare (type node node))
   (do ((lexenv (node-lexenv node)

-              (lambda-call-lexenv (lexenv-lambda lexenv))))
+               (lambda-call-lexenv (lexenv-lambda lexenv))))

       ((null lexenv) nil)
     (let ((cup (lexenv-cleanup lexenv)))
       (when cup (return cup)))))
       ((null lexenv) nil)
     (let ((cup (lexenv-cleanup lexenv)))
       (when cup (return cup)))))

@@ -34,7 +34,7 @@
 ;;; that cleanup.
 (defun insert-cleanup-code (block1 block2 node form &optional cleanup)
   (declare (type cblock block1 block2) (type node node)
 ;;; that cleanup.
 (defun insert-cleanup-code (block1 block2 node form &optional cleanup)
   (declare (type cblock block1 block2) (type node node)

-          (type (or cleanup null) cleanup))
+           (type (or cleanup null) cleanup))

   (setf (component-reanalyze (block-component block1)) t)
   (with-ir1-environment-from-node node
     (with-component-last-block (*current-component*
   (setf (component-reanalyze (block-component block1)) t)
   (with-ir1-environment-from-node node
     (with-component-last-block (*current-component*

@@ -62,11 +62,23 @@
         uses
         (list uses))))
 
         uses
         (list uses))))
 

+(declaim (ftype (sfunction (lvar) lvar) principal-lvar))
+(defun principal-lvar (lvar)
+  (labels ((pl (lvar)
+             (let ((use (lvar-uses lvar)))
+               (if (cast-p use)
+                   (pl (cast-value use))
+                   lvar))))
+    (pl lvar)))
+

 (defun principal-lvar-use (lvar)
 (defun principal-lvar-use (lvar)

-  (let ((use (lvar-uses lvar)))
-    (if (cast-p use)
-        (principal-lvar-use (cast-value use))
-        use)))
+  (labels ((plu (lvar)
+             (declare (type lvar lvar))
+             (let ((use (lvar-uses lvar)))
+               (if (cast-p use)
+                   (plu (cast-value use))
+                   use))))
+    (plu lvar)))

 
 ;;; Update lvar use information so that NODE is no longer a use of its
 ;;; LVAR.
 
 ;;; Update lvar use information so that NODE is no longer a use of its
 ;;; LVAR.

@@ -80,7 +92,7 @@
 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
 ;;; be given a new use.
 (defun %delete-lvar-use (node)
 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
 ;;; be given a new use.
 (defun %delete-lvar-use (node)

-  (let* ((lvar (node-lvar node)))
+  (let ((lvar (node-lvar node)))

     (when lvar
       (if (listp (lvar-uses lvar))
           (let ((new-uses (delq node (lvar-uses lvar))))
     (when lvar
       (if (listp (lvar-uses lvar))
           (let ((new-uses (delq node (lvar-uses lvar))))

@@ -153,9 +165,9 @@
       (exit (setf (exit-value dest) new))
       (basic-combination
        (if (eq old (basic-combination-fun dest))
       (exit (setf (exit-value dest) new))
       (basic-combination
        (if (eq old (basic-combination-fun dest))

-          (setf (basic-combination-fun dest) new)
-          (setf (basic-combination-args dest)
-                (nsubst new old (basic-combination-args dest)))))
+           (setf (basic-combination-fun dest) new)
+           (setf (basic-combination-args dest)
+                 (nsubst new old (basic-combination-args dest)))))

       (cast (setf (cast-value dest) new)))
 
     (setf (lvar-dest old) nil)
       (cast (setf (cast-value dest) new)))
 
     (setf (lvar-dest old) nil)

@@ -164,17 +176,27 @@
   (values))
 
 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
   (values))
 
 ;;; Replace all uses of OLD with uses of NEW, where NEW has an

-;;; arbitary number of uses.
-(defun substitute-lvar-uses (new old)
+;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
+(defun substitute-lvar-uses (new old propagate-dx)

   (declare (type lvar old)
   (declare (type lvar old)

-           (type (or lvar null) new))
+           (type (or lvar null) new)
+           (type boolean propagate-dx))
+
+  (cond (new
+         (do-uses (node old)
+           (%delete-lvar-use node)
+           (add-lvar-use node new))
+         (reoptimize-lvar new)
+         (awhen (and propagate-dx (lvar-dynamic-extent old))
+           (setf (lvar-dynamic-extent old) nil)
+           (unless (lvar-dynamic-extent new)
+             (setf (lvar-dynamic-extent new) it)
+             (setf (cleanup-info it) (subst new old (cleanup-info it)))))
+         (when (lvar-dynamic-extent new)
+           (do-uses (node new)
+             (node-ends-block node))))
+        (t (flush-dest old)))

 
 

-  (do-uses (node old)
-    (%delete-lvar-use node)
-    (when new
-      (add-lvar-use node new)))
-
-  (when new (reoptimize-lvar new))

   (values))
 \f
 ;;;; block starting/creation
   (values))
 \f
 ;;;; block starting/creation

@@ -221,6 +243,25 @@
       ((:inside-block)
        (node-ends-block (ctran-use ctran)))))
   (values))
       ((:inside-block)
        (node-ends-block (ctran-use ctran)))))
   (values))

+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+  (declare (type ctran ctran))
+  (aver (not (ctran-next ctran)))
+  (ecase (ctran-kind ctran)
+    (:inside-block
+     (let ((block (ctran-block ctran))
+           (node (ctran-use ctran)))
+       (aver (not (block-last block)))
+       (aver node)
+       (setf (block-last block) node)
+       (setf (node-next node) nil)
+       (setf (ctran-use ctran) nil)
+       (setf (ctran-kind ctran) :unused)
+       (setf (ctran-block ctran) nil)
+       (link-blocks block (ctran-starts-block ctran))))
+    (:block-start)))

 \f
 ;;;;
 
 \f
 ;;;;
 

@@ -287,14 +328,35 @@
                     (when (and (basic-combination-p use)
                                (eq (basic-combination-kind use) :local))
                       (merges use))))
                     (when (and (basic-combination-p use)
                                (eq (basic-combination-kind use) :local))
                       (merges use))))

+                (substitute-lvar-uses lvar value
+                                      (and lvar (eq (lvar-uses lvar) node)))

                 (%delete-lvar-use node)
                 (%delete-lvar-use node)

-                (substitute-lvar-uses lvar value)

                 (prog1
                     (unlink-node node)
                   (dolist (merge (merges))
                     (merge-tail-sets merge)))))
         (t (flush-dest value)
            (unlink-node node))))
                 (prog1
                     (unlink-node node)
                   (dolist (merge (merges))
                     (merge-tail-sets merge)))))
         (t (flush-dest value)
            (unlink-node node))))

+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+  (declare (type node next) (type lvar lvar) (type ctype type))
+  (with-ir1-environment-from-node next
+    (let* ((ctran (node-prev next))
+           (cast (make-cast lvar type policy))
+           (internal-ctran (make-ctran)))
+      (setf (ctran-next ctran) cast
+            (node-prev cast) ctran)
+      (use-ctran cast internal-ctran)
+      (link-node-to-previous-ctran next internal-ctran)
+      (setf (lvar-dest lvar) cast)
+      (reoptimize-lvar lvar)
+      (when (return-p next)
+        (node-ends-block cast))
+      (setf (block-attributep (block-flags (node-block cast))
+                              type-check type-asserted)
+            t)
+      cast)))

 \f
 ;;;; miscellaneous shorthand functions
 
 \f
 ;;;; miscellaneous shorthand functions
 

@@ -305,8 +367,8 @@
 (defun node-home-lambda (node)
   (declare (type node node))
   (do ((fun (lexenv-lambda (node-lexenv node))
 (defun node-home-lambda (node)
   (declare (type node node))
   (do ((fun (lexenv-lambda (node-lexenv node))

-           (lexenv-lambda (lambda-call-lexenv fun))))
-      ((not (eq (functional-kind fun) :deleted))
+            (lexenv-lambda (lambda-call-lexenv fun))))
+      ((not (memq (functional-kind fun) '(:deleted :zombie)))

        (lambda-home fun))
     (when (eq (lambda-home fun) fun)
       (return fun))))
        (lambda-home fun))
     (when (eq (lambda-home fun) fun)
       (return fun))))

@@ -324,6 +386,130 @@
 (defun node-dest (node)
   (awhen (node-lvar node) (lvar-dest it)))
 
 (defun node-dest (node)
   (awhen (node-lvar node) (lvar-dest it)))
 

+#!-sb-fluid (declaim (inline node-stack-allocate-p))
+(defun node-stack-allocate-p (node)
+  (awhen (node-lvar node)
+    (lvar-dynamic-extent it)))
+
+(declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component))
+                           boolean) use-good-for-dx-p))
+(declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component))
+                           boolean) lvar-good-for-dx-p))
+(defun use-good-for-dx-p (use dx &optional component)
+  ;; FIXME: Can casts point to LVARs in other components?
+  ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
+  ;; PRINCIPAL-LVAR is always in the same component as the original one. It
+  ;; would be either good to have an explanation of why casts don't point
+  ;; across components, or an explanation of when they do it. ...in the
+  ;; meanwhile AVER that our assumption holds true.
+  (aver (or (not component) (eq component (node-component use))))
+  (or (dx-combination-p use dx)
+      (and (cast-p use)
+           (not (cast-type-check use))
+           (lvar-good-for-dx-p (cast-value use) dx component))
+      (and (trivial-lambda-var-ref-p use)
+           (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use))))
+             (or (eq use uses)
+                 (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component))))))
+
+(defun lvar-good-for-dx-p (lvar dx &optional component)
+  (let ((uses (lvar-uses lvar)))
+    (if (listp uses)
+        (every (lambda (use)
+                 (use-good-for-dx-p use dx component))
+               uses)
+        (use-good-for-dx-p uses dx component))))
+
+(defun known-dx-combination-p (use dx)
+  (and (eq (combination-kind use) :known)
+       (let ((info (combination-fun-info use)))
+         (or (awhen (fun-info-stack-allocate-result info)
+               (funcall it use dx))
+             (awhen (fun-info-result-arg info)
+               (let ((args (combination-args use)))
+                 (lvar-good-for-dx-p (if (zerop it)
+                                         (car args)
+                                         (nth it args))
+                                     dx)))))))
+
+(defun dx-combination-p (use dx)
+  (and (combination-p use)
+       (or
+        ;; Known, and can do DX.
+        (known-dx-combination-p use dx)
+        ;; Possibly a not-yet-eliminated lambda which ends up returning the
+        ;; results of an actual known DX combination.
+        (let* ((fun (combination-fun use))
+               (ref (principal-lvar-use fun))
+               (clambda (when (ref-p ref)
+                          (ref-leaf ref)))
+               (creturn (when (lambda-p clambda)
+                          (lambda-return clambda)))
+               (result-use (when (return-p creturn)
+                             (principal-lvar-use (return-result creturn)))))
+          ;; FIXME: We should be able to deal with multiple uses here as well.
+          (and (dx-combination-p result-use dx)
+               (combination-args-flow-cleanly-p use result-use dx))))))
+
+(defun combination-args-flow-cleanly-p (combination1 combination2 dx)
+  (labels ((recurse (combination)
+             (or (eq combination combination2)
+                 (if (known-dx-combination-p combination dx)
+                     (let ((dest (lvar-dest (combination-lvar combination))))
+                       (and (combination-p dest)
+                            (recurse dest)))
+                     (let* ((fun1 (combination-fun combination))
+                            (ref1 (principal-lvar-use fun1))
+                            (clambda1 (when (ref-p ref1) (ref-leaf ref1))))
+                       (when (lambda-p clambda1)
+                         (dolist (var (lambda-vars clambda1) t)
+                           (dolist (var-ref (lambda-var-refs var))
+                             (let ((dest (lvar-dest (ref-lvar var-ref))))
+                               (unless (and (combination-p dest) (recurse dest))
+                                 (return-from combination-args-flow-cleanly-p nil)))))))))))
+    (recurse combination1)))
+
+(defun trivial-lambda-var-ref-p (use)
+  (and (ref-p use)
+       (let ((var (ref-leaf use)))
+         ;; lambda-var, no SETS
+         (when (and (lambda-var-p var) (not (lambda-var-sets var)))
+           (let ((home (lambda-var-home var))
+                 (refs (lambda-var-refs var)))
+             ;; bound by a system lambda, no other REFS
+             (when (and (lambda-system-lambda-p home)
+                        (eq use (car refs)) (not (cdr refs)))
+               ;; the LAMBDA this var is bound by has only a single REF, going
+               ;; to a combination
+               (let* ((lambda-refs (lambda-refs home))
+                      (primary (car lambda-refs)))
+                 (and (ref-p primary)
+                      (not (cdr lambda-refs))
+                      (combination-p (lvar-dest (ref-lvar primary)))))))))))
+
+(defun trivial-lambda-var-ref-lvar (use)
+  (let* ((this (ref-leaf use))
+         (home (lambda-var-home this)))
+    (multiple-value-bind (fun vars)
+        (values home (lambda-vars home))
+      (let* ((combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
+             (args (combination-args combination)))
+        (assert (= (length vars) (length args)))
+        (loop for var in vars
+              for arg in args
+              when (eq var this)
+              return arg)))))
+
+(declaim (inline block-to-be-deleted-p))
+(defun block-to-be-deleted-p (block)
+  (or (block-delete-p block)
+      (eq (functional-kind (block-home-lambda block)) :deleted)))
+
+;;; Checks whether NODE is in a block to be deleted
+(declaim (inline node-to-be-deleted-p))
+(defun node-to-be-deleted-p (node)
+  (block-to-be-deleted-p (node-block node)))
+

 (declaim (ftype (sfunction (clambda) cblock) lambda-block))
 (defun lambda-block (clambda)
   (node-block (lambda-bind clambda)))
 (declaim (ftype (sfunction (clambda) cblock) lambda-block))
 (defun lambda-block (clambda)
   (node-block (lambda-bind clambda)))

@@ -360,25 +546,25 @@
       ;;   1. It can fail in a few cases even when a meaningful home
       ;;      lambda exists, e.g. in IR1-CONVERT of one of the legs of
       ;;      an IF.
       ;;   1. It can fail in a few cases even when a meaningful home
       ;;      lambda exists, e.g. in IR1-CONVERT of one of the legs of
       ;;      an IF.

-      ;;   2. It can fail when converting a form which is born orphaned 
+      ;;   2. It can fail when converting a form which is born orphaned

       ;;      so that it never had a meaningful home lambda, e.g. a form
       ;;      which follows a RETURN-FROM or GO form.
       (let ((pred-list (block-pred block)))
       ;;      so that it never had a meaningful home lambda, e.g. a form
       ;;      which follows a RETURN-FROM or GO form.
       (let ((pred-list (block-pred block)))

-       ;; To deal with case 1, we reason that
-       ;; previous-in-target-execution-order blocks should be in the
-       ;; same lambda, and that they seem in practice to be
-       ;; previous-in-compilation-order blocks too, so we look back
-       ;; to find one which is sufficiently initialized to tell us
-       ;; what the home lambda is.
-       (if pred-list
-           ;; We could get fancy about this, flooding through the
-           ;; graph of all the previous blocks, but in practice it
-           ;; seems to work just to grab the first previous block and
-           ;; use it.
-           (node-home-lambda (block-last (first pred-list)))
-           ;; In case 2, we end up with an empty PRED-LIST and
-           ;; have to punt: There's no home lambda.
-           nil))))
+        ;; To deal with case 1, we reason that
+        ;; previous-in-target-execution-order blocks should be in the
+        ;; same lambda, and that they seem in practice to be
+        ;; previous-in-compilation-order blocks too, so we look back
+        ;; to find one which is sufficiently initialized to tell us
+        ;; what the home lambda is.
+        (if pred-list
+            ;; We could get fancy about this, flooding through the
+            ;; graph of all the previous blocks, but in practice it
+            ;; seems to work just to grab the first previous block and
+            ;; use it.
+            (node-home-lambda (block-last (first pred-list)))
+            ;; In case 2, we end up with an empty PRED-LIST and
+            ;; have to punt: There's no home lambda.
+            nil))))

 
 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
 (declaim (ftype (sfunction (cblock) clambda) block-home-lambda))
 
 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
 (declaim (ftype (sfunction (cblock) clambda) block-home-lambda))

@@ -419,18 +605,18 @@
 (defun node-source-form (node)
   (declare (type node node))
   (let* ((path (node-source-path node))
 (defun node-source-form (node)
   (declare (type node node))
   (let* ((path (node-source-path node))

-        (forms (source-path-forms path)))
+         (forms (source-path-forms path)))

     (if forms
     (if forms

-       (first forms)
-       (values (find-original-source path)))))
+        (first forms)
+        (values (find-original-source path)))))

 
 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
 ;;; NIL, NIL.
 (defun lvar-source (lvar)
   (let ((use (lvar-uses lvar)))
     (if (listp use)
 
 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
 ;;; NIL, NIL.
 (defun lvar-source (lvar)
   (let ((use (lvar-uses lvar)))
     (if (listp use)

-       (values nil nil)
-       (values (node-source-form use) t))))
+        (values nil nil)
+        (values (node-source-form use) t))))

 
 ;;; Return the unique node, delivering a value to LVAR.
 #!-sb-fluid (declaim (inline lvar-use))
 
 ;;; Return the unique node, delivering a value to LVAR.
 #!-sb-fluid (declaim (inline lvar-use))

@@ -455,17 +641,21 @@
   ;; approach fails, and furthermore realize that in some exceptional
   ;; cases it might return NIL. -- WHN 2001-12-04
   (cond ((ctran-use ctran)
   ;; approach fails, and furthermore realize that in some exceptional
   ;; cases it might return NIL. -- WHN 2001-12-04
   (cond ((ctran-use ctran)

-        (node-home-lambda (ctran-use ctran)))
-       ((ctran-block ctran)
-        (block-home-lambda-or-null (ctran-block ctran)))
-       (t
-        (bug "confused about home lambda for ~S" ctran))))
+         (node-home-lambda (ctran-use ctran)))
+        ((ctran-block ctran)
+         (block-home-lambda-or-null (ctran-block ctran)))
+        (t
+         (bug "confused about home lambda for ~S" ctran))))

 
 ;;; Return the LAMBDA that is CTRAN's home.
 (declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda))
 (defun ctran-home-lambda (ctran)
   (ctran-home-lambda-or-null ctran))
 
 
 ;;; Return the LAMBDA that is CTRAN's home.
 (declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda))
 (defun ctran-home-lambda (ctran)
   (ctran-home-lambda-or-null ctran))
 

+(declaim (inline cast-single-value-p))
+(defun cast-single-value-p (cast)
+  (not (values-type-p (cast-asserted-type cast))))
+

 #!-sb-fluid (declaim (inline lvar-single-value-p))
 (defun lvar-single-value-p (lvar)
   (or (not lvar)
 #!-sb-fluid (declaim (inline lvar-single-value-p))
 (defun lvar-single-value-p (lvar)
   (or (not lvar)

@@ -478,7 +668,7 @@
           (cast
            (locally
                (declare (notinline lvar-single-value-p))
           (cast
            (locally
                (declare (notinline lvar-single-value-p))

-             (and (not (values-type-p (cast-asserted-type dest)))
+             (and (cast-single-value-p dest)

                   (lvar-single-value-p (node-lvar dest)))))
           (t
            t)))))
                   (lvar-single-value-p (node-lvar dest)))))
           (t
            t)))))

@@ -502,23 +692,27 @@
 ;;; 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*)
 ;;; 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
+                         funs vars blocks tags

                          type-restrictions
                          type-restrictions

-                        (lambda (lexenv-lambda default))
-                        (cleanup (lexenv-cleanup default))
-                        (policy (lexenv-policy default)))
+                         (lambda (lexenv-lambda default))
+                         (cleanup (lexenv-cleanup default))
+                         (handled-conditions (lexenv-handled-conditions default))
+                         (disabled-package-locks
+                          (lexenv-disabled-package-locks default))
+                         (policy (lexenv-policy default)))

   (macrolet ((frob (var slot)
   (macrolet ((frob (var slot)

-              `(let ((old (,slot default)))
-                 (if ,var
-                     (nconc ,var old)
-                     old))))
+               `(let ((old (,slot default)))
+                  (if ,var
+                      (nconc ,var old)
+                      old))))

     (internal-make-lexenv
      (frob funs lexenv-funs)
      (frob vars lexenv-vars)
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
     (internal-make-lexenv
      (frob funs lexenv-funs)
      (frob vars lexenv-vars)
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)

-     lambda cleanup policy)))
+     lambda cleanup handled-conditions
+     disabled-package-locks policy)))

 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
 ;;; macroexpander
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
 ;;; macroexpander

@@ -535,7 +729,10 @@
            (destructuring-bind (name . thing) var
              (declare (ignore name))
              (etypecase thing
            (destructuring-bind (name . thing) var
              (declare (ignore name))
              (etypecase thing

-               (leaf nil)
+               ;; The evaluator will mark lexicals with :BOGUS when it
+               ;; translates an interpreter lexenv to a compiler
+               ;; lexenv.
+               ((or leaf #!+sb-eval (member :bogus)) nil)

                (cons (aver (eq (car thing) 'macro))
                      t)
                (heap-alien-info nil)))))
                (cons (aver (eq (car thing) 'macro))
                      t)
                (heap-alien-info nil)))))

@@ -547,6 +744,8 @@
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil

+     (lexenv-handled-conditions lexenv)
+     (lexenv-disabled-package-locks lexenv)

      (lexenv-policy lexenv))))
 \f
 ;;;; flow/DFO/component hackery
      (lexenv-policy lexenv))))
 \f
 ;;;; flow/DFO/component hackery

@@ -555,9 +754,9 @@
 (defun link-blocks (block1 block2)
   (declare (type cblock block1 block2))
   (setf (block-succ block1)
 (defun link-blocks (block1 block2)
   (declare (type cblock block1 block2))
   (setf (block-succ block1)

-       (if (block-succ block1)
-           (%link-blocks block1 block2)
-           (list block2)))
+        (if (block-succ block1)
+            (%link-blocks block1 block2)
+            (list block2)))

   (push block1 (block-pred block2))
   (values))
 (defun %link-blocks (block1 block2)
   (push block1 (block-pred block2))
   (values))
 (defun %link-blocks (block1 block2)

@@ -574,19 +773,19 @@
   (declare (type cblock block1 block2))
   (let ((succ1 (block-succ block1)))
     (if (eq block2 (car succ1))
   (declare (type cblock block1 block2))
   (let ((succ1 (block-succ block1)))
     (if (eq block2 (car succ1))

-       (setf (block-succ block1) (cdr succ1))
-       (do ((succ (cdr succ1) (cdr succ))
-            (prev succ1 succ))
-           ((eq (car succ) block2)
-            (setf (cdr prev) (cdr succ)))
-         (aver succ))))
+        (setf (block-succ block1) (cdr succ1))
+        (do ((succ (cdr succ1) (cdr succ))
+             (prev succ1 succ))
+            ((eq (car succ) block2)
+             (setf (cdr prev) (cdr succ)))
+          (aver succ))))

 
   (let ((new-pred (delq block1 (block-pred block2))))
     (setf (block-pred block2) new-pred)
     (when (singleton-p new-pred)
       (let ((pred-block (first new-pred)))
 
   (let ((new-pred (delq block1 (block-pred block2))))
     (setf (block-pred block2) new-pred)
     (when (singleton-p new-pred)
       (let ((pred-block (first new-pred)))

-       (when (if-p (block-last pred-block))
-         (setf (block-test-modified pred-block) t)))))
+        (when (if-p (block-last pred-block))
+          (setf (block-test-modified pred-block) t)))))

   (values))
 
 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
   (values))
 
 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK

@@ -598,29 +797,29 @@
   (declare (type cblock new old block))
   (unlink-blocks block old)
   (let ((last (block-last block))
   (declare (type cblock new old block))
   (unlink-blocks block old)
   (let ((last (block-last block))

-       (comp (block-component block)))
+        (comp (block-component block)))

     (setf (component-reanalyze comp) t)
     (typecase last
       (cif
        (setf (block-test-modified block) t)
        (let* ((succ-left (block-succ block))
     (setf (component-reanalyze comp) t)
     (typecase last
       (cif
        (setf (block-test-modified block) t)
        (let* ((succ-left (block-succ block))

-             (new (if (and (eq new (component-tail comp))
-                           succ-left)
-                      (first succ-left)
-                      new)))
-        (unless (memq new succ-left)
-          (link-blocks block new))
-        (macrolet ((frob (slot)
-                     `(when (eq (,slot last) old)
-                        (setf (,slot last) new))))
-          (frob if-consequent)
-          (frob if-alternative)
+              (new (if (and (eq new (component-tail comp))
+                            succ-left)
+                       (first succ-left)
+                       new)))
+         (unless (memq new succ-left)
+           (link-blocks block new))
+         (macrolet ((frob (slot)
+                      `(when (eq (,slot last) old)
+                         (setf (,slot last) new))))
+           (frob if-consequent)
+           (frob if-alternative)

            (when (eq (if-consequent last)
                      (if-alternative last))
            (when (eq (if-consequent last)
                      (if-alternative last))

-             (setf (component-reoptimize (block-component block)) t)))))
+             (reoptimize-component (block-component block) :maybe)))))

       (t
        (unless (memq new (block-succ block))
       (t
        (unless (memq new (block-succ block))

-        (link-blocks block new)))))
+         (link-blocks block new)))))

 
   (values))
 
 
   (values))
 

@@ -629,7 +828,7 @@
 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo))
 (defun remove-from-dfo (block)
   (let ((next (block-next block))
 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo))
 (defun remove-from-dfo (block)
   (let ((next (block-next block))

-       (prev (block-prev block)))
+        (prev (block-prev block)))

     (setf (block-component block) nil)
     (setf (block-next prev) next)
     (setf (block-prev next) prev))
     (setf (block-component block) nil)
     (setf (block-next prev) next)
     (setf (block-prev next) prev))

@@ -640,7 +839,7 @@
 (defun add-to-dfo (block after)
   (declare (type cblock block after))
   (let ((next (block-next after))
 (defun add-to-dfo (block after)
   (declare (type cblock block after))
   (let ((next (block-next after))

-       (comp (block-component after)))
+        (comp (block-component after)))

     (aver (not (eq (component-kind comp) :deleted)))
     (setf (block-component block) comp)
     (setf (block-next after) block)
     (aver (not (eq (component-kind comp) :deleted)))
     (setf (block-component block) comp)
     (setf (block-next after) block)

@@ -649,12 +848,39 @@
     (setf (block-prev next) block))
   (values))
 
     (setf (block-prev next) block))
   (values))
 

+;;; List all NLX-INFOs which BLOCK can exit to.
+;;;
+;;; We hope that no cleanup actions are performed in the middle of
+;;; BLOCK, so it is enough to look only at cleanups in the block
+;;; end. The tricky thing is a special cleanup block; all its nodes
+;;; have the same cleanup info, corresponding to the start, so the
+;;; same approach returns safe result.
+(defun map-block-nlxes (fun block &optional dx-cleanup-fun)
+  (loop for cleanup = (block-end-cleanup block)
+        then (node-enclosing-cleanup (cleanup-mess-up cleanup))
+        while cleanup
+        do (let ((mess-up (cleanup-mess-up cleanup)))
+             (case (cleanup-kind cleanup)
+               ((:block :tagbody)
+                (aver (entry-p mess-up))
+                (loop for exit in (entry-exits mess-up)
+                      for nlx-info = (exit-nlx-info exit)
+                      do (funcall fun nlx-info)))
+               ((:catch :unwind-protect)
+                (aver (combination-p mess-up))
+                (let* ((arg-lvar (first (basic-combination-args mess-up)))
+                       (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
+                (funcall fun nlx-info)))
+               ((:dynamic-extent)
+                (when dx-cleanup-fun
+                  (funcall dx-cleanup-fun cleanup)))))))
+

 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
 (declaim (ftype (sfunction (component) (values)) clear-flags))
 (defun clear-flags (component)
   (let ((head (component-head component))
 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
 (declaim (ftype (sfunction (component) (values)) clear-flags))
 (defun clear-flags (component)
   (let ((head (component-head component))

-       (tail (component-tail component)))
+        (tail (component-tail component)))

     (setf (block-flag head) t)
     (setf (block-flag tail) t)
     (do-blocks (block component)
     (setf (block-flag head) t)
     (setf (block-flag tail) t)
     (do-blocks (block component)

@@ -666,8 +892,8 @@
 (declaim (ftype (sfunction () component) make-empty-component))
 (defun make-empty-component ()
   (let* ((head (make-block-key :start nil :component nil))
 (declaim (ftype (sfunction () component) make-empty-component))
 (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 tail)))
+         (tail (make-block-key :start nil :component nil))
+         (res (make-component head tail)))

     (setf (block-flag head) t)
     (setf (block-flag tail) t)
     (setf (block-component head) res)
     (setf (block-flag head) t)
     (setf (block-flag tail) t)
     (setf (block-component head) res)

@@ -681,34 +907,35 @@
 (defun node-ends-block (node)
   (declare (type node node))
   (let* ((block (node-block node))
 (defun node-ends-block (node)
   (declare (type node node))
   (let* ((block (node-block node))

-        (start (node-next node))
-        (last (block-last block)))
+         (start (node-next node))
+         (last (block-last block)))
+    (check-type last node)

     (unless (eq last node)
       (aver (and (eq (ctran-kind start) :inside-block)
                  (not (block-delete-p block))))
       (let* ((succ (block-succ block))
     (unless (eq last node)
       (aver (and (eq (ctran-kind start) :inside-block)
                  (not (block-delete-p block))))
       (let* ((succ (block-succ block))

-            (new-block
-             (make-block-key :start start
-                             :component (block-component block)
-                             :succ succ :last last)))
-       (setf (ctran-kind start) :block-start)
+             (new-block
+              (make-block-key :start start
+                              :component (block-component block)
+                              :succ succ :last last)))
+        (setf (ctran-kind start) :block-start)

         (setf (ctran-use start) nil)
         (setf (ctran-use start) nil)

-       (setf (block-last block) node)
+        (setf (block-last block) node)

         (setf (node-next node) nil)
         (setf (node-next node) nil)

-       (dolist (b succ)
-         (setf (block-pred b)
-               (cons new-block (remove block (block-pred b)))))
-       (setf (block-succ block) ())
-       (link-blocks block new-block)
-       (add-to-dfo new-block block)
-       (setf (component-reanalyze (block-component block)) t)
-
-       (do ((ctran start (node-next (ctran-next ctran))))
-           ((not ctran))
-         (setf (ctran-block ctran) new-block))
-
-       (setf (block-type-asserted block) t)
-       (setf (block-test-modified block) t))))
+        (dolist (b succ)
+          (setf (block-pred b)
+                (cons new-block (remove block (block-pred b)))))
+        (setf (block-succ block) ())
+        (link-blocks block new-block)
+        (add-to-dfo new-block block)
+        (setf (component-reanalyze (block-component block)) t)
+
+        (do ((ctran start (node-next (ctran-next ctran))))
+            ((not ctran))
+          (setf (ctran-block ctran) new-block))
+
+        (setf (block-type-asserted block) t)
+        (setf (block-test-modified block) t))))

   (values))
 \f
 ;;;; deleting stuff
   (values))
 \f
 ;;;; deleting stuff

@@ -722,18 +949,18 @@
   ;; mark the LET for reoptimization, since it may be that we have
   ;; deleted its last variable.
   (let* ((fun (lambda-var-home leaf))
   ;; mark the LET for reoptimization, since it may be that we have
   ;; deleted its last variable.
   (let* ((fun (lambda-var-home leaf))

-        (n (position leaf (lambda-vars fun))))
+         (n (position leaf (lambda-vars fun))))

     (dolist (ref (leaf-refs fun))
       (let* ((lvar (node-lvar ref))
     (dolist (ref (leaf-refs fun))
       (let* ((lvar (node-lvar ref))

-            (dest (and lvar (lvar-dest lvar))))
-       (when (and (combination-p dest)
-                  (eq (basic-combination-fun dest) lvar)
-                  (eq (basic-combination-kind dest) :local))
-         (let* ((args (basic-combination-args dest))
-                (arg (elt args n)))
-           (reoptimize-lvar arg)
-           (flush-dest arg)
-           (setf (elt args n) nil))))))
+             (dest (and lvar (lvar-dest lvar))))
+        (when (and (combination-p dest)
+                   (eq (basic-combination-fun dest) lvar)
+                   (eq (basic-combination-kind dest) :local))
+          (let* ((args (basic-combination-args dest))
+                 (arg (elt args n)))
+            (reoptimize-lvar arg)
+            (flush-dest arg)
+            (setf (elt args n) nil))))))

 
   ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
   ;; too much difficulty, since we can efficiently implement
 
   ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
   ;; too much difficulty, since we can efficiently implement

@@ -752,13 +979,13 @@
     ;; We only deal with LET variables, marking the corresponding
     ;; initial value arg as needing to be reoptimized.
     (when (and (eq (functional-kind fun) :let)
     ;; We only deal with LET variables, marking the corresponding
     ;; initial value arg as needing to be reoptimized.
     (when (and (eq (functional-kind fun) :let)

-              (leaf-refs var))
+               (leaf-refs var))

       (do ((args (basic-combination-args
       (do ((args (basic-combination-args

-                 (lvar-dest (node-lvar (first (leaf-refs fun)))))
-                (cdr args))
-          (vars (lambda-vars fun) (cdr vars)))
-         ((eq (car vars) var)
-          (reoptimize-lvar (car args))))))
+                  (lvar-dest (node-lvar (first (leaf-refs fun)))))
+                 (cdr args))
+           (vars (lambda-vars fun) (cdr vars)))
+          ((eq (car vars) var)
+           (reoptimize-lvar (car args))))))

   (values))
 
 ;;; Delete a function that has no references. This need only be called
   (values))
 
 ;;; Delete a function that has no references. This need only be called

@@ -766,89 +993,95 @@
 ;;; DELETE-REF will handle the deletion.
 (defun delete-functional (fun)
   (aver (and (null (leaf-refs fun))
 ;;; DELETE-REF will handle the deletion.
 (defun delete-functional (fun)
   (aver (and (null (leaf-refs fun))

-            (not (functional-entry-fun fun))))
+             (not (functional-entry-fun fun))))

   (etypecase fun
     (optional-dispatch (delete-optional-dispatch fun))
     (clambda (delete-lambda fun)))
   (values))
 
   (etypecase fun
     (optional-dispatch (delete-optional-dispatch fun))
     (clambda (delete-lambda fun)))
   (values))
 

-;;; Deal with deleting the last reference to a CLAMBDA. It is called
-;;; in two situations: when the lambda is unreachable (so that its
-;;; body may be deleted), and when it is an effectless LET (in this
-;;; case its body is reachable and is not completely "its"). We set
-;;; FUNCTIONAL-KIND to :DELETED and rely on IR1-OPTIMIZE to delete its
-;;; blocks.
+;;; Deal with deleting the last reference to a CLAMBDA, which means
+;;; that the lambda is unreachable, so that its body may be
+;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
+;;; IR1-OPTIMIZE to delete its blocks.

 (defun delete-lambda (clambda)
   (declare (type clambda clambda))
   (let ((original-kind (functional-kind clambda))
 (defun delete-lambda (clambda)
   (declare (type clambda clambda))
   (let ((original-kind (functional-kind clambda))

-       (bind (lambda-bind clambda)))
+        (bind (lambda-bind clambda)))

     (aver (not (member original-kind '(:deleted :toplevel))))
     (aver (not (functional-has-external-references-p clambda)))
     (aver (not (member original-kind '(:deleted :toplevel))))
     (aver (not (functional-has-external-references-p clambda)))

+    (aver (or (eq original-kind :zombie) bind))

     (setf (functional-kind clambda) :deleted)
     (setf (lambda-bind clambda) nil)
 
     (setf (functional-kind clambda) :deleted)
     (setf (lambda-bind clambda) nil)
 

-    (when bind              ; CLAMBDA is deleted due to unreachability
-      (labels ((delete-children (lambda)
-                 (dolist (child (lambda-children lambda))
-                   (cond ((eq (functional-kind child) :deleted)
-                          (delete-children child))
-                         (t
-                          (delete-lambda child))))
-                 (setf (lambda-children lambda) nil)
-                 (setf (lambda-parent lambda) nil)))
-        (delete-children clambda)))
-    (dolist (let (lambda-lets clambda))
-      (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))))
+    (labels ((delete-children (lambda)
+               (dolist (child (lambda-children lambda))
+                 (cond ((eq (functional-kind child) :deleted)
+                        (delete-children child))
+                       (t
+                        (delete-lambda child))))
+               (setf (lambda-children lambda) nil)
+               (setf (lambda-parent lambda) nil)))
+      (delete-children clambda))

 
     ;; (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.)
 
     ;; (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.)

-    (if (member original-kind '(:let :mv-let :assignment))
-       (let ((home (lambda-home clambda)))
-         (setf (lambda-lets home) (delete clambda (lambda-lets home))))
-       ;; If the function isn't a LET, we unlink the function head
-       ;; and tail from the component head and tail to indicate that
-       ;; the code is unreachable. We also delete the function from
-       ;; COMPONENT-LAMBDAS (it won't be there before local call
-       ;; analysis, but no matter.) If the lambda was never
-       ;; referenced, we give a note.
-       (let* ((bind-block (node-block bind))
-              (component (block-component bind-block))
-              (return (lambda-return clambda))
-               (return-block (and return (node-block return))))
-         (unless (leaf-ever-used clambda)
-           (let ((*compiler-error-context* bind))
-             (compiler-notify 'code-deletion-note
-                              :format-control "deleting unused function~:[.~;~:*~%  ~S~]"
-                              :format-arguments (list (leaf-debug-name clambda)))))
-          (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)
-                 (delete clambda (tail-set-funs tails)))
-           (setf (lambda-tail-set clambda) nil))
-         (setf (component-lambdas component)
-               (delq clambda (component-lambdas component)))))
+    (case original-kind
+      (:zombie)
+      ((:let :mv-let :assignment)
+       (let ((bind-block (node-block bind)))
+         (mark-for-deletion bind-block))
+       (let ((home (lambda-home clambda)))
+         (setf (lambda-lets home) (delete clambda (lambda-lets home))))
+       ;; KLUDGE: In presence of NLEs we cannot always understand that
+       ;; LET's BIND dominates its body [for a LET "its" body is not
+       ;; quite its]; let's delete too dangerous for IR2 stuff. --
+       ;; APD, 2004-01-01
+       (dolist (var (lambda-vars clambda))
+         (flet ((delete-node (node)
+                  (mark-for-deletion (node-block node))))
+         (mapc #'delete-node (leaf-refs var))
+         (mapc #'delete-node (lambda-var-sets var)))))
+      (t
+       ;; Function has no reachable references.
+       (dolist (ref (lambda-refs clambda))
+         (mark-for-deletion (node-block ref)))
+       ;; If the function isn't a LET, we unlink the function head
+       ;; and tail from the component head and tail to indicate that
+       ;; the code is unreachable. We also delete the function from
+       ;; COMPONENT-LAMBDAS (it won't be there before local call
+       ;; analysis, but no matter.) If the lambda was never
+       ;; referenced, we give a note.
+       (let* ((bind-block (node-block bind))
+              (component (block-component bind-block))
+              (return (lambda-return clambda))
+              (return-block (and return (node-block return))))
+         (unless (leaf-ever-used clambda)
+           (let ((*compiler-error-context* bind))
+             (compiler-notify 'code-deletion-note
+                              :format-control "deleting unused function~:[.~;~:*~%  ~S~]"
+                              :format-arguments (list (leaf-debug-name clambda)))))
+         (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)
+                 (delete clambda (tail-set-funs tails)))
+           (setf (lambda-tail-set clambda) nil))
+         (setf (component-lambdas component)
+               (delq clambda (component-lambdas component))))))

 
     ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
     ;; ENTRY-FUN so that people will know that it is not an entry
     ;; point anymore.
     (when (eq original-kind :external)
       (let ((fun (functional-entry-fun clambda)))
 
     ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
     ;; ENTRY-FUN so that people will know that it is not an entry
     ;; point anymore.
     (when (eq original-kind :external)
       (let ((fun (functional-entry-fun clambda)))

-       (setf (functional-entry-fun fun) nil)
-       (when (optional-dispatch-p fun)
-         (delete-optional-dispatch fun)))))
+        (setf (functional-entry-fun fun) nil)
+        (when (optional-dispatch-p fun)
+          (delete-optional-dispatch fun)))))

 
   (values))
 
 
   (values))
 

@@ -878,61 +1111,83 @@
       (setf (functional-kind leaf) :deleted)
 
       (flet ((frob (fun)
       (setf (functional-kind leaf) :deleted)
 
       (flet ((frob (fun)

-              (unless (eq (functional-kind fun) :deleted)
-                (aver (eq (functional-kind fun) :optional))
-                (setf (functional-kind fun) nil)
-                (let ((refs (leaf-refs fun)))
-                  (cond ((null refs)
-                         (delete-lambda fun))
-                        ((null (rest refs))
-                         (or (maybe-let-convert fun)
-                             (maybe-convert-to-assignment fun)))
-                        (t
-                         (maybe-convert-to-assignment fun)))))))
-
-       (dolist (ep (optional-dispatch-entry-points leaf))
+               (unless (eq (functional-kind fun) :deleted)
+                 (aver (eq (functional-kind fun) :optional))
+                 (setf (functional-kind fun) nil)
+                 (let ((refs (leaf-refs fun)))
+                   (cond ((null refs)
+                          (delete-lambda fun))
+                         ((null (rest refs))
+                          (or (maybe-let-convert fun)
+                              (maybe-convert-to-assignment fun)))
+                         (t
+                          (maybe-convert-to-assignment fun)))))))
+
+        (dolist (ep (optional-dispatch-entry-points leaf))

           (when (promise-ready-p ep)
             (frob (force ep))))
           (when (promise-ready-p ep)
             (frob (force ep))))

-       (when (optional-dispatch-more-entry leaf)
-         (frob (optional-dispatch-more-entry leaf)))
-       (let ((main (optional-dispatch-main-entry leaf)))
-         (when (eq (functional-kind main) :optional)
-           (frob main))))))
+        (when (optional-dispatch-more-entry leaf)
+          (frob (optional-dispatch-more-entry leaf)))
+        (let ((main (optional-dispatch-main-entry leaf)))
+          (when entry
+            (setf (functional-entry-fun entry) main)
+            (setf (functional-entry-fun main) entry))
+          (when (eq (functional-kind main) :optional)
+            (frob main))))))

 
   (values))
 
 
   (values))
 

+(defun note-local-functional (fun)
+  (declare (type functional fun))
+  (when (and (leaf-has-source-name-p fun)
+             (eq (leaf-source-name fun) (functional-debug-name fun)))
+    (let ((name (leaf-source-name fun)))
+      (let ((defined-fun (gethash name *free-funs*)))
+        (when (and defined-fun
+                   (defined-fun-p defined-fun)
+                   (eq (defined-fun-functional defined-fun) fun))
+          (remhash name *free-funs*))))))
+
+;;; Return functional for DEFINED-FUN which has been converted in policy
+;;; corresponding to the current one, or NIL if no such functional exists.
+(defun defined-fun-functional (defined-fun)
+  (let ((policy (lexenv-%policy *lexenv*)))
+    (dolist (functional (defined-fun-functionals defined-fun))
+      (when (equal policy (lexenv-%policy (functional-lexenv functional)))
+        (return functional)))))
+

 ;;; Do stuff to delete the semantic attachments of a REF node. When
 ;;; this leaves zero or one reference, we do a type dispatch off of
 ;;; the leaf to determine if a special action is appropriate.
 (defun delete-ref (ref)
   (declare (type ref ref))
   (let* ((leaf (ref-leaf ref))
 ;;; Do stuff to delete the semantic attachments of a REF node. When
 ;;; this leaves zero or one reference, we do a type dispatch off of
 ;;; the leaf to determine if a special action is appropriate.
 (defun delete-ref (ref)
   (declare (type ref ref))
   (let* ((leaf (ref-leaf ref))

-        (refs (delq ref (leaf-refs leaf))))
+         (refs (delq ref (leaf-refs leaf))))

     (setf (leaf-refs leaf) refs)
 
     (cond ((null refs)
     (setf (leaf-refs leaf) refs)
 
     (cond ((null refs)

-          (typecase leaf
-            (lambda-var
-             (delete-lambda-var leaf))
-            (clambda
-             (ecase (functional-kind leaf)
-               ((nil :let :mv-let :assignment :escape :cleanup)
-                (aver (null (functional-entry-fun leaf)))
-                (delete-lambda leaf))
-               (:external
-                (delete-lambda leaf))
-               ((:deleted :optional))))
-            (optional-dispatch
-             (unless (eq (functional-kind leaf) :deleted)
-               (delete-optional-dispatch leaf)))))
-         ((null (rest refs))
-          (typecase leaf
-            (clambda (or (maybe-let-convert leaf)
-                         (maybe-convert-to-assignment leaf)))
-            (lambda-var (reoptimize-lambda-var leaf))))
-         (t
-          (typecase leaf
-            (clambda (maybe-convert-to-assignment leaf))))))
+           (typecase leaf
+             (lambda-var
+              (delete-lambda-var leaf))
+             (clambda
+              (ecase (functional-kind leaf)
+                ((nil :let :mv-let :assignment :escape :cleanup)
+                 (aver (null (functional-entry-fun leaf)))
+                 (delete-lambda leaf))
+                (:external
+                 (delete-lambda leaf))
+                ((:deleted :zombie :optional))))
+             (optional-dispatch
+              (unless (eq (functional-kind leaf) :deleted)
+                (delete-optional-dispatch leaf)))))
+          ((null (rest refs))
+           (typecase leaf
+             (clambda (or (maybe-let-convert leaf)
+                          (maybe-convert-to-assignment leaf)))
+             (lambda-var (reoptimize-lambda-var leaf))))
+          (t
+           (typecase leaf
+             (clambda (maybe-convert-to-assignment leaf))))))

 
   (values))
 
 
   (values))
 

@@ -947,9 +1202,10 @@
     (flush-lvar-externally-checkable-type lvar)
     (do-uses (use lvar)
       (let ((prev (node-prev use)))
     (flush-lvar-externally-checkable-type lvar)
     (do-uses (use lvar)
       (let ((prev (node-prev use)))

-       (let ((block (ctran-block prev)))
-          (setf (component-reoptimize (block-component block)) t)
-          (setf (block-attributep (block-flags block) flush-p type-asserted)
+        (let ((block (ctran-block prev)))
+          (reoptimize-component (block-component block) t)
+          (setf (block-attributep (block-flags block)
+                                  flush-p type-asserted type-check)

                 t)))
       (setf (node-lvar use) nil))
     (setf (lvar-uses lvar) nil))
                 t)))
       (setf (node-lvar use) nil))
     (setf (lvar-uses lvar) nil))

@@ -963,6 +1219,13 @@
         (unless (block-delete-p block)
           (mark-for-deletion block))))))
 
         (unless (block-delete-p block)
           (mark-for-deletion block))))))
 

+;;; Queue the block for deletion
+(defun delete-block-lazily (block)
+  (declare (type cblock block))
+  (unless (block-delete-p block)
+    (setf (block-delete-p block) t)
+    (push block (component-delete-blocks (block-component block)))))
+

 ;;; Do a graph walk backward from BLOCK, marking all predecessor
 ;;; blocks with the DELETE-P flag.
 (defun mark-for-deletion (block)
 ;;; Do a graph walk backward from BLOCK, marking all predecessor
 ;;; blocks with the DELETE-P flag.
 (defun mark-for-deletion (block)

@@ -970,7 +1233,7 @@
   (let* ((component (block-component block))
          (head (component-head component)))
     (labels ((helper (block)
   (let* ((component (block-component block))
          (head (component-head component)))
     (labels ((helper (block)

-               (setf (block-delete-p block) t)
+               (delete-block-lazily block)

                (dolist (pred (block-pred block))
                  (unless (or (block-delete-p pred)
                              (eq pred head))
                (dolist (pred (block-pred block))
                  (unless (or (block-delete-p pred)
                              (eq pred head))

@@ -983,10 +1246,12 @@
 ;;; This function does what is necessary to eliminate the code in it
 ;;; from the IR1 representation. This involves unlinking it from its
 ;;; predecessors and successors and deleting various node-specific
 ;;; This function does what is necessary to eliminate the code in it
 ;;; from the IR1 representation. This involves unlinking it from its
 ;;; predecessors and successors and deleting various node-specific

-;;; semantic information.
+;;; semantic information. BLOCK must be already removed from
+;;; COMPONENT-DELETE-BLOCKS.

 (defun delete-block (block &optional silent)
   (declare (type cblock block))
   (aver (block-component block))      ; else block is already deleted!
 (defun delete-block (block &optional silent)
   (declare (type cblock block))
   (aver (block-component block))      ; else block is already deleted!

+  #!+high-security (aver (not (memq block (component-delete-blocks (block-component block)))))

   (unless silent
     (note-block-deletion block))
   (setf (block-delete-p block) t)
   (unless silent
     (note-block-deletion block))
   (setf (block-delete-p block) t)

@@ -1076,14 +1341,20 @@
   (declare (type clambda fun))
   (dolist (var (lambda-vars fun))
     (unless (or (leaf-ever-used var)
   (declare (type clambda fun))
   (dolist (var (lambda-vars fun))
     (unless (or (leaf-ever-used var)

-               (lambda-var-ignorep var))
+                (lambda-var-ignorep var))

       (let ((*compiler-error-context* (lambda-bind fun)))
       (let ((*compiler-error-context* (lambda-bind fun)))

-       (unless (policy *compiler-error-context* (= inhibit-warnings 3))
-         ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
-         ;; requires this to be no more than a STYLE-WARNING.
-         (compiler-style-warn "The variable ~S is defined but never used."
-                              (leaf-debug-name var)))
-       (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
+        (unless (policy *compiler-error-context* (= inhibit-warnings 3))
+          ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
+          ;; requires this to be no more than a STYLE-WARNING.
+          #-sb-xc-host
+          (compiler-style-warn "The variable ~S is defined but never used."
+                               (leaf-debug-name var))
+          ;; There's no reason to accept this kind of equivocation
+          ;; when compiling our own code, though.
+          #+sb-xc-host
+          (warn "The variable ~S is defined but never used."
+                (leaf-debug-name var)))
+        (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN

   (values))
 
 (defvar *deletion-ignored-objects* '(t nil))
   (values))
 
 (defvar *deletion-ignored-objects* '(t nil))

@@ -1096,22 +1367,22 @@
 (defun present-in-form (obj form depth)
   (declare (type (integer 0 20) depth))
   (cond ((= depth 20) nil)
 (defun present-in-form (obj form depth)
   (declare (type (integer 0 20) depth))
   (cond ((= depth 20) nil)

-       ((eq obj form) t)
-       ((atom form) nil)
-       (t
-        (let ((first (car form))
-              (depth (1+ depth)))
-          (if (member first '(quote function))
-              nil
-              (or (and (not (symbolp first))
-                       (present-in-form obj first depth))
-                  (do ((l (cdr form) (cdr l))
-                       (n 0 (1+ n)))
-                      ((or (atom l) (> n 100))
-                       nil)
-                    (declare (fixnum n))
-                    (when (present-in-form obj (car l) depth)
-                      (return t)))))))))
+        ((eq obj form) t)
+        ((atom form) nil)
+        (t
+         (let ((first (car form))
+               (depth (1+ depth)))
+           (if (member first '(quote function))
+               nil
+               (or (and (not (symbolp first))
+                        (present-in-form obj first depth))
+                   (do ((l (cdr form) (cdr l))
+                        (n 0 (1+ n)))
+                       ((or (atom l) (> n 100))
+                        nil)
+                     (declare (fixnum n))
+                     (when (present-in-form obj (car l) depth)
+                       (return t)))))))))

 
 ;;; This function is called on a block immediately before we delete
 ;;; it. We check to see whether any of the code about to die appeared
 
 ;;; This function is called on a block immediately before we delete
 ;;; it. We check to see whether any of the code about to die appeared

@@ -1135,27 +1406,27 @@
   (let ((home (block-home-lambda block)))
     (unless (eq (functional-kind home) :deleted)
       (do-nodes (node nil block)
   (let ((home (block-home-lambda block)))
     (unless (eq (functional-kind home) :deleted)
       (do-nodes (node nil block)

-       (let* ((path (node-source-path node))
-              (first (first path)))
-         (when (or (eq first 'original-source-start)
-                   (and (atom first)
-                        (or (not (symbolp first))
-                            (let ((pkg (symbol-package first)))
-                              (and pkg
-                                   (not (eq pkg (symbol-package :end))))))
-                        (not (member first *deletion-ignored-objects*))
-                        (not (typep first '(or fixnum character)))
-                        (every (lambda (x)
-                                 (present-in-form first x 0))
-                               (source-path-forms path))
-                        (present-in-form first (find-original-source path)
-                                         0)))
-           (unless (return-p node)
-             (let ((*compiler-error-context* node))
-               (compiler-notify 'code-deletion-note
-                                :format-control "deleting unreachable code"
-                                :format-arguments nil)))
-           (return))))))
+        (let* ((path (node-source-path node))
+               (first (first path)))
+          (when (or (eq first 'original-source-start)
+                    (and (atom first)
+                         (or (not (symbolp first))
+                             (let ((pkg (symbol-package first)))
+                               (and pkg
+                                    (not (eq pkg (symbol-package :end))))))
+                         (not (member first *deletion-ignored-objects*))
+                         (not (typep first '(or fixnum character)))
+                         (every (lambda (x)
+                                  (present-in-form first x 0))
+                                (source-path-forms path))
+                         (present-in-form first (find-original-source path)
+                                          0)))
+            (unless (return-p node)
+              (let ((*compiler-error-context* node))
+                (compiler-notify 'code-deletion-note
+                                 :format-control "deleting unreachable code"
+                                 :format-arguments nil)))
+            (return))))))

   (values))
 
 ;;; Delete a node from a block, deleting the block if there are no
   (values))
 
 ;;; Delete a node from a block, deleting the block if there are no

@@ -1174,63 +1445,73 @@
     (delete-lvar-use node))
 
   (let* ((ctran (node-next node))
     (delete-lvar-use node))
 
   (let* ((ctran (node-next node))

-        (next (and ctran (ctran-next ctran)))
-        (prev (node-prev node))
-        (block (ctran-block prev))
-        (prev-kind (ctran-kind prev))
-        (last (block-last block)))
+         (next (and ctran (ctran-next ctran)))
+         (prev (node-prev node))
+         (block (ctran-block prev))
+         (prev-kind (ctran-kind prev))
+         (last (block-last block)))

 
     (setf (block-type-asserted block) t)
     (setf (block-test-modified block) t)
 
     (cond ((or (eq prev-kind :inside-block)
 
     (setf (block-type-asserted block) t)
     (setf (block-test-modified block) t)
 
     (cond ((or (eq prev-kind :inside-block)

-              (and (eq prev-kind :block-start)
-                   (not (eq node last))))
-          (cond ((eq node last)
-                 (setf (block-last block) (ctran-use prev))
-                 (setf (node-next (ctran-use prev)) nil))
-                (t
-                 (setf (ctran-next prev) next)
-                 (setf (node-prev next) prev)
+               (and (eq prev-kind :block-start)
+                    (not (eq node last))))
+           (cond ((eq node last)
+                  (setf (block-last block) (ctran-use prev))
+                  (setf (node-next (ctran-use prev)) nil))
+                 (t
+                  (setf (ctran-next prev) next)
+                  (setf (node-prev next) prev)

                   (when (if-p next) ; AOP wanted
                     (reoptimize-lvar (if-test next)))))
                   (when (if-p next) ; AOP wanted
                     (reoptimize-lvar (if-test next)))))

-          (setf (node-prev node) nil)
-          nil)
-         (t
-          (aver (eq prev-kind :block-start))
-          (aver (eq node last))
-          (let* ((succ (block-succ block))
-                 (next (first succ)))
-            (aver (singleton-p succ))
-            (cond
-             ((eq block (first succ))
-              (with-ir1-environment-from-node node
-                (let ((exit (make-exit)))
-                  (setf (ctran-next prev) nil)
-                  (link-node-to-previous-ctran exit prev)
-                  (setf (block-last block) exit)))
-              (setf (node-prev node) nil)
-              nil)
-             (t
-              (aver (eq (block-start-cleanup block)
-                        (block-end-cleanup block)))
-              (unlink-blocks block next)
-              (dolist (pred (block-pred block))
-                (change-block-successor pred block next))
-              (remove-from-dfo block)
+           (setf (node-prev node) nil)
+           nil)
+          (t
+           (aver (eq prev-kind :block-start))
+           (aver (eq node last))
+           (let* ((succ (block-succ block))
+                  (next (first succ)))
+             (aver (singleton-p succ))
+             (cond
+              ((eq block (first succ))
+               (with-ir1-environment-from-node node
+                 (let ((exit (make-exit)))
+                   (setf (ctran-next prev) nil)
+                   (link-node-to-previous-ctran exit prev)
+                   (setf (block-last block) exit)))
+               (setf (node-prev node) nil)
+               nil)
+              (t
+               (aver (eq (block-start-cleanup block)
+                         (block-end-cleanup block)))
+               (unlink-blocks block next)
+               (dolist (pred (block-pred block))
+                 (change-block-successor pred block next))
+               (when (block-delete-p block)
+                 (let ((component (block-component block)))
+                   (setf (component-delete-blocks component)
+                         (delq block (component-delete-blocks component)))))
+               (remove-from-dfo block)

                (setf (block-delete-p block) t)
                (setf (block-delete-p block) t)

-              (setf (node-prev node) nil)
-              t)))))))
+               (setf (node-prev node) nil)
+               t)))))))
+
+;;; Return true if CTRAN has been deleted, false if it is still a valid
+;;; part of IR1.
+(defun ctran-deleted-p (ctran)
+  (declare (type ctran ctran))
+  (let ((block (ctran-block ctran)))
+    (or (not (block-component block))
+        (block-delete-p block))))

 
 ;;; Return true if NODE has been deleted, false if it is still a valid
 ;;; part of IR1.
 (defun node-deleted (node)
   (declare (type node node))
   (let ((prev (node-prev node)))
 
 ;;; Return true if NODE has been deleted, false if it is still a valid
 ;;; part of IR1.
 (defun node-deleted (node)
   (declare (type node node))
   (let ((prev (node-prev node)))

-    (not (and prev
-             (let ((block (ctran-block prev)))
-               (and (block-component block)
-                    (not (block-delete-p block))))))))
+    (or (not prev)
+        (ctran-deleted-p prev))))

 
 ;;; Delete all the blocks and functions in COMPONENT. We scan first
 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
 
 ;;; Delete all the blocks and functions in COMPONENT. We scan first
 ;;; marking the blocks as DELETE-P to prevent weird stuff from being

@@ -1240,17 +1521,27 @@
   (aver (null (component-new-functionals component)))
   (setf (component-kind component) :deleted)
   (do-blocks (block component)
   (aver (null (component-new-functionals component)))
   (setf (component-kind component) :deleted)
   (do-blocks (block component)

-    (setf (block-delete-p block) t))
+    (delete-block-lazily block))

   (dolist (fun (component-lambdas component))
     (unless (eq (functional-kind fun) :deleted)
       (setf (functional-kind fun) nil)
       (setf (functional-entry-fun fun) nil)
       (setf (leaf-refs fun) nil)
       (delete-functional fun)))
   (dolist (fun (component-lambdas component))
     (unless (eq (functional-kind fun) :deleted)
       (setf (functional-kind fun) nil)
       (setf (functional-entry-fun fun) nil)
       (setf (leaf-refs fun) nil)
       (delete-functional fun)))

-  (do-blocks (block component)
-    (delete-block block))
+  (clean-component component)

   (values))
 
   (values))
 

+;;; Remove all pending blocks to be deleted. Return the nearest live
+;;; block after or equal to BLOCK.
+(defun clean-component (component &optional block)
+  (loop while (component-delete-blocks component)
+        ;; actual deletion of a block may queue new blocks
+        do (let ((current (pop (component-delete-blocks component))))
+             (when (eq block current)
+               (setq block (block-next block)))
+             (delete-block current)))
+  block)
+

 ;;; Convert code of the form
 ;;;   (FOO ... (FUN ...) ...)
 ;;; to
 ;;; Convert code of the form
 ;;;   (FOO ... (FUN ...) ...)
 ;;; to

@@ -1261,42 +1552,92 @@
 ;;; of arguments changes, the transform must be prepared to return a
 ;;; lambda with a new lambda-list with the correct number of
 ;;; arguments.
 ;;; of arguments changes, the transform must be prepared to return a
 ;;; lambda with a new lambda-list with the correct number of
 ;;; arguments.

-(defun extract-fun-args (lvar fun num-args)
+(defun splice-fun-args (lvar fun num-args)

   #!+sb-doc
   #!+sb-doc

-  "If LVAR is a call to FUN with NUM-ARGS args, change those arguments
-   to feed directly to the LVAR-DEST of LVAR, which must be a
-   combination."
+  "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
+directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
+is :ANY, the function name is not checked."

   (declare (type lvar lvar)
   (declare (type lvar lvar)

-          (type symbol fun)
-          (type index num-args))
+           (type symbol fun)
+           (type index num-args))

   (let ((outside (lvar-dest lvar))
   (let ((outside (lvar-dest lvar))

-       (inside (lvar-uses lvar)))
+        (inside (lvar-uses lvar)))

     (aver (combination-p outside))
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))
     (aver (combination-p outside))
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))

-      (unless (eq (lvar-fun-name inside-fun) fun)
-       (give-up-ir1-transform))
+      (unless (or (eq fun :any)
+                  (eq (lvar-fun-name inside-fun) fun))
+        (give-up-ir1-transform))

       (let ((inside-args (combination-args inside)))
       (let ((inside-args (combination-args inside)))

-       (unless (= (length inside-args) num-args)
-         (give-up-ir1-transform))
-       (let* ((outside-args (combination-args outside))
-              (arg-position (position lvar outside-args))
-              (before-args (subseq outside-args 0 arg-position))
-              (after-args (subseq outside-args (1+ arg-position))))
-         (dolist (arg inside-args)
-           (setf (lvar-dest arg) outside)
+        (unless (= (length inside-args) num-args)
+          (give-up-ir1-transform))
+        (let* ((outside-args (combination-args outside))
+               (arg-position (position lvar outside-args))
+               (before-args (subseq outside-args 0 arg-position))
+               (after-args (subseq outside-args (1+ arg-position))))
+          (dolist (arg inside-args)
+            (setf (lvar-dest arg) outside)

             (flush-lvar-externally-checkable-type arg))
             (flush-lvar-externally-checkable-type arg))

-         (setf (combination-args inside) nil)
-         (setf (combination-args outside)
-               (append before-args inside-args after-args))
-         (change-ref-leaf (lvar-uses inside-fun)
-                          (find-free-fun 'list "???"))
-         (setf (combination-kind inside)
-                (info :function :info 'list))
-         (setf (node-derived-type inside) *wild-type*)
-         (flush-dest lvar)
-         (values))))))
+          (setf (combination-args inside) nil)
+          (setf (combination-args outside)
+                (append before-args inside-args after-args))
+          (change-ref-leaf (lvar-uses inside-fun)
+                           (find-free-fun 'list "???"))
+          (setf (combination-fun-info inside) (info :function :info 'list)
+                (combination-kind inside) :known)
+          (setf (node-derived-type inside) *wild-type*)
+          (flush-dest lvar)
+          inside-args)))))
+
+;;; Eliminate keyword arguments from the call (leaving the
+;;; parameters in place.
+;;;
+;;;    (FOO ... :BAR X :QUUX Y)
+;;; becomes
+;;;    (FOO ... X Y)
+;;;
+;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
+;;; Returns the list of specified parameters names in the
+;;; order they appeared in the call. N-POSITIONAL is the
+;;; number of positional arguments in th call.
+(defun eliminate-keyword-args (call n-positional specs)
+  (let* ((specs (copy-tree specs))
+         (all (combination-args call))
+         (new-args (reverse (subseq all 0 n-positional)))
+         (key-args (subseq all n-positional))
+         (parameters nil))
+    (loop while key-args
+          do (let* ((key (pop key-args))
+                    (val (pop key-args))
+                    (keyword (if (constant-lvar-p key)
+                                 (lvar-value key)
+                                 (give-up-ir1-transform)))
+                    (spec (or (assoc keyword specs :test #'eq)
+                              (give-up-ir1-transform))))
+               (push val new-args)
+               (flush-dest key)
+               (push (second spec) parameters)
+               ;; In case of duplicate keys.
+               (setf (second spec) (gensym))))
+    (setf (combination-args call) (reverse new-args))
+    (reverse parameters)))
+
+(defun extract-fun-args (lvar fun num-args)
+  (declare (type lvar lvar)
+           (type (or symbol list) fun)
+           (type index num-args))
+  (let ((fun (if (listp fun) fun (list fun))))
+    (let ((inside (lvar-uses lvar)))
+      (unless (combination-p inside)
+        (give-up-ir1-transform))
+      (let ((inside-fun (combination-fun inside)))
+        (unless (member (lvar-fun-name inside-fun) fun)
+          (give-up-ir1-transform))
+        (let ((inside-args (combination-args inside)))
+          (unless (= (length inside-args) num-args)
+            (give-up-ir1-transform))
+          (values (lvar-fun-name inside-fun) inside-args))))))

 
 (defun flush-combination (combination)
   (declare (type combination combination))
 
 (defun flush-combination (combination)
   (declare (type combination combination))

@@ -1324,8 +1665,8 @@
             (and (basic-combination-p dest)
                  (eq lvar (basic-combination-fun dest))
                  (csubtypep ltype (specifier-type 'function))))
             (and (basic-combination-p dest)
                  (eq lvar (basic-combination-fun dest))
                  (csubtypep ltype (specifier-type 'function))))

-         (setf (node-derived-type ref) vltype)
-         (derive-node-type ref vltype)))
+          (setf (node-derived-type ref) vltype)
+          (derive-node-type ref vltype)))

     (reoptimize-lvar (node-lvar ref)))
   (values))
 
     (reoptimize-lvar (node-lvar ref)))
   (values))
 

@@ -1347,22 +1688,71 @@
 
 ;;; Return a LEAF which represents the specified constant object. If
 ;;; the object is not in *CONSTANTS*, then we create a new constant
 
 ;;; Return a LEAF which represents the specified constant object. If
 ;;; the object is not in *CONSTANTS*, then we create a new constant

-;;; LEAF and enter it.
-(defun find-constant (object)
-  (if (typep object
-            ;; FIXME: What is the significance of this test? ("things
-            ;; that are worth uniquifying"?)
-            '(or symbol number character instance))
-      (or (gethash object *constants*)
-         (setf (gethash object *constants*)
-               (make-constant :value object
-                              :%source-name '.anonymous.
-                              :type (ctype-of object)
-                              :where-from :defined)))
-      (make-constant :value object
-                    :%source-name '.anonymous.
-                    :type (ctype-of object)
-                    :where-from :defined)))
+;;; LEAF and enter it. If we are producing a fasl file, make sure that
+;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
+;;; needs to be.
+;;;
+;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
+;;; when file-compiling, but not when using COMPILE.
+(defun find-constant (object &optional (name nil namep))
+  (let ((faslp (producing-fasl-file)))
+    (labels ((make-it ()
+               (when faslp
+                 (if namep
+                     (maybe-emit-make-load-forms object name)
+                     (maybe-emit-make-load-forms object)))
+               (make-constant object))
+             (core-coalesce-p (x)
+               ;; True for things which retain their identity under EQUAL,
+               ;; so we can safely share the same CONSTANT leaf between
+               ;; multiple references.
+               (or (typep x '(or symbol number character))
+                   ;; Amusingly enough, we see CLAMBDAs --among other things--
+                   ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
+                   ;; No point in stuffing them in the hash-table.
+                   (and (typep x 'instance)
+                        (not (or (leaf-p x) (node-p x))))))
+             (file-coalesce-p (x)
+               ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
+               ;; other things when file-compiling.
+               (or (core-coalesce-p x)
+                   (if (consp x)
+                       (if (eq +code-coverage-unmarked+ (cdr x))
+                           ;; These are already coalesced, and the CAR should
+                           ;; always be OK, so no need to check.
+                           t
+                           (unless (maybe-cyclic-p x) ; safe for EQUAL?
+                             (do ((y x (cdr y)))
+                                 ((atom y) (file-coalesce-p y))
+                               (unless (file-coalesce-p (car y))
+                                 (return nil)))))
+                       ;; We *could* coalesce base-strings as well,
+                       ;; but we'd need a separate hash-table for
+                       ;; that, since we are not allowed to coalesce
+                       ;; base-strings with non-base-strings.
+                       (typep x
+                              '(or bit-vector
+                                ;; in the cross-compiler, we coalesce
+                                ;; all strings with the same contents,
+                                ;; because we will end up dumping them
+                                ;; as base-strings anyway.  In the
+                                ;; real compiler, we're not allowed to
+                                ;; coalesce regardless of string
+                                ;; specialized element type, so we
+                                ;; KLUDGE by coalescing only character
+                                ;; strings (the common case) and
+                                ;; punting on the other types.
+                                #+sb-xc-host
+                                string
+                                #-sb-xc-host
+                                (vector character))))))
+             (coalescep (x)
+               (if faslp (file-coalesce-p x) (core-coalesce-p x))))
+      (if (and (boundp '*constants*) (coalescep object))
+          (or (gethash object *constants*)
+              (setf (gethash object *constants*)
+                    (make-it)))
+          (make-it)))))

 \f
 ;;; Return true if VAR would have to be closed over if environment
 ;;; analysis ran now (i.e. if there are any uses that have a different
 \f
 ;;; Return true if VAR would have to be closed over if environment
 ;;; analysis ran now (i.e. if there are any uses that have a different

@@ -1376,7 +1766,7 @@
                (flet ((frob (l)
                         (find home l
                               :key #'node-home-lambda
                (flet ((frob (l)
                         (find home l
                               :key #'node-home-lambda

-                              :test-not #'eq)))
+                              :test #'neq)))

                  (or (frob (leaf-refs var))
                      (frob (basic-var-sets var)))))))))
 
                  (or (frob (leaf-refs var))
                      (frob (basic-var-sets var)))))))))
 

@@ -1385,10 +1775,16 @@
 (defun find-nlx-info (exit)
   (declare (type exit exit))
   (let* ((entry (exit-entry exit))
 (defun find-nlx-info (exit)
   (declare (type exit exit))
   (let* ((entry (exit-entry exit))

-         (entry-cleanup (entry-cleanup entry)))
+         (cleanup (entry-cleanup entry))
+        (block (first (block-succ (node-block exit)))))

     (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
     (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)

-      (when (eq (nlx-info-exit nlx) exit)
-       (return nlx)))))
+      (when (and (eq (nlx-info-block nlx) block)
+                 (eq (nlx-info-cleanup nlx) cleanup))
+        (return nlx)))))
+
+(defun nlx-info-lvar (nlx)
+  (declare (type nlx-info nlx))
+  (node-lvar (block-last (nlx-info-target nlx))))

 \f
 ;;;; functional hackery
 
 \f
 ;;;; functional hackery
 

@@ -1407,17 +1803,17 @@
 (defun looks-like-an-mv-bind (functional)
   (and (optional-dispatch-p functional)
        (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
 (defun looks-like-an-mv-bind (functional)
   (and (optional-dispatch-p functional)
        (do ((arg (optional-dispatch-arglist functional) (cdr arg)))

-          ((null arg) nil)
-        (let ((info (lambda-var-arg-info (car arg))))
-          (unless info (return nil))
-          (case (arg-info-kind info)
-            (:optional
-             (when (or (arg-info-supplied-p info) (arg-info-default info))
-               (return nil)))
-            (:rest
-             (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
-            (t
-             (return nil)))))))
+           ((null arg) nil)
+         (let ((info (lambda-var-arg-info (car arg))))
+           (unless info (return nil))
+           (case (arg-info-kind info)
+             (:optional
+              (when (or (arg-info-supplied-p info) (arg-info-default info))
+                (return nil)))
+             (:rest
+              (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
+             (t
+              (return nil)))))))

 
 ;;; Return true if function is an external entry point. This is true
 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
 
 ;;; Return true if function is an external entry point. This is true
 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas

@@ -1433,15 +1829,24 @@
   (declare (type lvar lvar))
   (let ((use (lvar-uses lvar)))
     (if (ref-p use)
   (declare (type lvar lvar))
   (let ((use (lvar-uses lvar)))
     (if (ref-p use)

-       (let ((leaf (ref-leaf use)))
-         (if (and (global-var-p leaf)
-                  (eq (global-var-kind leaf) :global-function)
-                  (or (not (defined-fun-p leaf))
-                      (not (eq (defined-fun-inlinep leaf) :notinline))
-                      notinline-ok))
-             (leaf-source-name leaf)
-             nil))
-       nil)))
+        (let ((leaf (ref-leaf use)))
+          (if (and (global-var-p leaf)
+                   (eq (global-var-kind leaf) :global-function)
+                   (or (not (defined-fun-p leaf))
+                       (not (eq (defined-fun-inlinep leaf) :notinline))
+                       notinline-ok))
+              (leaf-source-name leaf)
+              nil))
+        nil)))
+
+(defun lvar-fun-debug-name (lvar)
+  (declare (type lvar lvar))
+  (let ((uses (lvar-uses lvar)))
+    (flet ((name1 (use)
+             (leaf-debug-name (ref-leaf use))))
+      (if (ref-p uses)
+        (name1 uses)
+        (mapcar #'name1 uses)))))

 
 ;;; Return the source name of a combination. (This is an idiom
 ;;; which was used in CMU CL. I gather it always works. -- WHN)
 
 ;;; Return the source name of a combination. (This is an idiom
 ;;; which was used in CMU CL. I gather it always works. -- WHN)

@@ -1461,7 +1866,7 @@
   (declare (type lambda-var var))
   (let ((fun (lambda-var-home var)))
     (elt (combination-args (let-combination fun))
   (declare (type lambda-var var))
   (let ((fun (lambda-var-home var)))
     (elt (combination-args (let-combination fun))

-        (position-or-lose var (lambda-vars fun)))))
+         (position-or-lose var (lambda-vars fun)))))

 
 ;;; Return the LAMBDA that is called by the local CALL.
 (defun combination-lambda (call)
 
 ;;; Return the LAMBDA that is called by the local CALL.
 (defun combination-lambda (call)

@@ -1478,28 +1883,28 @@
 ;;; limit, and warn if so, returning NIL.
 (defun inline-expansion-ok (node)
   (let ((expanded (incf (component-inline-expansions
 ;;; limit, and warn if so, returning NIL.
 (defun inline-expansion-ok (node)
   (let ((expanded (incf (component-inline-expansions

-                        (block-component
-                         (node-block node))))))
+                         (block-component
+                          (node-block node))))))

     (cond ((> expanded *inline-expansion-limit*) nil)
     (cond ((> expanded *inline-expansion-limit*) nil)

-         ((= expanded *inline-expansion-limit*)
-          ;; FIXME: If the objective is to stop the recursive
-          ;; expansion of inline functions, wouldn't it be more
-          ;; correct to look back through surrounding expansions
-          ;; (which are, I think, stored in the *CURRENT-PATH*, and
-          ;; possibly stored elsewhere too) and suppress expansion
-          ;; and print this warning when the function being proposed
-          ;; for inline expansion is found there? (I don't like the
-          ;; arbitrary numerical limit in principle, and I think
-          ;; it'll be a nuisance in practice if we ever want the
-          ;; compiler to be able to use WITH-COMPILATION-UNIT on
-          ;; arbitrarily huge blocks of code. -- WHN)
-          (let ((*compiler-error-context* node))
-            (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
-                              probably trying to~%  ~
-                              inline a recursive function."
-                             *inline-expansion-limit*))
-          nil)
-         (t t))))
+          ((= expanded *inline-expansion-limit*)
+           ;; FIXME: If the objective is to stop the recursive
+           ;; expansion of inline functions, wouldn't it be more
+           ;; correct to look back through surrounding expansions
+           ;; (which are, I think, stored in the *CURRENT-PATH*, and
+           ;; possibly stored elsewhere too) and suppress expansion
+           ;; and print this warning when the function being proposed
+           ;; for inline expansion is found there? (I don't like the
+           ;; arbitrary numerical limit in principle, and I think
+           ;; it'll be a nuisance in practice if we ever want the
+           ;; compiler to be able to use WITH-COMPILATION-UNIT on
+           ;; arbitrarily huge blocks of code. -- WHN)
+           (let ((*compiler-error-context* node))
+             (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
+                               probably trying to~%  ~
+                               inline a recursive function."
+                              *inline-expansion-limit*))
+           nil)
+          (t t))))

 
 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
 (defun assure-functional-live-p (functional)
 
 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
 (defun assure-functional-live-p (functional)

@@ -1512,8 +1917,22 @@
               ;; analysis, it is LET-converted: LET-converted functionals
               ;; are too badly trashed to expand them inline, and deleted
               ;; LET-converted functionals are even worse.
               ;; analysis, it is LET-converted: LET-converted functionals
               ;; are too badly trashed to expand them inline, and deleted
               ;; LET-converted functionals are even worse.

-              (eql (functional-kind functional) :deleted)))
+              (memq (functional-kind functional) '(:deleted :zombie))))

     (throw 'locall-already-let-converted functional)))
     (throw 'locall-already-let-converted functional)))

+
+(defun call-full-like-p (call)
+  (declare (type combination call))
+  (let ((kind (basic-combination-kind call)))
+    (or (eq kind :full)
+        (and (eq kind :known)
+             (let ((info (basic-combination-fun-info call)))
+               (and
+                (not (fun-info-ir2-convert info))
+                (dolist (template (fun-info-templates info) t)
+                  (when (eq (template-ltn-policy template) :fast-safe)
+                    (multiple-value-bind (val win)
+                       (valid-fun-use call (template-type template))
+                      (when (or val (not win)) (return nil)))))))))))

 \f
 ;;;; careful call
 
 \f
 ;;;; careful call
 

@@ -1524,16 +1943,16 @@
 ;;; the error context for any error message, and CONTEXT is a string
 ;;; that is spliced into the warning.
 (declaim (ftype (sfunction ((or symbol function) list node function string)
 ;;; the error context for any error message, and CONTEXT is a string
 ;;; that is spliced into the warning.
 (declaim (ftype (sfunction ((or symbol function) list node function string)

-                         (values list boolean))
-               careful-call))
+                          (values list boolean))
+                careful-call))

 (defun careful-call (function args node warn-fun context)
   (values
    (multiple-value-list
     (handler-case (apply function args)
       (error (condition)
 (defun careful-call (function args node warn-fun context)
   (values
    (multiple-value-list
     (handler-case (apply function args)
       (error (condition)

-       (let ((*compiler-error-context* node))
-         (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
-         (return-from careful-call (values nil nil))))))
+        (let ((*compiler-error-context* node))
+          (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
+          (return-from careful-call (values nil nil))))))

    t))
 
 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
    t))
 
 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong

@@ -1543,8 +1962,8 @@
        `(progn
           (defun ,careful (specifier)
             (handler-case (,basic specifier)
        `(progn
           (defun ,careful (specifier)
             (handler-case (,basic specifier)

-             (sb!kernel::arg-count-error (condition)
-               (values nil (list (format nil "~A" condition))))
+              (sb!kernel::arg-count-error (condition)
+                (values nil (list (format nil "~A" condition))))

               (simple-error (condition)
                 (values nil (list* (simple-condition-format-control condition)
                                    (simple-condition-format-arguments condition))))))
               (simple-error (condition)
                 (values nil (list* (simple-condition-format-control condition)
                                    (simple-condition-format-arguments condition))))))

@@ -1569,7 +1988,7 @@
 ;;; otherwise. The legality and constantness of the keywords should
 ;;; already have been checked.
 (declaim (ftype (sfunction (list keyword) (or lvar null))
 ;;; otherwise. The legality and constantness of the keywords should
 ;;; already have been checked.
 (declaim (ftype (sfunction (list keyword) (or lvar null))

-               find-keyword-lvar))
+                find-keyword-lvar))

 (defun find-keyword-lvar (args key)
   (do ((arg args (cddr arg)))
       ((null arg) nil)
 (defun find-keyword-lvar (args key)
   (do ((arg args (cddr arg)))
       ((null arg) nil)

@@ -1584,7 +2003,7 @@
   (do ((arg args (cddr arg)))
       ((null arg) t)
     (unless (and (rest arg)
   (do ((arg args (cddr arg)))
       ((null arg) t)
     (unless (and (rest arg)

-                (constant-lvar-p (first arg)))
+                 (constant-lvar-p (first arg)))

       (return nil))))
 
 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
       (return nil))))
 
 ;;; This function is used by the result of PARSE-DEFTRANSFORM to

@@ -1594,9 +2013,9 @@
 (defun check-transform-keys (args keys)
   (and (check-key-args-constant args)
        (do ((arg args (cddr arg)))
 (defun check-transform-keys (args keys)
   (and (check-key-args-constant args)
        (do ((arg args (cddr arg)))

-          ((null arg) t)
-        (unless (member (lvar-value (first arg)) keys)
-          (return nil)))))
+           ((null arg) t)
+         (unless (member (lvar-value (first arg)) keys)
+           (return nil)))))

 \f
 ;;;; miscellaneous
 
 \f
 ;;;; miscellaneous
 

@@ -1605,8 +2024,8 @@
 (defun %event (info node)
   (incf (event-info-count info))
   (when (and (>= (event-info-level info) *event-note-threshold*)
 (defun %event (info node)
   (incf (event-info-count info))
   (when (and (>= (event-info-level info) *event-note-threshold*)

-            (policy (or node *lexenv*)
-                    (= inhibit-warnings 0)))
+             (policy (or node *lexenv*)
+                     (= inhibit-warnings 0)))

     (let ((*compiler-error-context* node))
       (compiler-notify (event-info-description info))))
 
     (let ((*compiler-error-context* node))
       (compiler-notify (event-info-description info))))
 

@@ -1642,4 +2061,25 @@
              (do-uses (node lvar)
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
              (do-uses (node lvar)
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)

-               (setf (component-reoptimize (node-component node)) t)))))))
+               (reoptimize-component (node-component node) :maybe)))))))
+
+;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
+;;; global function with one of the specified NAMES.
+(defun lvar-fun-is (lvar names)
+  (declare (type lvar lvar) (list names))
+  (let ((use (lvar-uses lvar)))
+    (and (ref-p use)
+         (let ((leaf (ref-leaf use)))
+           (and (global-var-p leaf)
+                (eq (global-var-kind leaf) :global-function)
+                (not (null (member (leaf-source-name leaf) names
+                                   :test #'equal))))))))
+
+(defun lvar-matches (lvar &key fun-names arg-count)
+  (let ((use (lvar-use lvar)))
+    (and (combination-p use)
+         (or (not fun-names)
+             (member (combination-fun-source-name use)
+                     fun-names :test #'eq))
+         (or (not arg-count)
+             (= arg-count (length (combination-args use)))))))