1.0.15.9: further ASSOC & MEMBER transform improvements

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index a5e8c16..bd3c298 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*

@@ -63,10 +63,13 @@
         (list uses))))
 
 (defun principal-lvar-use (lvar)
         (list uses))))
 
 (defun principal-lvar-use (lvar)

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

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

@@ -153,9 +156,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)

@@ -325,6 +328,26 @@
                     (merge-tail-sets merge)))))
         (t (flush-dest value)
            (unlink-node node))))
                     (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
 

@@ -335,7 +358,7 @@
 (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))))
+            (lexenv-lambda (lambda-call-lexenv fun))))

       ((not (memq (functional-kind fun) '(:deleted :zombie)))
        (lambda-home fun))
     (when (eq (lambda-home fun) fun)
       ((not (memq (functional-kind fun) '(:deleted :zombie)))
        (lambda-home fun))
     (when (eq (lambda-home fun) fun)

@@ -359,6 +382,13 @@
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 

+(defun use-good-for-dx-p (use)
+  (and (combination-p use)
+       (eq (combination-kind use) :known)
+       (awhen (fun-info-stack-allocate-result
+               (combination-fun-info use))
+         (funcall it use))))
+

 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)

@@ -405,25 +435,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))

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

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

     (if forms
     (if forms

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

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

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

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

@@ -500,11 +530,11 @@
   ;; 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))
 
 ;;; Return the LAMBDA that is CTRAN's home.
 (declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda))

@@ -551,26 +581,26 @@
 ;;; slot values. Values for the alist slots are NCONCed to the
 ;;; beginning of the current value, rather than replacing it entirely.
 (defun make-lexenv (&key (default *lexenv*)
 ;;; slot values. Values for the alist slots are NCONCed to the
 ;;; beginning of the current value, rather than replacing it entirely.
 (defun make-lexenv (&key (default *lexenv*)

-                        funs vars blocks tags
+                         funs vars blocks tags

                          type-restrictions
                          type-restrictions

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

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

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

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

-     lambda cleanup handled-conditions 
+     lambda cleanup handled-conditions

      disabled-package-locks policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
      disabled-package-locks policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced

@@ -588,7 +618,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)))))

@@ -610,9 +643,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)

@@ -629,19 +662,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

@@ -653,29 +686,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))
              (reoptimize-component (block-component block) :maybe)))))
       (t
        (unless (memq new (block-succ block))
            (when (eq (if-consequent last)
                      (if-alternative last))
              (reoptimize-component (block-component block) :maybe)))))
       (t
        (unless (memq new (block-succ block))

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

 
   (values))
 
 
   (values))
 

@@ -684,7 +717,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))

@@ -695,7 +728,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)

@@ -720,7 +753,7 @@
                ((:block :tagbody)
                 (aver (entry-p mess-up))
                 (loop for exit in (entry-exits mess-up)
                ((:block :tagbody)
                 (aver (entry-p mess-up))
                 (loop for exit in (entry-exits mess-up)

-                      for nlx-info = (find-nlx-info exit)
+                      for nlx-info = (exit-nlx-info exit)

                       do (funcall fun nlx-info)))
                ((:catch :unwind-protect)
                 (aver (combination-p mess-up))
                       do (funcall fun nlx-info)))
                ((:catch :unwind-protect)
                 (aver (combination-p mess-up))

@@ -736,7 +769,7 @@
 (declaim (ftype (sfunction (component) (values)) clear-flags))
 (defun clear-flags (component)
   (let ((head (component-head component))
 (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)

@@ -748,8 +781,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)

@@ -763,34 +796,34 @@
 (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)))

     (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

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

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

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

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

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

@@ -834,13 +867,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

@@ -848,7 +881,7 @@
 ;;; 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)))
   (etypecase fun
     (optional-dispatch (delete-optional-dispatch fun))
     (clambda (delete-lambda fun)))

@@ -861,7 +894,7 @@
 (defun delete-lambda (clambda)
   (declare (type clambda clambda))
   (let ((original-kind (functional-kind clambda))
 (defun delete-lambda (clambda)
   (declare (type clambda clambda))
   (let ((original-kind (functional-kind clambda))

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

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

@@ -934,9 +967,9 @@
     ;; point anymore.
     (when (eq original-kind :external)
       (let ((fun (functional-entry-fun clambda)))
     ;; 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))
 

@@ -966,61 +999,75 @@
       (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*))))))
+

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

 
   (values))
 
 
   (values))
 

