X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=7d9f2f3d4842fe0449cf891513d32e744b220df5;hb=HEAD;hp=64182a29f5eab24965a5151f6c8748593c3114e6;hpb=757091b10a73a7f6e2bd673bcf990ac93f23f77c;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 64182a2..7d9f2f3 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -80,6 +80,15 @@
                    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.
 ;;;
@@ -101,7 +110,7 @@
                       (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.
@@ -148,6 +157,53 @@
             (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))))))))
 
 ;;;; lvar substitution
 
@@ -266,9 +322,9 @@
 ;;;;
 
 ;;; 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)
@@ -302,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
-        ;; check lvar. We substitute for the first argument of
-        ;; this node.
+        ;; check lvar. We substitute exactly one argument.
         (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))
 
@@ -391,10 +454,58 @@
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 
-(declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component))
-                           boolean) use-good-for-dx-p))
-(declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component))
-                           boolean) lvar-good-for-dx-p))
+(defun 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
@@ -415,15 +526,23 @@
 (defun lvar-good-for-dx-p (lvar dx &optional component)
   (let ((uses (lvar-uses lvar)))
     (if (listp uses)
-        (every (lambda (use)
-                 (use-good-for-dx-p use dx component))
-               uses)
+        (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)
-       (awhen (fun-info-stack-allocate-result (combination-fun-info use))
-         (funcall it use dx))))
+       (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)
@@ -457,21 +576,37 @@
                        (when (lambda-p clambda1)
                          (dolist (var (lambda-vars clambda1) t)
                            (dolist (var-ref (lambda-var-refs var))
-                             (let ((dest (lvar-dest (ref-lvar var-ref))))
+                             (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
-         (when (and (lambda-var-p var) (not (lambda-var-sets var)))
+         ;; 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 system lambda, no other REFS
+             ;; 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)
-                        (eq use (car refs)) (not (cdr refs)))
+                        (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))
@@ -482,16 +617,52 @@
 
 (defun trivial-lambda-var-ref-lvar (use)
   (let* ((this (ref-leaf use))
-         (home (lambda-var-home this)))
-    (multiple-value-bind (fun vars)
-        (values home (lambda-vars home))
-      (let* ((combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
-             (args (combination-args combination)))
-        (assert (= (length vars) (length args)))
-        (loop for var in vars
-              for arg in args
-              when (eq var this)
-              return arg)))))
+         (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)
@@ -594,11 +765,26 @@
 (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))
-         (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
         (first forms)
         (values (find-original-source path)))))
@@ -611,6 +797,30 @@
         (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))
 (defun lvar-use (lvar)
@@ -682,7 +892,7 @@
         (reoptimize-lvar prev)))
 
 ;;; 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*)
                          funs vars blocks tags
@@ -692,11 +902,12 @@
                          (handled-conditions (lexenv-handled-conditions default))
                          (disabled-package-locks
                           (lexenv-disabled-package-locks default))
-                         (policy (lexenv-policy default)))
+                         (policy (lexenv-policy default))
+                         (user-data (lexenv-user-data default)))
   (macrolet ((frob (var slot)
                `(let ((old (,slot default)))
                   (if ,var
-                      (nconc ,var old)
+                      (append ,var old)
                       old))))
     (internal-make-lexenv
      (frob funs lexenv-funs)
@@ -704,8 +915,10 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup handled-conditions
-     disabled-package-locks policy)))
+     lambda
+     cleanup handled-conditions disabled-package-locks
+     policy
+     user-data)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
 ;;; macroexpander
@@ -739,7 +952,8 @@
      nil
      (lexenv-handled-conditions lexenv)
      (lexenv-disabled-package-locks lexenv)
-     (lexenv-policy lexenv))))
+     (lexenv-policy lexenv)
+     (lexenv-user-data lexenv))))
 
 ;;;; flow/DFO/component hackery
 
@@ -937,6 +1151,7 @@
 (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
@@ -1143,11 +1358,32 @@
 
 ;;; 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 ((policy (lexenv-%policy *lexenv*)))
-    (dolist (functional (defined-fun-functionals defined-fun))
-      (when (equal policy (lexenv-%policy (functional-lexenv functional)))
-        (return functional)))))
+  (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
@@ -1168,7 +1404,8 @@
                  (aver (null (functional-entry-fun leaf)))
                  (delete-lambda leaf))
                 (:external
-                 (delete-lambda leaf))
+                 (unless (functional-has-external-references-p leaf)
+                   (delete-lambda leaf)))
                 ((:deleted :zombie :optional))))
              (optional-dispatch
               (unless (eq (functional-kind leaf) :deleted)
@@ -1184,6 +1421,20 @@
 
   (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
@@ -1191,16 +1442,12 @@
 (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)
-      (let ((prev (node-prev use)))
-        (let ((block (ctran-block prev)))
-          (reoptimize-component (block-component block) t)
-          (setf (block-attributep (block-flags block)
-                                  flush-p type-asserted type-check)
-                t)))
-      (setf (node-lvar use) nil))
+      (flush-node use))
     (setf (lvar-uses lvar) nil))
   (values))
 
@@ -1547,9 +1794,9 @@
 ;;; arguments.
 (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."
+  "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)
            (type symbol fun)
            (type index num-args))
@@ -1559,7 +1806,8 @@
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))
-      (unless (eq (lvar-fun-name inside-fun) fun)
+      (unless (or (eq fun :any)
+                  (eq (lvar-fun-name inside-fun) fun))
         (give-up-ir1-transform))
       (let ((inside-args (combination-args inside)))
         (unless (= (length inside-args) num-args)
@@ -1580,7 +1828,43 @@
                 (combination-kind inside) :known)
           (setf (node-derived-type inside) *wild-type*)
           (flush-dest lvar)
-          (values))))))
+          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)
@@ -1610,7 +1894,7 @@
 ;;;; 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))
@@ -1625,7 +1909,7 @@
                  (eq lvar (basic-combination-fun dest))
                  (csubtypep ltype (specifier-type 'function))))
           (setf (node-derived-type ref) vltype)
-          (derive-node-type ref vltype)))
+          (derive-node-type ref vltype :from-scratch recklessly)))
     (reoptimize-lvar (node-lvar ref)))
   (values))
 
@@ -1807,11 +2091,13 @@
         (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)
-(defun combination-fun-source-name (combination)
-  (let ((ref (lvar-uses (combination-fun combination))))
-    (leaf-source-name (ref-leaf ref))))
+;;; 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)
@@ -1879,6 +2165,15 @@
               (memq (functional-kind functional) '(:deleted :zombie))))
     (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)))
@@ -2022,14 +2317,63 @@
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))
 
-;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
-;;; global function with one of the specified NAMES.
+;;; 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 ((leaf (ref-leaf use)))
-           (and (global-var-p leaf)
-                (eq (global-var-kind leaf) :global-function)
-                (not (null (member (leaf-source-name leaf) names
-                                   :test #'equal))))))))
+         (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))))))