Convert an ASSERT into an AVER in INIT-LIVE-TNS

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 41d7a58..7d9f2f3 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,32 @@
         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)))
+
+(defun principal-lvar-dest (lvar)
+  (labels ((pld (lvar)
+             (declare (type lvar lvar))
+             (let ((dest (lvar-dest lvar)))
+               (if (cast-p dest)
+                   (pld (cast-lvar dest))
+                   dest))))
+    (pld 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 +101,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))))

@@ -89,7 +110,7 @@
                       (first new-uses)
                       new-uses)))
           (setf (lvar-uses lvar) nil))
                       (first new-uses)
                       new-uses)))
           (setf (lvar-uses lvar) nil))

-      (setf (node-lvar node) nil)))
+      (flush-node node)))

   (values))
 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
 ;;; its DEST's block, which must be unreachable.
   (values))
 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
 ;;; its DEST's block, which must be unreachable.

@@ -136,6 +157,53 @@
             (eq (ctran-next it) dest))
            (t (eq (block-start (first (block-succ (node-block node))))
                   (node-prev dest))))))
             (eq (ctran-next it) dest))
            (t (eq (block-start (first (block-succ (node-block node))))
                   (node-prev dest))))))

+
+;;; Returns the defined (usually untrusted) type of the combination,
+;;; or NIL if we couldn't figure it out.
+(defun combination-defined-type (combination)
+  (let ((use (principal-lvar-use (basic-combination-fun combination))))
+    (or (when (ref-p use)
+          (let ((type (leaf-defined-type (ref-leaf use))))
+            (when (fun-type-p type)
+              (fun-type-returns type))))
+        *wild-type*)))
+
+;;; Return true if LVAR destination is executed after node with only
+;;; uninteresting nodes intervening.
+;;;
+;;; Uninteresting nodes are nodes in the same block which are either
+;;; REFs, external CASTs to the same destination, or known combinations
+;;; that never unwind.
+(defun almost-immediately-used-p (lvar node)
+  (declare (type lvar lvar)
+           (type node node))
+  (aver (eq (node-lvar node) lvar))
+  (let ((dest (lvar-dest lvar)))
+    (tagbody
+     :next
+       (let ((ctran (node-next node)))
+         (cond (ctran
+                (setf node (ctran-next ctran))
+                (if (eq node dest)
+                    (return-from almost-immediately-used-p t)
+                    (typecase node
+                      (ref
+                       (go :next))
+                      (cast
+                       (when (and (eq :external (cast-type-check node))
+                                  (eq dest (node-dest node)))
+                         (go :next)))
+                      (combination
+                       ;; KLUDGE: Unfortunately we don't have an attribute for
+                       ;; "never unwinds", so we just special case
+                       ;; %ALLOCATE-CLOSURES: it is easy to run into with eg.
+                       ;; FORMAT and a non-constant first argument.
+                       (when (eq '%allocate-closures (combination-fun-source-name node nil))
+                         (go :next))))))
+               (t
+                (when (eq (block-start (first (block-succ (node-block node))))
+                          (node-prev dest))
+                  (return-from almost-immediately-used-p t))))))))

 \f
 ;;;; lvar substitution
 
 \f
 ;;;; lvar substitution
 

@@ -153,9 +221,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 +232,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))
-
-  (do-uses (node old)
-    (%delete-lvar-use node)
-    (when new
-      (add-lvar-use node 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)))

 
 

-  (when new (reoptimize-lvar new))

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