@@ -1035,7 +1082,7 @@
     (flush-lvar-externally-checkable-type lvar)
     (do-uses (use lvar)
       (let ((prev (node-prev use)))
     (flush-lvar-externally-checkable-type lvar)
     (do-uses (use lvar)
       (let ((prev (node-prev use)))

-       (let ((block (ctran-block prev)))
+        (let ((block (ctran-block prev)))

           (reoptimize-component (block-component block) t)
           (setf (block-attributep (block-flags block)
                                   flush-p type-asserted type-check)
           (reoptimize-component (block-component block) t)
           (setf (block-attributep (block-flags block)
                                   flush-p type-asserted type-check)

@@ -1174,20 +1221,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.
-         #-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
+        (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))

@@ -1200,22 +1247,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

@@ -1239,27 +1286,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

@@ -1278,57 +1325,57 @@
     (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))
-              (when (block-delete-p 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)
                  (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 (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.
 
 ;;; Return true if CTRAN has been deleted, false if it is still a valid
 ;;; part of IR1.

@@ -1385,42 +1432,58 @@
 ;;; 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
   "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."
   (declare (type lvar lvar)
   #!+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."
   (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)))
       (unless (eq (lvar-fun-name inside-fun) fun)
     (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))
+        (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-fun-info inside) (info :function :info 'list)
-               (combination-kind inside) :known)
-         (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)
+          (values))))))
+
+(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))

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

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

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

@@ -1474,19 +1537,19 @@
 ;;; LEAF and enter it.
 (defun find-constant (object)
   (if (typep object
 ;;; 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))
+             ;; FIXME: What is the significance of this test? ("things
+             ;; that are worth uniquifying"?)
+             '(or symbol number character instance))

       (or (gethash object *constants*)
       (or (gethash object *constants*)

-         (setf (gethash object *constants*)
-               (make-constant :value object
-                              :%source-name '.anonymous.
-                              :type (ctype-of object)
-                              :where-from :defined)))
+          (setf (gethash object *constants*)
+                (make-constant :value object
+                               :%source-name '.anonymous.
+                               :type (ctype-of object)
+                               :where-from :defined)))

       (make-constant :value object
       (make-constant :value object

-                    :%source-name '.anonymous.
-                    :type (ctype-of object)
-                    :where-from :defined)))
+                     :%source-name '.anonymous.
+                     :type (ctype-of object)
+                     :where-from :defined)))

 \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

@@ -1508,10 +1571,17 @@
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (exit)
   (declare (type exit exit))
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (exit)
   (declare (type exit exit))

-  (let ((entry (exit-entry exit)))
+  (let* ((entry (exit-entry exit))
+         (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
 

@@ -1530,17 +1600,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

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

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

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

@@ -1584,7 +1663,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)

@@ -1601,28 +1680,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, ~
+          ((= 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."
                                probably trying to~%  ~
                                inline a recursive function."

-                             *inline-expansion-limit*))
-          nil)
-         (t t))))
+                              *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)

@@ -1643,14 +1722,14 @@
   (let ((kind (basic-combination-kind call)))
     (or (eq kind :full)
         (and (eq kind :known)
   (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)))))))))))
+             (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
 

@@ -1661,16 +1740,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

@@ -1680,8 +1759,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))))))

@@ -1706,7 +1785,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)

@@ -1721,7 +1800,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

@@ -1731,9 +1810,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
 

@@ -1742,8 +1821,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))))
 

@@ -1780,3 +1859,15 @@
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))

+
+;;; True if LVAR is for 'NAME, or #'NAME (global, not local)
+(defun lvar-for-named-function (lvar name)
+  (if (constant-lvar-p lvar)
+      (eq name (lvar-value lvar))
+      (let ((use (lvar-uses lvar)))
+        (and (not (listp use))
+             (ref-p use)
+             (let ((leaf (ref-leaf use)))
+               (and (global-var-p leaf)
+                    (eq :global-function (global-var-kind leaf))
+                    (eq name (leaf-source-name leaf))))))))