From edb7acf8d242c0398ec33924e21c85dc54bc768d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 24 May 2011 08:49:45 +0000 Subject: [PATCH] 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. --- NEWS | 4 +++ doc/manual/efficiency.texinfo | 59 ++++++++++++++++++++++++++-------- src/compiler/generic/vm-ir2tran.lisp | 2 +- src/compiler/ir1tran.lisp | 42 +++++++++++++----------- src/compiler/ir1util.lisp | 10 +++--- src/compiler/locall.lisp | 10 +++--- src/compiler/node.lisp | 7 +++- src/compiler/physenvanal.lisp | 2 +- tests/dynamic-extent.impure.lisp | 15 +++++++++ version.lisp-expr | 2 +- 10 files changed, 107 insertions(+), 46 deletions(-) diff --git a/NEWS b/NEWS index a4cdf76..c4046b6 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 6820e77..31fcee0 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 b0a2d3d..a089050 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 81b68f7..db5bf38 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 55df159..e3ef6cf 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 e820d46..b6d52c2 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 f9de316..1d5f635 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 6148f67..a2adbcc 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 e8a177a..912b44e 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 7794a0f..69ee89c 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" -- 1.7.10.4