@@ -221,13 +299,32 @@
       ((: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
 ;;;;
 
 ;;; Filter values of LVAR through FORM, which must be an ordinary/mv
 \f
 ;;;;
 
 ;;; Filter values of LVAR through FORM, which must be an ordinary/mv

-;;; call. First argument must be 'DUMMY, which will be replaced with
-;;; LVAR. In case of an ordinary call the function should not have
-;;; return type NIL. We create a new "filtered" lvar.
+;;; call. Exactly one argument must be 'DUMMY, which will be replaced
+;;; with LVAR. In case of an ordinary call the function should not
+;;; have return type NIL. We create a new "filtered" lvar.

 ;;;
 ;;; TODO: remove preconditions.
 (defun filter-lvar (lvar form)
 ;;;
 ;;; TODO: remove preconditions.
 (defun filter-lvar (lvar form)

@@ -261,11 +358,18 @@
         ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
         ;; no LET conversion has been done yet.) The [mv-]combination
         ;; code from the call in the form will be the use of the new
         ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
         ;; no LET conversion has been done yet.) The [mv-]combination
         ;; code from the call in the form will be the use of the new

-        ;; check lvar. We substitute for the first argument of
-        ;; this node.
+        ;; check lvar. We substitute exactly one argument.

         (let* ((node (lvar-use filtered-lvar))
         (let* ((node (lvar-use filtered-lvar))

-               (args (basic-combination-args node))
-               (victim (first args)))
+               victim)
+          (dolist (arg (basic-combination-args node) (aver victim))
+            (let* ((arg (principal-lvar arg))
+                   (use (lvar-use arg))
+                   leaf)
+              (when (and (ref-p use)
+                         (constant-p (setf leaf (ref-leaf use)))
+                         (eql (constant-value leaf) 'dummy))
+                (aver (not victim))
+                (setf victim arg))))

           (aver (eq (constant-value (ref-leaf (lvar-use victim)))
                     'dummy))
 
           (aver (eq (constant-value (ref-leaf (lvar-use victim)))
                     'dummy))
 

@@ -287,14 +391,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 +430,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 +449,231 @@
 (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)))
+
+(defun flushable-combination-p (call)
+  (declare (type combination call))
+  (let ((kind (combination-kind call))
+        (info (combination-fun-info call)))
+    (when (and (eq kind :known) (fun-info-p info))
+      (let ((attr (fun-info-attributes info)))
+        (when (and (not (ir1-attributep attr call))
+                   ;; FIXME: For now, don't consider potentially flushable
+                   ;; calls flushable when they have the CALL attribute.
+                   ;; Someday we should look at the functional args to
+                   ;; determine if they have any side effects.
+                   (if (policy call (= safety 3))
+                       (ir1-attributep attr flushable)
+                       (ir1-attributep attr unsafely-flushable)))
+          t)))))
+
+;;;; DYNAMIC-EXTENT related
+
+(defun lambda-var-original-name (leaf)
+  (let ((home (lambda-var-home leaf)))
+    (if (eq :external (functional-kind home))
+        (let* ((entry (functional-entry-fun home))
+               (p (1- (position leaf (lambda-vars home)))))
+          (leaf-debug-name
+           (if (optional-dispatch-p entry)
+               (elt (optional-dispatch-arglist entry) p)
+               (elt (lambda-vars entry) p))))
+        (leaf-debug-name leaf))))
+
+(defun note-no-stack-allocation (lvar &key flush)
+  (do-uses (use (principal-lvar lvar))
+    (unless (or
+             ;; Don't complain about not being able to stack allocate constants.
+             (and (ref-p use) (constant-p (ref-leaf use)))
+             ;; If we're flushing, don't complain if we can flush the combination.
+             (and flush (combination-p use) (flushable-combination-p use))
+             ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
+             ;; reports that way.
+             (and (ref-p use) (lambda-var-p (ref-leaf use))
+                  (eq :optional (lambda-kind (lambda-var-home (ref-leaf use))))))
+      ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
+      ;; would be a far better description, but since we use
+      ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
+      ;; can have different handled conditions.
+      (let ((*compiler-error-context* use))
+        (if (and (ref-p use) (lambda-var-p (ref-leaf use)))
+            (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
+                             (lambda-var-original-name (ref-leaf use))
+                             (find-original-source (node-source-path use)))
+            (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
+                             (find-original-source (node-source-path use))))))))
+
+(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)
+        (when 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 (principal-lvar-dest (ref-lvar var-ref))))
+                               (unless (and (combination-p dest) (recurse dest))
+                                 (return-from combination-args-flow-cleanly-p nil)))))))))))
+    (recurse combination1)))
+
+(defun ref-good-for-dx-p (ref)
+ (let* ((lvar (ref-lvar ref))
+        (dest (when lvar (lvar-dest lvar))))
+   (and (combination-p dest)
+        (eq :known (combination-kind dest))
+        (awhen (combination-fun-info dest)
+          (or (ir1-attributep (fun-info-attributes it) dx-safe)
+              (and (not (combination-lvar dest))
+                   (awhen (fun-info-result-arg it)
+                     (eql lvar (nth it (combination-args dest))))))))))
+
+(defun trivial-lambda-var-ref-p (use)
+  (and (ref-p use)
+       (let ((var (ref-leaf use)))
+         ;; lambda-var, no SETS, not explicitly indefinite-extent.
+         (when (and (lambda-var-p var) (not (lambda-var-sets var))
+                    (neq :indefinite (lambda-var-extent var)))
+           (let ((home (lambda-var-home var))
+                 (refs (lambda-var-refs var)))
+             ;; bound by a non-XEP system lambda, no other REFS that aren't
+             ;; DX-SAFE, or are result-args when the result is discarded.
+             (when (and (lambda-system-lambda-p home)
+                        (neq :external (lambda-kind home))
+                        (dolist (ref refs t)
+                          (unless (or (eq use ref) (ref-good-for-dx-p ref))
+                            (return nil))))
+               ;; 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))
+         (fun (lambda-var-home this))
+         (vars (lambda-vars fun))
+         (combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
+         (args (combination-args combination)))
+    (aver (= (length vars) (length args)))
+    (loop for var in vars
+          for arg in args
+          when (eq var this)
+          return arg)))
+
+;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
+(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component)
+  (let ((uses (lvar-uses lvar)))
+    ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
+    ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
+    ;; to process uses of single-use LVARs.
+    (when (node-p uses)
+      (node-ends-block uses))
+    ;; If this LVAR's USE is good for DX, it is either a CAST, or it
+    ;; must be a regular combination whose arguments are potentially DX as well.
+    (flet ((recurse (use)
+             (etypecase use
+               (cast
+                (handle-nested-dynamic-extent-lvars
+                 dx (cast-value use) recheck-component))
+               (combination
+                (loop for arg in (combination-args use)
+                      ;; deleted args show up as NIL here
+                      when (and arg
+                                (lvar-good-for-dx-p arg dx recheck-component))
+                      append (handle-nested-dynamic-extent-lvars
+                              dx arg recheck-component)))
+               (ref
+                (let* ((other (trivial-lambda-var-ref-lvar use)))
+                  (unless (eq other lvar)
+                    (handle-nested-dynamic-extent-lvars
+                     dx other recheck-component)))))))
+      (cons (cons dx lvar)
+            (if (listp uses)
+                (loop for use in uses
+                      when (use-good-for-dx-p use dx recheck-component)
+                      nconc (recurse use))
+                (when (use-good-for-dx-p uses dx recheck-component)
+                  (recurse uses)))))))
+
+;;;;; BLOCK UTILS
+
+(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 +710,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))

