X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=f62f0a4c76061057bc19af3f06585f87ec4ee75e;hb=d7e55b414d180341d79e0eddc957e1aa52551c38;hp=964a23f3e86b92e9de9ff39a09c319b35799d57e;hpb=8e1b05fa04bfb1c2da7a766143792ae8b68a78d4;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 964a23f..f62f0a4 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -457,11 +457,14 @@
 ;;;; DYNAMIC-EXTENT related
 
 (defun lambda-var-original-name (leaf)
-  (let* ((home (lambda-var-home leaf)))
-    (if (eq :external (lambda-kind home))
-        (let ((p (1- (position leaf (lambda-vars home)))))
+  (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
-           (elt (lambda-vars (lambda-entry-fun home)) p)))
+           (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)
@@ -470,7 +473,15 @@
              ;; 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)))
+             (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~:@>"
@@ -554,6 +565,17 @@
                                  (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)))
@@ -562,10 +584,13 @@
                     (neq :indefinite (lambda-var-extent var)))
            (let ((home (lambda-var-home var))
                  (refs (lambda-var-refs var)))
-             ;; bound by a non-XEP system lambda, no other REFS
+             ;; bound by a non-XEP system lambda, no other REFS that aren't
+             ;; DX-SAFE, or are result-args when the result is discarded.
              (when (and (lambda-system-lambda-p home)
                         (neq :external (lambda-kind home))
-                        (eq use (car refs)) (not (cdr refs)))
+                        (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))