1.0.48.21: explicitly indefinite-extent leaves, safer dynamic-extent &REST

  Change LEAF-DYNAMIC-EXTENT to LEAF-EXTENT. Setting it to :INDEFINITE stops
  dynamic-extent propagation through the leaf.

  Use this in CONVERT-MORE-CALL / CONVERT-HAIRY-FUN-ENTRY by proclaiming the
  variables in the open-coded &REST list as having indefinite-extent.

  The upshot is that dynamic-extent &REST will only stack allocate the spine
  of the rest list, making it easier and safer to use.

  Document this in the manual and attach appropriate caveats re. portability.

10 files changed, 107 insertions, 46 deletions

diff --git a/NEWS b/NEWS
index a4cdf7637..c4046b642 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,10 @@ changes relative to sbcl-1.0.48:
   * enhancement: more informative compile-time warnings and runtime
     errors for type-errors detected at compile-time.
   * enhancement: deadlock detection for mutexes and spinlocks.
+  * enhancement: dynamic-extent for &rest lists stack allocate only their
+    spines, not their argumets. While portable code should not rely on this,
+    particularly in combination with inlining, it should make dynamic-extent
+    easier and safer to use.
   * bug fix: blocking reads from FIFOs created by RUN-PROGRAM were
     uninterruptible, as well as blocking reads from socket streams created
     with for which :SERVE-EVENTS NIL. (regression from 1.0.42.43)
diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo
index 6820e7707..31fcee00b 100644
--- a/doc/manual/efficiency.texinfo
+++ b/doc/manual/efficiency.texinfo
@@ -73,17 +73,54 @@ lazily set up during those calls.
 @cindex @code{dynamic-extent} declaration
 @cindex declaration, @code{dynamic-extent}
 
-SBCL has limited support for performing allocation on the stack when a
-variable is declared @code{dynamic-extent}. The @code{dynamic-extent}
-declarations are not verified, but are simply trusted as long as
-@code{sb-ext:*stack-allocate-dynamic-extent*} is true.
+SBCL has fairly extensive support for performing allocation on the
+stack when a variable is declared @code{dynamic-extent}. The
+@code{dynamic-extent} declarations are not verified, but are simply
+trusted as long as @code{sb-ext:*stack-allocate-dynamic-extent*} is
+true.
+
+@include var-sb-ext-star-stack-allocate-dynamic-extent-star.texinfo
 
 If dynamic extent constraints specified in the Common Lisp standard
 are violated, the best that can happen is for the program to have
 garbage in variables and return values; more commonly, the system will
 crash.
 