@@ -415,22 +765,61 @@
 (defun source-path-forms (path)
   (subseq path 0 (position 'original-source-start path)))
 
 (defun source-path-forms (path)
   (subseq path 0 (position 'original-source-start path)))
 

+(defun tree-some (predicate tree)
+  (let ((seen (make-hash-table)))
+    (labels ((walk (tree)
+               (cond ((funcall predicate tree))
+                     ((and (consp tree)
+                           (not (gethash tree seen)))
+                      (setf (gethash tree seen) t)
+                      (or (walk (car tree))
+                          (walk (cdr tree)))))))
+      (walk tree))))
+

 ;;; Return the innermost source form for NODE.
 (defun node-source-form (node)
   (declare (type node node))
   (let* ((path (node-source-path node))
 ;;; Return the innermost source form for NODE.
 (defun node-source-form (node)
   (declare (type node node))
   (let* ((path (node-source-path node))

-        (forms (source-path-forms path)))
+         (forms (remove-if (lambda (x)
+                             (tree-some #'leaf-p x))
+                           (source-path-forms path))))
+    ;; another option: if first form includes a leaf, return
+    ;; find-original-source instead.

     (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))))
+
+(defun common-suffix (x y)
+  (let ((mismatch (mismatch x y :from-end t)))
+    (if mismatch
+        (subseq x mismatch)
+        x)))
+
+;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
+;;; singleton.  Otherwise, return a list of the lowest common
+;;; ancestor source form of all the uses (if it can be found),
+;;; followed by all the uses' source forms.
+(defun lvar-all-sources (lvar)
+  (let ((use (lvar-uses lvar)))
+    (if (listp use)
+        (let ((forms  '())
+              (path   (node-source-path (first use))))
+          (dolist (use use (cons (if (find 'original-source-start path)
+                                     (find-original-source path)
+                                     "a hairy form")
+                                 forms))
+            (pushnew (node-source-form use) forms)
+            (setf path (common-suffix path
+                                      (node-source-path use)))))
+        (list (node-source-form use)))))

 
 ;;; 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 +844,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 +871,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)))))

@@ -499,26 +892,33 @@
         (reoptimize-lvar prev)))
 \f
 ;;; Return a new LEXENV just like DEFAULT except for the specified
         (reoptimize-lvar prev)))
 \f
 ;;; Return a new LEXENV just like DEFAULT except for the specified

-;;; slot values. Values for the alist slots are NCONCed to the
+;;; slot values. Values for the alist slots are APPENDed to the

 ;;; beginning of the current value, rather than replacing it entirely.
 (defun make-lexenv (&key (default *lexenv*)
 ;;; 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))
+                         (user-data (lexenv-user-data 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
+                      (append ,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
+     user-data)))

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

@@ -535,7 +935,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,7 +950,10 @@
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil

-     (lexenv-policy lexenv))))
+     (lexenv-handled-conditions lexenv)
+     (lexenv-disabled-package-locks lexenv)
+     (lexenv-policy lexenv)
+     (lexenv-user-data lexenv))))

 \f
 ;;;; flow/DFO/component hackery
 
 \f
 ;;;; flow/DFO/component hackery
 

