1.0.29.6: regression in DIRECTORY when matching directory patterns

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d501d67..19e0adb 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -391,6 +391,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 +443,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 +1227,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 +1637,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 +1648,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)))