-@include var-sb-ext-star-stack-allocate-dynamic-extent-star.texinfo
+In particular, it is important to realize that dynamic extend is
+contagious:
+
+@lisp
+(let* ((a (list 1 2 3))
+       (b (cons a a)))
+   (declare (dynamic-extent b))
+   ;; Unless A is accessed elsewhere as well, SBCL will consider
+   ;; it to be otherwise inaccessible -- it can only be accessed
+   ;; through B, after all -- and stack allocate it as well.
+   ;;
+   ;; Hence returning (CAR B) here is unsafe.
+   ...)
+@end lisp
+
+This allows stack allocation of complex structures. As a notable
+exception to this, SBCL does not as of 1.0.48.21 propagate
+dynamic-extentness through @code{&rest} arguments -- but another
+conforming implementation might, so portable code should not rely on
+this.
+
+@lisp
+(declaim (inline foo))
+(defun foo (fun &rest arguments)
+  (declare (dynamic-extent arguments))
+  (apply fun arguments))
+
+(defun bar (a)
+  ;; SBCL will heap allocate the result of (LIST A), and stack allocate
+  ;; only the spine of the &rest list -- so this is safe, but unportable.
+  ;;
+  ;; Another implementation, including earlier versions of SBCL might consider
+  ;; (LIST A) to be otherwise inaccessible and stack-allocate it as well!
+  (foo #'car (list a)))
+@end lisp
 
 There are many cases when @code{dynamic-extent} declarations could be
 useful. At present, SBCL implements stack allocation for
@@ -120,11 +157,9 @@ only in zero @code{safety} policies.
 @cindex @code{safety} optimization quality
 @cindex optimization quality, @code{safety}
 closures defined with @code{flet} or @code{labels}, with a bound
-@code{dynamic-extent} declaration. Closed-over variables, which are
-assigned to (either inside or outside the closure) are still allocated
-on the heap. Blocks and tags are also allocated on the heap, unless
-all non-local control transfers to them are compiled with zero
-@code{safety}.
+@code{dynamic-extent} declaration. Blocks and tags are also allocated
+on the heap, unless all non-local control transfers to them are
+compiled with zero @code{safety}.
 
 @item
 user-defined structures when the structure constructor defined using
@@ -180,10 +215,6 @@ Future plans include
 @itemize
 
 @item
-Stack allocation of assigned-to closed-over variables, where these are
-declared @code{dynamic-extent};
-
-@item
 Automatic detection of the common idiom of applying a function to some
 defaults and a @code{&rest} list, even when this is not declared
 @code{dynamic-extent};
diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index b0a2d3d68..a08905092 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -223,7 +223,7 @@
 (progn
   (defoptimizer (allocate-vector stack-allocate-result)
       ((type length words) node dx)
-    (or (eq dx :truly)
+    (or (eq dx :always-dynamic)
         (zerop (policy node safety))
         ;; a vector object should fit in one page -- otherwise it might go past
         ;; stack guard pages.
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 81b68f7c5..db5bf3851 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -1374,13 +1374,17 @@
          (setf (lambda-var-ignorep var) t)))))
   (values))
 
-(defun process-dx-decl (names vars fvars kind)
-  (let ((dx (cond ((eq 'truly-dynamic-extent kind)
-                   :truly)
-                  ((and (eq 'dynamic-extent kind)
-                        *stack-allocate-dynamic-extent*)
-                   t))))
-    (if dx
+(defun process-extent-decl (names vars fvars kind)
+  (let ((extent
+          (ecase kind
+            (truly-dynamic-extent
+             :always-dynamic)
+            (dynamic-extent
+             (when *stack-allocate-dynamic-extent*
+               :maybe-dynamic))
+            (indefinite-extent
+             :indefinite))))
+    (if extent
         (dolist (name names)
           (cond
             ((symbolp name)
@@ -1391,21 +1395,23 @@
                (etypecase var
                  (leaf
                   (if bound-var
-                      (setf (leaf-dynamic-extent var) dx)
+                      (if (and (leaf-extent var) (neq extent (leaf-extent var)))
+                          (warn "Multiple incompatible extent declarations for ~S?" name)
+                          (setf (leaf-extent var) extent))
                       (compiler-notify
-                       "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+                       "Ignoring free ~S declaration: ~S" kind name)))
                  (cons
-                  (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+                  (compiler-error "~S on symbol-macro: ~S" kind name))
                  (heap-alien-info
-                  (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S"
-                                  name))
+                  (compiler-error "~S on alien-variable: ~S" kind name))
                  (null
                   (compiler-style-warn
-                   "Unbound variable declared DYNAMIC-EXTENT: ~S" name)))))
+                   "Unbound variable declared ~S: ~S" kind name)))))
             ((and (consp name)
                   (eq (car name) 'function)
                   (null (cddr name))
-                  (valid-function-name-p (cadr name)))
+                  (valid-function-name-p (cadr name))
+                  (neq :indefinite extent))
              (let* ((fname (cadr name))
                     (bound-fun (find fname fvars
                                      :key #'leaf-source-name
@@ -1415,7 +1421,7 @@
                  (leaf
                   (if bound-fun
                       #!+stack-allocatable-closures
-                      (setf (leaf-dynamic-extent bound-fun) dx)
+                      (setf (leaf-extent bound-fun) extent)
                       #!-stack-allocatable-closures
                       (compiler-notify
                        "Ignoring DYNAMIC-EXTENT declaration on function ~S ~
@@ -1428,7 +1434,7 @@
                   (compiler-style-warn
                    "Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
             (t
-             (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+             (compiler-error "~S on a weird thing: ~S" kind name))))
         (when (policy *lexenv* (= speed 3))
           (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
 
@@ -1483,8 +1489,8 @@
                        (car types)
                        `(values ,@types)))))
           res))
-       ((dynamic-extent truly-dynamic-extent)
-        (process-dx-decl (cdr spec) vars fvars (first spec))
+       ((dynamic-extent truly-dynamic-extent indefinite-extent)
+        (process-extent-decl (cdr spec) vars fvars (first spec))
         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 55df1594e..e3ef6cfef 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -457,10 +457,6 @@
         (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))
-                           boolean) lvar-good-for-dx-p))
 (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
@@ -539,8 +535,9 @@
 (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
@@ -591,6 +588,7 @@
                               dx arg recheck-component)))
                (ref
                 (let* ((other (trivial-lambda-var-ref-lvar use)))
+                  (print (list :ref use other))
                   (unless (eq other lvar)
                     (handle-nested-dynamic-extent-lvars
                      dx other recheck-component)))))))
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index e820d461e..b6d52c2e9 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -47,7 +47,7 @@
   (declare (type combination call) (type clambda fun))
   (loop for arg in (basic-combination-args call)
         for var in (lambda-vars fun)
-        for dx = (lambda-var-dynamic-extent var)
+        for dx = (leaf-dynamic-extent var)
         when (and dx arg (not (lvar-dynamic-extent arg)))
         append (handle-nested-dynamic-extent-lvars dx arg) into dx-lvars
         finally (when dx-lvars
@@ -560,14 +560,15 @@
 ;;; function that rearranges the arguments and calls the entry point.
 ;;; We analyze the new function and the entry point immediately so
 ;;; that everything gets converted during the single pass.
-(defun convert-hairy-fun-entry (ref call entry vars ignores args)
+(defun convert-hairy-fun-entry (ref call entry vars ignores args indef)
   (declare (list vars ignores args) (type ref ref) (type combination call)
            (type clambda entry))
   (let ((new-fun
          (with-ir1-environment-from-node call
            (ir1-convert-lambda
             `(lambda ,vars
-               (declare (ignorable ,@ignores))
+               (declare (ignorable ,@ignores)
+                        (indefinite-extent ,@indef))
                (%funcall ,entry ,@args))
             :debug-name (debug-name 'hairy-function-entry
                                     (lvar-fun-debug-name
@@ -698,7 +699,8 @@
 
         (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
                                  (append temps more-temps)
-                                 (ignores) (call-args)))))
+                                 (ignores) (call-args)
+                                 more-temps))))
 
   (values))
 
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index f9de3162b..1d5f635dc 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -632,10 +632,15 @@
   ;; be true when REFS and SETS are null, since code can be deleted.
   (ever-used nil :type boolean)
   ;; is it declared dynamic-extent, or truly-dynamic-extent?
-  (dynamic-extent nil :type (member nil t :truly))
+  (extent nil :type (member nil :maybe-dynamic :always-dynamic :indefinite))
   ;; some kind of info used by the back end
   (info nil))
 
+(defun leaf-dynamic-extent (leaf)
+  (let ((extent (leaf-extent leaf)))
+    (unless (member extent '(nil :indefinite))
+      extent)))
+
 ;;; LEAF name operations
 ;;;
 ;;; KLUDGE: wants CLOS..
diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 6148f6762..a2adbcc6b 100644
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -401,7 +401,7 @@
                                    (cond (closure
                                           (setq dx t))
                                          (t
-                                          (setf (leaf-dynamic-extent fun) nil)))))
+                                          (setf (leaf-extent fun) nil)))))
                                (when dx
                                  (setf (lvar-dynamic-extent arg) cleanup)
                                  (real-dx-lvars arg))))))
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index e8a177a17..912b44e48 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -913,3 +913,18 @@
         (return (bar))))))
 (with-test (:name :bug-681092)
   (assert (= 10 (bug-681092))))
+
+;;;; &REST lists should stop DX propagation -- not required by ANSI,
+;;;; but required by sanity.
+
+(declaim (inline rest-stops-dx))
+(defun-with-dx rest-stops-dx (&rest args)
+  (declare (dynamic-extent args))
+  (apply #'opaque-identity args))
+
+(defun-with-dx rest-stops-dx-ok ()
+  (equal '(:foo) (rest-stops-dx (list :foo))))
+
+(with-test (:name :rest-stops-dynamic-extent)
+  (assert (rest-stops-dx-ok)))
+
diff --git a/version.lisp-expr b/version.lisp-expr
index 7794a0f5c..69ee89cad 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.48.20"
+"1.0.48.21"