@@ -555,9 +961,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 +980,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 +1004,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 +1035,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 +1046,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 +1055,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 +1099,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 +1114,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

@@ -717,23 +1151,24 @@
 (defun delete-lambda-var (leaf)
   (declare (type lambda-var leaf))
 
 (defun delete-lambda-var (leaf)
   (declare (type lambda-var leaf))
 

+  (setf (lambda-var-deleted leaf) t)

   ;; Iterate over all local calls flushing the corresponding argument,
   ;; allowing the computation of the argument to be deleted. We also
   ;; mark the LET for reoptimization, since it may be that we have
   ;; deleted its last variable.
   (let* ((fun (lambda-var-home leaf))
   ;; Iterate over all local calls flushing the corresponding argument,
   ;; allowing the computation of the argument to be deleted. We also
   ;; 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 +1187,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,88 +1201,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 mey 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)))
-    (aver (not (member original-kind '(:deleted :optional :toplevel))))
+        (bind (lambda-bind clambda)))
+    (aver (not (member original-kind '(:deleted :toplevel))))

     (aver (not (functional-has-external-references-p clambda)))
     (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))
-                   (if (eq (functional-kind child) :deleted)
-                       (delete-children child)
-                       (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)
-               (delete 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))
 

@@ -877,64 +1319,122 @@
       (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.
+;;;
+;;; Also check that the parent of the functional is visible in the current
+;;; environment.
+(defun defined-fun-functional (defined-fun)
+  (let ((functionals (defined-fun-functionals defined-fun)))
+    (when functionals
+      (let* ((sample (car functionals))
+             (there (lambda-parent (if (lambda-p sample)
+                                       sample
+                                       (optional-dispatch-main-entry sample)))))
+        (when there
+          (labels ((lookup (here)
+                     (unless (eq here there)
+                       (if here
+                           (lookup (lambda-parent here))
+                           ;; We looked up all the way up, and didn't find the parent
+                           ;; of the functional -- therefore it is nested in a lambda
+                           ;; we don't see, so return nil.
+                           (return-from defined-fun-functional nil)))))
+            (lookup (lexenv-lambda *lexenv*)))))
+      ;; Now find a functional whose policy matches the current one, if we already
+      ;; have one.
+      (let ((policy (lexenv-%policy *lexenv*)))
+        (dolist (functional functionals)
+          (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
+                 (unless (functional-has-external-references-p leaf)
+                   (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))
 

+;;; This function is called to unlink a node from its LVAR;
+;;; we assume that the LVAR's USE list has already been updated,
+;;; and that we only have to mark the node as up for dead code
+;;; elimination, and to clear it LVAR slot.
+(defun flush-node (node)
+  (declare (type node node))
+  (let* ((prev (node-prev node))
+         (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 node) nil))
+

 ;;; This function is called by people who delete nodes; it provides a
 ;;; way to indicate that the value of a lvar is no longer used. We
 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
 ;;; This function is called by people who delete nodes; it provides a
 ;;; way to indicate that the value of a lvar is no longer used. We
 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses

@@ -942,15 +1442,12 @@
 (defun flush-dest (lvar)
   (declare (type (or lvar null) lvar))
   (unless (null lvar)
 (defun flush-dest (lvar)
   (declare (type (or lvar null) lvar))
   (unless (null lvar)

+    (when (lvar-dynamic-extent lvar)
+      (note-no-stack-allocation lvar :flush t))

     (setf (lvar-dest lvar) nil)
     (flush-lvar-externally-checkable-type lvar)
     (do-uses (use lvar)
     (setf (lvar-dest lvar) nil)
     (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)
-                t)))
-      (setf (node-lvar use) nil))
+      (flush-node use))

     (setf (lvar-uses lvar) nil))
   (values))
 
     (setf (lvar-uses lvar) nil))
   (values))
 

@@ -962,6 +1459,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)

@@ -969,7 +1473,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))

@@ -982,10 +1486,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)

@@ -1005,7 +1511,7 @@
   (do-nodes-carefully (node block)
     (when (valued-node-p node)
       (delete-lvar-use node))
   (do-nodes-carefully (node block)
     (when (valued-node-p node)
       (delete-lvar-use node))

-    (typecase node
+    (etypecase node

       (ref (delete-ref node))
       (cif (flush-dest (if-test node)))
       ;; The next two cases serve to maintain the invariant that a LET
       (ref (delete-ref node))
       (cif (flush-dest (if-test node)))
       ;; The next two cases serve to maintain the invariant that a LET

@@ -1038,6 +1544,11 @@
          (when entry
            (setf (entry-exits entry)
                  (delq node (entry-exits entry))))))
          (when entry
            (setf (entry-exits entry)
                  (delq node (entry-exits entry))))))

+      (entry
+       (dolist (exit (entry-exits node))
+         (mark-for-deletion (node-block exit)))
+       (let ((home (node-home-lambda node)))
+         (setf (lambda-entries home) (delq node (lambda-entries home)))))

       (creturn
        (flush-dest (return-result node))
        (delete-return node))
       (creturn
        (flush-dest (return-result node))
        (delete-return node))

@@ -1070,14 +1581,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))

@@ -1090,22 +1607,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

@@ -1129,27 +1646,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

@@ -1168,63 +1685,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

@@ -1234,16 +1761,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))
   (dolist (fun (component-lambdas component))

-    (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))
+    (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)))
+  (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

@@ -1254,42 +1792,95 @@
 ;;; 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)
