X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=046c7bf882c93fa6987ed42e278289564ff1f37c;hb=024389e7e3db268f535e36d883b4efc9d7ea0f65;hp=d501d6708212db4d03195f932793c2fb09941b1d;hpb=e840f481796d191997a47421d60cd039cd260613;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d501d67..046c7bf 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -148,6 +148,43 @@
             (eq (ctran-next it) dest))
            (t (eq (block-start (first (block-succ (node-block node))))
                   (node-prev dest))))))
+
+;;; 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
 
@@ -391,6 +428,34 @@
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 
+(defun flushable-combination-p (call)
+  (declare (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)))))
+
+(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)))
+      (let ((*compiler-error-context* use))
+        (compiler-notify "could not stack allocate the result of ~S"
+                         (find-original-source (node-source-path use)))))))
+
+
 (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))
@@ -415,9 +480,10 @@
 (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)
@@ -1198,6 +1264,8 @@
 (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)
@@ -1606,7 +1674,8 @@ is :ANY, the function name is not checked."
          (all (combination-args call))
          (new-args (reverse (subseq all 0 n-positional)))
          (key-args (subseq all n-positional))
-         (parameters nil))
+         (parameters nil)
+         (flushed-keys nil))
     (loop while key-args
           do (let* ((key (pop key-args))
                     (val (pop key-args))
@@ -1616,10 +1685,12 @@ is :ANY, the function name is not checked."
                     (spec (or (assoc keyword specs :test #'eq)
                               (give-up-ir1-transform))))
                (push val new-args)
-               (flush-dest key)
+               (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)))
 
@@ -1850,9 +1921,10 @@ is :ANY, the function name is not checked."
 
 ;;; 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))))
+(defun combination-fun-source-name (combination &optional (errorp t))
+  (let ((leaf (ref-leaf (lvar-uses (combination-fun combination)))))
+    (when (or errorp (leaf-has-source-name-p leaf))
+      (leaf-source-name leaf))))
 
 ;;; Return the COMBINATION node that is the call to the LET FUN.
 (defun let-combination (fun)