+         (flushed-keys 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)
+               (push key flushed-keys)
+               (push (second spec) parameters)
+               ;; In case of duplicate keys.
+               (setf (second spec) (gensym))))
+    (dolist (key flushed-keys)
+      (flush-dest key))
+    (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))

@@ -1303,7 +1894,7 @@
 ;;;; leaf hackery
 
 ;;; Change the LEAF that a REF refers to.
 ;;;; leaf hackery
 
 ;;; Change the LEAF that a REF refers to.

-(defun change-ref-leaf (ref leaf)
+(defun change-ref-leaf (ref leaf &key recklessly)

   (declare (type ref ref) (type leaf leaf))
   (unless (eq (ref-leaf ref) leaf)
     (push ref (leaf-refs leaf))
   (declare (type ref ref) (type leaf leaf))
   (unless (eq (ref-leaf ref) leaf)
     (push ref (leaf-refs leaf))

@@ -1317,8 +1908,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 :from-scratch recklessly)))

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

@@ -1340,22 +1931,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

@@ -1369,7 +2009,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)))))))))
 

@@ -1378,10 +2018,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
 

@@ -1400,17 +2046,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

@@ -1426,21 +2072,32 @@
   (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)))
-
-;;; Return the source name of a combination. (This is an idiom
-;;; which was used in CMU CL. I gather it always works. -- WHN)
-(defun combination-fun-source-name (combination)
-  (let ((ref (lvar-uses (combination-fun combination))))
-    (leaf-source-name (ref-leaf ref))))
+        (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 -- or signals an error
+;;; if the function leaf is anonymous.
+(defun combination-fun-source-name (combination &optional (errorp t))
+  (let ((leaf (ref-leaf (lvar-uses (combination-fun combination)))))
+    (if (or errorp (leaf-has-source-name-p leaf))
+        (values (leaf-source-name leaf) t)
+        (values nil nil))))

 
 ;;; Return the COMBINATION node that is the call to the LET FUN.
 (defun let-combination (fun)
 
 ;;; Return the COMBINATION node that is the call to the LET FUN.
 (defun let-combination (fun)

@@ -1454,7 +2111,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)

@@ -1471,28 +2128,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)

@@ -1505,8 +2162,31 @@
               ;; 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 assure-leaf-live-p (leaf)
+  (typecase leaf
+    (lambda-var
+     (when (lambda-var-deleted leaf)
+       (throw 'locall-already-let-converted leaf)))
+    (functional
+     (assure-functional-live-p leaf))))
+
+
+(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
 

@@ -1517,16 +2197,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

@@ -1536,8 +2216,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))))))

@@ -1562,7 +2242,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)

@@ -1577,7 +2257,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

@@ -1587,9 +2267,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
 

@@ -1598,8 +2278,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))))
 

@@ -1635,4 +2315,65 @@
              (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 reference to a global function
+;;; designator with one of the specified NAMES, that hasn't been
+;;; declared NOTINLINE.
+(defun lvar-fun-is (lvar names)
+  (declare (type lvar lvar) (list names))
+  (let ((use (lvar-uses lvar)))
+    (and (ref-p use)
+         (let* ((*lexenv* (node-lexenv use))
+                (leaf (ref-leaf use))
+                (name
+                 (cond ((global-var-p leaf)
+                        ;; Case 1: #'NAME
+                        (and (eq (global-var-kind leaf) :global-function)
+                             (car (member (leaf-source-name leaf) names
+                                          :test #'equal))))
+                       ((constant-p leaf)
+                        (let ((value (constant-value leaf)))
+                          (car (if (functionp value)
+                                   ;; Case 2: #.#'NAME
+                                   (member value names
+                                           :key (lambda (name)
+                                                  (and (fboundp name)
+                                                       (fdefinition name)))
+                                           :test #'eq)
+                                   ;; Case 3: 'NAME
+                                   (member value names
+                                           :test #'equal))))))))
+           (and name
+                (not (fun-lexically-notinline-p name)))))))
+
+;;; Return true if LVAR's only use is a call to one of the named functions
+;;; (or any function if none are specified) with the specified number of
+;;; of arguments (or any number if number is not specified)
+(defun lvar-matches (lvar &key fun-names arg-count)
+  (let ((use (lvar-uses lvar)))
+    (and (combination-p use)
+         (or (not fun-names)
+             (multiple-value-bind (name ok)
+                 (combination-fun-source-name use nil)
+               (and ok (member name fun-names :test #'eq))))
+         (or (not arg-count)
+             (= arg-count (length (combination-args use)))))))
+
+;;; True if the optional has a rest-argument.
+(defun optional-rest-p (opt)
+  (dolist (var (optional-dispatch-arglist opt) nil)
+    (let* ((info (when (lambda-var-p var)
+                   (lambda-var-arg-info var)))
+           (kind (when info
+                   (arg-info-kind info))))
+      (when (eq :rest kind)
+        (return t)))))
+
+;;; Don't substitute single-ref variables on high-debug / low speed, to
+;;; improve the debugging experience. ...but don't bother keeping those
+;;; from system lambdas.
+(defun preserve-single-use-debug-var-p (call var)
+  (and (policy call (eql preserve-single-use-debug-variables 3))
+       (or (not (lambda-var-p var))
+           (not (lambda-system-lambda-p (lambda-var-home var))))))