diff --git a/BUGS b/BUGS index 0dbe1e1dd..b1d99eb18 100644 --- a/BUGS +++ b/BUGS @@ -1805,27 +1805,26 @@ WORKAROUND: 419: stack-allocated indirect closure variables are not popped - (locally (declare (optimize sb-c::stack-allocate-dynamic-extent - sb-c::stack-allocate-value-cells)) (defun bug419 (x) (multiple-value-call #'list (eval '(values 1 2 3)) (let ((x x)) - (declare (dynamic-extent x)) + (declare (sb-int:truly-dynamic-extent x)) (flet ((mget (y) (+ x y)) (mset (z) (incf x z))) (declare (dynamic-extent #'mget #'mset)) - ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))) + ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset))))) (ASSERT (EQUAL (BUG419 42) '(1 2 3 4 5 6))) => failure Note: as of SBCL 1.0.26.29 this bug no longer affects user code, as - SB-C::STACK-ALLOCATE-VALUE-CELLS needs to be explicitly turned on for - that to happen. Proper fix for this bug requires (Nikodemus thinks) - storing the relevant LAMBDA-VARs in a :DYNAMIC-EXTENT cleanup, and - teaching stack analysis how to deal with them. + SB-INT:TRULY-DYNAMIC-EXTENT needs to be used instead of + DYNAMIC-EXTENT for this to happen. Proper fix for this bug requires + (Nikodemus thinks) storing the relevant LAMBDA-VARs in a + :DYNAMIC-EXTENT cleanup, and teaching stack analysis how to deal + with them. 421: READ-CHAR-NO-HANG misbehaviour on Windows Console: diff --git a/NEWS b/NEWS index 3ffa382c1..2c1291e18 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.20 relative to 1.0.19: + * minor incompatible change: OPTIMIZE qualities + SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT, SB-C::STACK-ALLOCATE-VECTOR, + and SB-C::STACK-ALLOCATE-VALUE-CELLS no longer exist. See documentation + and SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT* for details. * bug fix: fixed #427: unused local aliens no longer cause compiler breakage. (reported by Stelian Ionescu, Andy Hefner and Stanislaw Halik) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 7e8962f9c..79840f4c3 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -35,6 +35,7 @@ ( ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; miscellaneous + ("src/code/cross-early" :not-target) ;; This comes early because it's useful for debugging everywhere. ("src/code/show") diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo index 6931ed035..de905ae3a 100644 --- a/doc/manual/efficiency.texinfo +++ b/doc/manual/efficiency.texinfo @@ -3,6 +3,173 @@ @chapter Efficiency @cindex Efficiency +@menu +* Dynamic-extent allocation:: +* Modular arithmetic:: +* Miscellaneous Efficiency Issues:: +@end menu + +@node Dynamic-extent allocation +@comment node-name, next, previous, up +@section Dynamic-extent allocation +@cindex Dynamic-extent declaration + +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. + +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 + +There are many cases when @code{dynamic-extent} declarations could be +useful. At present, SBCL implements stack allocation for + +@itemize + +@item +@code{&rest} lists, when these are declared @code{dynamic-extent}. + +@item +@code{cons}, @code{list} and @code{list*}, when the result is bound to +a variable declared @code{dynamic-extent}. + +@item +simple forms of @code{make-array}, whose result is bound to a variable +declared @code{dynamic-extent}: stack allocation is possible only if +the resulting array is one-dimensional, and the call has no keyword +arguments with the exception of @code{:element-type}. + +@strong{Note}: stack space is limited, so allocation of a large vector +may cause stack overflow. For this reason potentially large vectors, +which might circumvent stack overflow detection, are stack allocated +only in zero @code{safety} policies. + +@item +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}. + +@item +user-defined structures when the structure constructor defined using +@code{defstruct} has been declared @code{inline} and the result of the +call to the constructor is bound to a variable declared +@code{dynamic-extent}. + +@strong{Note:} structures with ``raw'' slots can currently be +stack-allocated only on x86 and x86-64. + +@item +all of the above when they appear as initial parts if another +stack-allocated object. + +@end itemize + +Examples: + +@lisp +;;; Declaiming a structure constructor inline before definition makes +;;; stack allocation possible. +(declaim (inline make-thing)) +(defstruct thing obj next) + +;;; Stack allocation of various objects bound to DYNAMIC-EXTENT +;;; variables. +(let* ((list (list 1 2 3)) + (nested (cons (list 1 2) (list* 3 4 (list 5)))) + (vector (make-array 3 :element-type 'single-float)) + (thing (make-thing :obj list + :next (make-thing :obj (make-array 3))))) + (declare (dynamic-extent list nested vector thing)) + ...) + +;;; Stack allocation of arguments to a local function is equivalent +;;; to stack allocation of local variable values. +(flet ((f (x) + (declare (dynamic-extent x)) + ...)) + ... + (f (list 1 2 3)) + (f (cons (cons 1 2) (cons 3 4))) + ...) + +;;; Stack allocation of &REST lists +(defun foo (&rest args) + (declare (dynamic-extent args)) + ...) +@end lisp + +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}; + +@item +Automatic detection of the common idiom of calling quantifiers with a +closure, even when the closure is not declared @code{dynamic-extent}. + +@end itemize + +@node Modular arithmetic +@comment node-name, next, previous, up +@section Modular arithmetic +@cindex Modular arithmetic +@cindex Arithmetic, modular +@cindex Arithmetic, hardware + +Some numeric functions have a property: @var{N} lower bits of the +result depend only on @var{N} lower bits of (all or some) +arguments. If the compiler sees an expression of form @code{(logand +@var{exp} @var{mask})}, where @var{exp} is a tree of such ``good'' +functions and @var{mask} is known to be of type @code{(unsigned-byte +@var{w})}, where @var{w} is a ``good'' width, all intermediate results +will be cut to @var{w} bits (but it is not done for variables and +constants!). This often results in an ability to use simple machine +instructions for the functions. + +Consider an example. + +@lisp +(defun i (x y) + (declare (type (unsigned-byte 32) x y)) + (ldb (byte 32 0) (logxor x (lognot y)))) +@end lisp + +The result of @code{(lognot y)} will be negative and of type +@code{(signed-byte 33)}, so a naive implementation on a 32-bit +platform is unable to use 32-bit arithmetic here. But modular +arithmetic optimizer is able to do it: because the result is cut down +to 32 bits, the compiler will replace @code{logxor} and @code{lognot} +with versions cutting results to 32 bits, and because terminals +(here---expressions @code{x} and @code{y}) are also of type +@code{(unsigned-byte 32)}, 32-bit machine arithmetic can be used. + +As of SBCL 0.8.5 ``good'' functions are @code{+}, @code{-}; +@code{logand}, @code{logior}, @code{logxor}, @code{lognot} and their +combinations; and @code{ash} with the positive second +argument. ``Good'' widths are 32 on HPPA, MIPS, PPC, Sparc and x86 and +64 on Alpha. While it is possible to support smaller widths as well, +currently this is not implemented. + +@node Miscellaneous Efficiency Issues +@comment node-name, next, previous, up +@section Miscellaneous Efficiency Issues + FIXME: The material in the CMUCL manual about getting good performance from the compiler should be reviewed, reformatted in Texinfo, lightly edited for SBCL, and substituted into this @@ -30,7 +197,7 @@ Besides this information from the CMUCL manual, there are a few other points to keep in mind. @itemize - + @item The CMUCL manual doesn't seem to state it explicitly, but Python has a mental block about type inference when assignment is involved. Python @@ -48,33 +215,29 @@ explicit type declarations.) @c - + @item Since the time the CMUCL manual was written, CMUCL (and thus SBCL) has gotten a generational garbage collector. This means that there are some efficiency implications of various patterns of memory usage which aren't discussed in the CMUCL manual. (Some new material should be written about this.) - + @item SBCL has some important known efficiency problems. Perhaps the most important are - + @itemize @minus - -@item -There is only limited support for the ANSI @code{dynamic-extent} -declaration. @xref{Dynamic-extent allocation}. - + @item The garbage collector is not particularly efficient, at least on platforms without the generational collector (as of SBCL 0.8.9, all except x86). - + @item Various aspects of the PCL implementation of CLOS are more inefficient than necessary. - + @end itemize @end itemize @@ -90,11 +253,11 @@ the appropriate case hasn't been hand-coded. Some cases where no such hand-coding has been done as of SBCL version 0.6.3 include @itemize - + @item @code{(reduce #'f x)} where the type of @code{x} is known at compile time - + @item various bit vector operations, e.g. @code{(position 0 some-bit-vector)} @@ -117,162 +280,3 @@ patch to the compiler and submitting it for inclusion in the main sources. Such code is often reasonably straightforward to write; search the sources for the string ``@code{deftransform}'' to find many examples (some straightforward, some less so). - -@menu -* Dynamic-extent allocation:: -* Modular arithmetic:: -@end menu - -@node Dynamic-extent allocation -@comment node-name, next, previous, up -@section Dynamic-extent allocation -@cindex Dynamic-extent declaration - -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; if the -constraints 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. - -As a consequence of this, the condition for performing stack -allocation is stringent: either of the @code{speed} or @code{space} -optimization qualities must be higher than the maximum of -@code{safety} and @code{debug} at the point of the allocation. For -example: - -@lisp -(locally - (declare (optimize speed (safety 1) (debug 1))) - (defun foo (&rest rest) - (declare (dynamic-extent rest)) - (length rest))) -@end lisp - -Here the @code{&rest} list will be allocated on the stack. Note that -it would not be in the following situation: - -@lisp -(defun foo (&rest rest) - (declare (optimize speed (safety 1) (debug 1))) - (declare (dynamic-extent rest)) - (length rest)) -@end lisp - -because both the allocation of the @code{&rest} list and the variable -binding are outside the scope of the @code{optimize} declaration. - -There are many cases when @code{dynamic-extent} declarations could be -useful. At present, SBCL implements - -@itemize - -@item -Stack allocation of @code{&rest} lists, where these are declared -@code{dynamic-extent}. - -@item -Stack allocation of @code{list} and @code{list*}, whose result is -bound to a variable, declared @code{dynamic-extent}, such as - -@lisp -(let ((list (list 1 2 3))) - (declare (dynamic-extent list) - ...)) -@end lisp - -or - -@lisp -(flet ((f (x) - (declare (dynamic-extent x)) - ...)) - ... - (f (list 1 2 3)) - ...) -@end lisp - -@item -Stack allocation of simple forms of @code{make-array}, whose result is -bound to a variable, declared @code{dynamic-extent}. The resulting -array should be one-dimensional, the only allowed keyword argument is -@code{:element-type}. - -Notice, that stack space is limited, so allocation of a large vector -may cause stack overflow and abnormal termination of the SBCL process. - -@item -Stack allocation of closures, defined with @code{flet} or -@code{labels} with a bound declaration @code{dynamic-extent}. -Closed-over variables, which are assigned (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}. - -@end itemize - -Future plans include - -@itemize - -@item -Stack allocation of closures, where these are declared -@code{dynamic-extent}; - -@item -Stack allocation of @code{list}, @code{list*} and @code{cons} -(including following chains during initialization, and also for -binding mutation), where the allocation is 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}; - -@item -Automatic detection of the common idiom of calling quantifiers with a -closure, even when the closure is not declared @code{dynamic-extent}. - -@end itemize - -@node Modular arithmetic -@comment node-name, next, previous, up -@section Modular arithmetic -@cindex Modular arithmetic -@cindex Arithmetic, modular -@cindex Arithmetic, hardware - -Some numeric functions have a property: @var{N} lower bits of the -result depend only on @var{N} lower bits of (all or some) -arguments. If the compiler sees an expression of form @code{(logand -@var{exp} @var{mask})}, where @var{exp} is a tree of such ``good'' -functions and @var{mask} is known to be of type @code{(unsigned-byte -@var{w})}, where @var{w} is a ``good'' width, all intermediate results -will be cut to @var{w} bits (but it is not done for variables and -constants!). This often results in an ability to use simple machine -instructions for the functions. - -Consider an example. - -@lisp -(defun i (x y) - (declare (type (unsigned-byte 32) x y)) - (ldb (byte 32 0) (logxor x (lognot y)))) -@end lisp - -The result of @code{(lognot y)} will be negative and of type -@code{(signed-byte 33)}, so a naive implementation on a 32-bit -platform is unable to use 32-bit arithmetic here. But modular -arithmetic optimizer is able to do it: because the result is cut down -to 32 bits, the compiler will replace @code{logxor} and @code{lognot} -with versions cutting results to 32 bits, and because terminals -(here---expressions @code{x} and @code{y}) are also of type -@code{(unsigned-byte 32)}, 32-bit machine arithmetic can be used. - -As of SBCL 0.8.5 ``good'' functions are @code{+}, @code{-}; -@code{logand}, @code{logior}, @code{logxor}, @code{lognot} and their -combinations; and @code{ash} with the positive second -argument. ``Good'' widths are 32 on HPPA, MIPS, PPC, Sparc and x86 and -64 on Alpha. While it is possible to support smaller widths as well, -currently this is not implemented. diff --git a/make-host-2.lisp b/make-host-2.lisp index 8bc96bf36..0258b1943 100644 --- a/make-host-2.lisp +++ b/make-host-2.lisp @@ -27,9 +27,7 @@ ;; sbcl-internal optimization declarations: ;; ;; never insert stepper conditions - (sb!c:insert-step-conditions 0) - ;; always stack-allocate if requested - (sb!c::stack-allocate-dynamic-extent 3))))) + (sb!c:insert-step-conditions 0))))) (compile 'proclaim-target-optimization) (defun in-target-cross-compilation-mode (fun) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 72388077d..0a3357c13 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -584,6 +584,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*GC-RUN-TIME*" "PURIFY" + ;; Stack allocation control + "*STACK-ALLOCATE-DYNAMIC-EXTENT*" + ;; Customizing printing of compiler and debugger messages "*COMPILER-PRINT-VARIABLE-ALIST*" "*DEBUG-PRINT-VARIABLE-ALIST*" @@ -800,6 +803,9 @@ possibly temporariliy, because it might be used internally." "FP-ZERO-P" "NEG-FP-ZERO" + ;; Stack allocation without any questions asked + "TRULY-DYNAMIC-EXTENT" + ;; generic set implementation "ADD-TO-XSET" "ALLOC-XSET" diff --git a/src/code/array.lisp b/src/code/array.lisp index c0f673bd1..a7f1940da 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -527,17 +527,17 @@ of specialized arrays is supported." t)) (defun array-row-major-index (array &rest subscripts) - (declare (dynamic-extent subscripts)) + (declare (truly-dynamic-extent subscripts)) (%array-row-major-index array subscripts)) (defun aref (array &rest subscripts) #!+sb-doc "Return the element of the ARRAY specified by the SUBSCRIPTS." - (declare (dynamic-extent subscripts)) + (declare (truly-dynamic-extent subscripts)) (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) - (declare (dynamic-extent stuff)) + (declare (truly-dynamic-extent stuff)) (let ((subscripts (butlast stuff)) (new-value (car (last stuff)))) (setf (row-major-aref array (%array-row-major-index array subscripts)) @@ -570,7 +570,7 @@ of specialized arrays is supported." #!-sb-fluid (declaim (inline (setf aref))) (defun (setf aref) (new-value array &rest subscripts) - (declare (dynamic-extent subscripts)) + (declare (truly-dynamic-extent subscripts)) (declare (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value)) diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 5b3cd9c78..d9c8c0083 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -208,7 +208,7 @@ ;; whether there's still an optimizer bug, and fix it if so, and ;; then make these INLINE. `(defun ,b-name (&rest ,args) - (declare (dynamic-extent ,args)) + (declare (truly-dynamic-extent ,args)) (apply #',name ,args))))) (def backq-list list) (def backq-list* list*) diff --git a/src/code/cross-early.lisp b/src/code/cross-early.lisp new file mode 100644 index 000000000..c22523a9f --- /dev/null +++ b/src/code/cross-early.lisp @@ -0,0 +1,14 @@ +;;;; cross-compile-time-only stuff that is needed before anything else + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!IMPL") + +(declaim (declaration truly-dynamic-extent)) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index ddd6355f9..232802fce 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -573,31 +573,27 @@ evaluated as a PROGN." (let* ((local-funs nil) (mapped-bindings (mapcar (lambda (binding) (destructuring-bind (type handler) binding - (let (lambda-form) + (let ((lambda-form handler)) (if (and (consp handler) - (or (prog1 (eq 'lambda (car handler)) - (setf lambda-form handler)) + (or (eq 'lambda (car handler)) (and (eq 'function (car handler)) (consp (cdr handler)) - (consp (cadr handler)) - (prog1 (eq 'lambda (caadr handler)) - (setf lambda-form (cadr handler))))) - ;; KLUDGE: DX-FLET doesn't handle non-required arguments yet. - (not (intersection (second lambda-form) sb!xc:lambda-list-keywords))) + (let ((x (second handler))) + (and (consp x) + (eq 'lambda (car x)) + (setf lambda-form x)))))) (let ((name (gensym "LAMBDA"))) (push `(,name ,@(cdr lambda-form)) local-funs) (list type `(function ,name))) binding)))) - bindings)) - (form-fun (gensym "FORM-FUN"))) - `(dx-flet (,@(reverse local-funs) - (,form-fun () (progn ,form))) + bindings))) + `(dx-flet (,@(reverse local-funs)) (let ((*handler-clusters* (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) mapped-bindings)) *handler-clusters*))) - (declare (dynamic-extent *handler-clusters*)) - (,form-fun))))) + (declare (truly-dynamic-extent *handler-clusters*)) + (progn ,form))))) (defmacro-mundanely handler-bind (bindings &body forms) #!+sb-doc diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 61794ec80..e004f73a7 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1225,53 +1225,19 @@ to :INTERPRET, an interpreter will be used.") ;;; Helper for making the DX closure allocation in macros expanding ;;; to CALL-WITH-FOO less ugly. -;;; -;;; This expands to something like -;;; -;;; (flet ((foo (...) )) -;;; (declare (optimize stack-allocate-dynamic-extent)) -;;; (flet ((foo (...) -;;; (foo ...)) -;;; (declare (dynamic-extent #'foo)) -;;; ))) -;;; -;;; The outer FLETs are inlined into the inner ones, and the inner ones -;;; are DX-allocated. The double-fletting is done to keep the bodies of -;;; the functions in an environment with correct policy: we don't want -;;; to force DX allocation in their bodies, which would be bad eg. -;;; in safe code. (defmacro dx-flet (functions &body forms) - (let ((names (mapcar #'car functions))) - `(flet ,functions - #-sb-xc-host - (declare (optimize sb!c::stack-allocate-dynamic-extent)) - (flet ,(mapcar - (lambda (f) - (let ((args (cadr f)) - (name (car f))) - (when (intersection args sb!xc:lambda-list-keywords) - ;; No fundamental reason not to support them, but we - ;; don't currently need them here. - (error "Non-required arguments not implemented for DX-FLET.")) - `(,name ,args - (,name ,@args)))) - functions) - (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names))) - ,@forms)))) - -;;; Another similar one -- but actually touches the policy of the body, -;;; so take care with this one... + `(flet ,functions + (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent + ,@(mapcar (lambda (func) `(function ,(car func))) functions))) + ,@forms)) + +;;; Another similar one. (defmacro dx-let (bindings &body forms) - `(locally - (declare (optimize #-sb-xc-host sb!c::stack-allocate-dynamic-extent - #-sb-xc-host sb!c::stack-allocate-value-cells)) - (let ,bindings - (declare (dynamic-extent ,@(mapcar (lambda (bind) - (if (consp bind) - (car bind) - bind)) - bindings))) - ,@forms))) + `(let ,bindings + (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent + ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind)) + bindings))) + ,@forms)) (in-package "SB!KERNEL") diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 53de4081e..9529f2979 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -295,7 +295,7 @@ (defun values (&rest values) #!+sb-doc "Return all arguments, in order, as values." - (declare (dynamic-extent values)) + (declare (truly-dynamic-extent values)) (values-list values)) (defun values-list (list) diff --git a/src/code/list.lisp b/src/code/list.lisp index d18d3a595..46cbb32c7 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -341,7 +341,7 @@ (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" - (declare (dynamic-extent lists) (optimize speed)) + (declare (truly-dynamic-extent lists) (optimize speed)) (labels ((fail (object) (error 'type-error :datum object @@ -471,7 +471,7 @@ (defun nconc (&rest lists) #!+sb-doc "Concatenates the lists given as arguments (by changing them)" - (declare (dynamic-extent lists) (optimize speed)) + (declare (truly-dynamic-extent lists) (optimize speed)) (flet ((fail (object) (error 'type-error :datum object diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 6de67f281..9571988d6 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -742,7 +742,7 @@ (defun = (number &rest more-numbers) #!+sb-doc "Return T if all of its arguments are numerically equal, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (the number number) (do ((nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -752,7 +752,7 @@ (defun /= (number &rest more-numbers) #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((head (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -766,7 +766,7 @@ (defun < (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly increasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -776,7 +776,7 @@ (defun > (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly decreasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -786,7 +786,7 @@ (defun <= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-decreasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -796,7 +796,7 @@ (defun >= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-increasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -807,7 +807,7 @@ #!+sb-doc "Return the greatest of its arguments; among EQUALP greatest, return the first." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -819,7 +819,7 @@ the first." #!+sb-doc "Return the least of its arguments; among EQUALP least, return the first." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index b6b2a216f..ddfd722b9 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -145,7 +145,7 @@ (values ;; ENCAPSULATION-FUN (lambda (&more arg-context arg-count) - (declare (optimize speed safety sb-c::stack-allocate-dynamic-extent)) + (declare (optimize speed safety)) ;; Make sure that we're not recursing infinitely. (when (boundp '*computing-profiling-data-for*) (unprofile-all) ; to avoid further recursion diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 7cf17f4c9..c76c58673 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -673,7 +673,7 @@ #!+sb-doc "The target sequence is destructively modified by copying successive elements into it from the source sequence." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind ;; these things here so that legacy code gets the names it's @@ -961,9 +961,9 @@ (type list sequences)) (let ((result nil)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (push (apply fun args) result))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) (nreverse result))) (defun %map-to-vector (output-type-spec fun sequences) @@ -971,19 +971,19 @@ (type list sequences)) (let ((min-len 0)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore args)) (incf min-len))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) (let ((result (make-sequence output-type-spec min-len)) (i 0)) (declare (type (simple-array * (*)) result)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (setf (aref result i) (apply fun args)) (incf i))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) result))) (defun %map-to-sequence (result-type fun sequences) @@ -991,20 +991,20 @@ (type list sequences)) (let ((min-len 0)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore args)) (incf min-len))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) (let ((result (make-sequence result-type min-len))) (multiple-value-bind (state limit from-end step endp elt setelt) (sb!sequence:make-sequence-iterator result) (declare (ignore limit endp elt)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (funcall setelt (apply fun args) result state) (setq state (funcall step result state from-end)))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences))) result))) @@ -1234,7 +1234,7 @@ (define-sequence-traverser reduce (function sequence &rest args &key key from-end start end (initial-value nil ivp)) (declare (type index start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((start start) (end (or end length))) (declare (type index start end)) @@ -1377,7 +1377,7 @@ "Return a sequence formed by destructively removing the specified ITEM from the given SEQUENCE." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1415,7 +1415,7 @@ "Return a sequence formed by destructively removing the elements satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1453,7 +1453,7 @@ "Return a sequence formed by destructively removing the elements not satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1602,7 +1602,7 @@ "Return a copy of SEQUENCE with elements satisfying the test (default is EQL) with ITEM removed." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1619,7 +1619,7 @@ #!+sb-doc "Return a copy of sequence with elements satisfying PREDICATE removed." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1636,7 +1636,7 @@ #!+sb-doc "Return a copy of sequence with elements not satisfying PREDICATE removed." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1788,7 +1788,7 @@ The :TEST-NOT argument is deprecated." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (if sequence (list-remove-duplicates* sequence test test-not @@ -1861,7 +1861,7 @@ given sequence, is returned. The :TEST-NOT argument is deprecated." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (if sequence (list-delete-duplicates* sequence test test-not @@ -1981,7 +1981,7 @@ "Return a sequence of the same kind as SEQUENCE with the same elements, except that all elements equal to OLD are replaced with NEW." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (subst-dispatch 'normal))) @@ -1993,7 +1993,7 @@ #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying the PRED are replaced with NEW." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (fixnum start)) (let ((end (or end length)) (test predicate) @@ -2007,7 +2007,7 @@ #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying the PRED are replaced with NEW." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (fixnum start)) (let ((end (or end length)) (test predicate) @@ -2026,7 +2026,7 @@ except that all elements equal to OLD are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (seq-dispatch sequence (if from-end @@ -2079,7 +2079,7 @@ except that all elements satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (fixnum end)) (seq-dispatch sequence @@ -2121,7 +2121,7 @@ except that all elements not satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (fixnum end)) (seq-dispatch sequence @@ -2212,7 +2212,7 @@ (defun find (item sequence &rest args &key from-end (start 0) end key test test-not) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 0 (%find-position item sequence from-end start end @@ -2225,7 +2225,7 @@ (apply #'sb!sequence:find item sequence args))) (defun position (item sequence &rest args &key from-end (start 0) end key test test-not) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 1 (%find-position item sequence from-end start end @@ -2238,7 +2238,7 @@ (apply #'sb!sequence:position item sequence args))) (defun find-if (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 0 (%find-position-if (%coerce-callable-to-fun predicate) @@ -2251,7 +2251,7 @@ (apply #'sb!sequence:find-if predicate sequence args))) (defun position-if (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 1 (%find-position-if (%coerce-callable-to-fun predicate) @@ -2265,7 +2265,7 @@ (defun find-if-not (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 0 (%find-position-if-not (%coerce-callable-to-fun predicate) @@ -2278,7 +2278,7 @@ (apply #'sb!sequence:find-if-not predicate sequence args))) (defun position-if-not (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 1 (%find-position-if-not (%coerce-callable-to-fun predicate) @@ -2327,7 +2327,7 @@ #!+sb-doc "Return the number of elements in SEQUENCE satisfying PRED(el)." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length)) (pred (%coerce-callable-to-fun pred))) (declare (type index end)) @@ -2345,7 +2345,7 @@ #!+sb-doc "Return the number of elements in SEQUENCE not satisfying TEST(el)." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length)) (pred (%coerce-callable-to-fun pred))) (declare (type index end)) @@ -2365,7 +2365,7 @@ "Return the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (when (and test-p test-not-p) ;; ANSI Common Lisp has left the behavior in this situation unspecified. ;; (CLHS 17.2.1) @@ -2473,7 +2473,7 @@ :FROM-END argument is given, then one plus the index of the rightmost position in which the sequences differ is returned." (declare (fixnum start1 start2)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let* ((end1 (or end1 length1)) (end2 (or end2 length2))) (declare (type index end1 end2)) @@ -2583,7 +2583,7 @@ (sequence1 sequence2 &rest args &key from-end test test-not start1 end1 start2 end2 key) (declare (fixnum start1 start2)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end1 (or end1 length1)) (end2 (or end2 length2))) (seq-dispatch sequence2 diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 1d6949f4c..076a9b9e3 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -23,7 +23,7 @@ #!+sb-doc "Destructively sort SEQUENCE. PREDICATE should return non-NIL if ARG1 is to precede ARG2." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((predicate-fun (%coerce-callable-to-fun predicate))) (seq-dispatch sequence (stable-sort-list sequence @@ -43,7 +43,7 @@ #!+sb-doc "Destructively sort SEQUENCE. PREDICATE should return non-NIL if ARG1 is to precede ARG2." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((predicate-fun (%coerce-callable-to-fun predicate))) (seq-dispatch sequence (stable-sort-list sequence diff --git a/src/code/step.lisp b/src/code/step.lisp index 66a83131b..43a480138 100644 --- a/src/code/step.lisp +++ b/src/code/step.lisp @@ -41,7 +41,7 @@ t))) (defun step-values (form &rest values) - (declare (dynamic-extent values)) + (declare (truly-dynamic-extent values)) (signal 'step-values-condition :form form :result values) (values-list values)) diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index f055e416e..e4b87c355 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -372,7 +372,7 @@ (defun char= (character &rest more-characters) #!+sb-doc "Return T if all of the arguments are the same character." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (dolist (c more-characters t) (declare (type character c)) (unless (eq c character) (return nil)))) @@ -380,7 +380,7 @@ (defun char/= (character &rest more-characters) #!+sb-doc "Return T if no two of the arguments are the same character." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((head character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -392,7 +392,7 @@ (defun char< (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly increasing alphabetic order." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -403,7 +403,7 @@ (defun char> (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly decreasing alphabetic order." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -414,7 +414,7 @@ (defun char<= (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-decreasing alphabetic order." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -425,7 +425,7 @@ (defun char>= (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-increasing alphabetic order." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -450,7 +450,7 @@ #!+sb-doc "Return T if all of the arguments are the same character. Font, bits, and case are ignored." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do ((clist more-characters (cdr clist))) ((null clist) t) (unless (two-arg-char-equal (car clist) character) @@ -463,7 +463,7 @@ #!+sb-doc "Return T if no two of the arguments are the same character. Font, bits, and case are ignored." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((head character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -480,7 +480,7 @@ #!+sb-doc "Return T if the arguments are in strictly increasing alphabetic order. Font, bits, and case are ignored." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -494,7 +494,7 @@ #!+sb-doc "Return T if the arguments are in strictly decreasing alphabetic order. Font, bits, and case are ignored." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -508,7 +508,7 @@ #!+sb-doc "Return T if the arguments are in strictly non-decreasing alphabetic order. Font, bits, and case are ignored." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) @@ -522,7 +522,7 @@ #!+sb-doc "Return T if the arguments are in strictly non-increasing alphabetic order. Font, bits, and case are ignored." - (declare (dynamic-extent more-characters)) + (declare (truly-dynamic-extent more-characters)) (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 9bb1506d4..845c64708 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -56,7 +56,6 @@ restarts associated with CONDITION (or with no condition) will be returned." (setq other (append (cdr alist) other)))) (collect ((res)) (let ((stack *restart-test-stack*)) - (declare (optimize sb!c::stack-allocate-dynamic-extent)) (dolist (restart-cluster *restart-clusters*) (dolist (restart restart-cluster) (when (and (or (not condition) @@ -69,7 +68,7 @@ restarts associated with CONDITION (or with no condition) will be returned." ;; duraction of the test call. (not (memq restart stack)) (let ((*restart-test-stack* (cons restart stack))) - (declare (dynamic-extent *restart-test-stack*)) + (declare (truly-dynamic-extent *restart-test-stack*)) (funcall (restart-test-function restart) condition))) (res restart))))) (res)))) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 95710d9dd..8c0f4868c 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -92,7 +92,7 @@ (declare (type (or function fixnum (member :default :ignore)) handler)) (/show0 "enable-interrupt") (flet ((run-handler (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (in-interruption () (apply handler args)))) (without-gcing diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp index 878fd58d6..96621a355 100644 --- a/src/compiler/alpha/alloc.lisp +++ b/src/compiler/alpha/alloc.lisp @@ -12,11 +12,6 @@ (in-package "SB!VM") ;;;; LIST and LIST* -(defoptimizer (list stack-allocate-result) ((&rest args)) - (not (null args))) -(defoptimizer (list* stack-allocate-result) ((&rest args)) - (not (null (rest args)))) - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:scs (descriptor-reg) :type list) ptr) diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index d9ccfeef4..467d67043 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -1110,9 +1110,6 @@ default-value-8 (define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) ;;; Turn &MORE arg (context, count) into a list. -(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) - t) - (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index e04ad0344..2c41074f7 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -111,6 +111,13 @@ (defvar *warnings-p*) (defvar *lambda-conversions*) +(defvar *stack-allocate-dynamic-extent* t + "If true (the default), the compiler respects DYNAMIC-EXTENT declarations +and stack allocates otherwise inaccessible parts of the object whenever +possible. Potentially long (over one page in size) vectors are, however, not +stack allocated except in zero SAFETY code, as such a vector could overflow +the stack without triggering overflow protection.") + ;;; This lock is seized in the compiler, and related areas: the ;;; compiler is not presently thread-safe (defvar *big-compiler-lock* diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 4544f51c8..de0299ab2 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -13,7 +13,8 @@ sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag nil) -(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args)) +(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx) + (declare (ignore node dx)) t) (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) @@ -170,3 +171,57 @@ (lvar-tn node block symbol) value-tn) (move-lvar-result node block (list value-tn) (node-lvar node)))))))) + +;;; Stack allocation optimizers per platform support +;;; +;;; Platforms with stack-allocatable vectors +#!+(or x86 x86-64) +(progn + (defoptimizer (allocate-vector stack-allocate-result) + ((type length words) node dx) + (or (eq dx :truly) + (zerop (policy node safety)) + ;; a vector object should fit in one page -- otherwise it might go past + ;; stack guard pages. + (values-subtypep (lvar-derived-type words) + (load-time-value + (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size* + sb!vm:n-word-bytes) + sb!vm:vector-data-offset))))))) + + (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) + (let ((args (basic-combination-args call)) + (template (template-or-lose (if (awhen (node-lvar call) + (lvar-dynamic-extent it)) + 'sb!vm::allocate-vector-on-stack + 'sb!vm::allocate-vector-on-heap)))) + (dolist (arg args) + (setf (lvar-info arg) + (make-ir2-lvar (primitive-type (lvar-type arg))))) + (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) + (ltn-default-call call) + (return-from allocate-vector-ltn-annotate-optimizer (values))) + (setf (basic-combination-info call) template) + (setf (node-tail-p call) nil) + + (dolist (arg args) + (annotate-1-value-lvar arg))))) + +;;; ...lists +#!+(or alpha mips ppc sparc x86 x86-64) +(progn + (defoptimizer (list stack-allocate-result) ((&rest args) node dx) + (declare (ignore node dx)) + (not (null args))) + (defoptimizer (list* stack-allocate-result) ((&rest args) node dx) + (declare (ignore node dx)) + (not (null (rest args)))) + (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx) + (declare (ignore node dx)) + t)) + +;;; ...conses +#!+(or x86 x86-64) +(defoptimizer (cons stack-allocate-result) ((&rest args) node dx) + (declare (ignore node dx)) + t) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 2497c0689..e78d86b14 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1318,54 +1318,59 @@ (setf (lambda-var-ignorep var) t))))) (values)) -(defun process-dx-decl (names vars fvars) +(defun process-dx-decl (names vars fvars kind) (flet ((maybe-notify (control &rest args) (when (policy *lexenv* (> speed inhibit-warnings)) (apply #'compiler-notify control args)))) - (if (policy *lexenv* (= stack-allocate-dynamic-extent 3)) - (dolist (name names) - (cond - ((symbolp name) - (let* ((bound-var (find-in-bindings vars name)) - (var (or bound-var - (lexenv-find name vars) - (find-free-var name)))) - (etypecase var - (leaf - (if bound-var - (setf (leaf-dynamic-extent var) t) - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - name))) - (cons - (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) - (heap-alien-info - (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" - name))))) - ((and (consp name) - (eq (car name) 'function) - (null (cddr name)) - (valid-function-name-p (cadr name))) - (let* ((fname (cadr name)) - (bound-fun (find fname fvars - :key #'leaf-source-name - :test #'equal))) - (etypecase bound-fun - (leaf - #!+stack-allocatable-closures - (setf (leaf-dynamic-extent bound-fun) t) - #!-stack-allocatable-closures - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ + (let ((dx (cond ((eq 'truly-dynamic-extent kind) + :truly) + ((and (eq 'dynamic-extent kind) + *stack-allocate-dynamic-extent*) + t)))) + (if dx + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) dx) + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" + name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal))) + (etypecase bound-fun + (leaf + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) dx) + #!-stack-allocatable-closures + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ (not supported on this platform)." fname)) - (cons - (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) - (null - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - fname))))) - (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) - (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) + (null + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + fname))))) + (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))) ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think. @@ -1418,8 +1423,8 @@ (car types) `(values ,@types))))) res)) - (dynamic-extent - (process-dx-decl (cdr spec) vars fvars) + ((dynamic-extent truly-dynamic-extent) + (process-dx-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 695a9b6c6..2beb88452 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -391,37 +391,35 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) -(declaim (ftype (sfunction (node &optional (or null component)) boolean) - use-good-for-dx-p)) -(declaim (ftype (sfunction (lvar &optional (or null component)) boolean) - lvar-good-for-dx-p)) -(defun use-good-for-dx-p (use &optional component) +(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 PRINCIPAL-LVAR is always in the same component - ;; as the original one. It would be either good to have an - ;; explanation of why casts don't point across components, or an - ;; explanation of when they do it. ...in the meanwhile AVER that - ;; our assumption holds true. + ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the + ;; PRINCIPAL-LVAR is always in the same component as the original one. It + ;; would be either good to have an explanation of why casts don't point + ;; across components, or an explanation of when they do it. ...in the + ;; meanwhile AVER that our assumption holds true. (aver (or (not component) (eq component (node-component use)))) (or (and (combination-p use) (eq (combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (combination-fun-info use)) - (funcall it use)) + (awhen (fun-info-stack-allocate-result (combination-fun-info use)) + (funcall it use dx)) t) (and (cast-p use) (not (cast-type-check use)) - (lvar-good-for-dx-p (cast-value use) component) + (lvar-good-for-dx-p (cast-value use) dx component) t))) -(defun lvar-good-for-dx-p (lvar &optional component) +(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 component)) + (use-good-for-dx-p use dx component)) uses) - (use-good-for-dx-p uses component)))) + (use-good-for-dx-p uses dx component)))) (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 947389feb..ca486d1a3 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -58,9 +58,8 @@ (event make-value-cell-event node) (let ((leaf (tn-leaf res))) (vop make-value-cell node block value - (and leaf (leaf-dynamic-extent leaf) - ;; FIXME: See bug 419 - (policy node (> stack-allocate-value-cells 1))) + ;; FIXME: See bug 419 + (and leaf (eq :truly (leaf-dynamic-extent leaf))) res))) ;;;; leaf reference diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index a65bae30a..fe1dea83f 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -43,7 +43,7 @@ (setf (car args) nil))) (values)) -(defun handle-nested-dynamic-extent-lvars (lvar) +(defun handle-nested-dynamic-extent-lvars (dx lvar) (let ((uses (lvar-uses lvar))) ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. ;; Uses of mupltiple-use LVARs already end their blocks, so we just need @@ -55,26 +55,26 @@ (flet ((recurse (use) (etypecase use (cast - (handle-nested-dynamic-extent-lvars (cast-value use))) + (handle-nested-dynamic-extent-lvars dx (cast-value use))) (combination (loop for arg in (combination-args use) - when (lvar-good-for-dx-p arg) - append (handle-nested-dynamic-extent-lvars arg)))))) + when (lvar-good-for-dx-p arg dx) + append (handle-nested-dynamic-extent-lvars dx arg)))))) (cons lvar (if (listp uses) (loop for use in uses - when (use-good-for-dx-p use) + when (use-good-for-dx-p use dx) nconc (recurse use)) - (when (use-good-for-dx-p uses) + (when (use-good-for-dx-p uses dx) (recurse uses))))))) (defun recognize-dynamic-extent-lvars (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (basic-combination-args call) - and var in (lambda-vars fun) - when (and arg (lambda-var-dynamic-extent var) - (not (lvar-dynamic-extent arg))) - append (handle-nested-dynamic-extent-lvars arg) into dx-lvars + for var in (lambda-vars fun) + for dx = (lambda-var-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 ;; Stack analysis requires that the CALL ends the block, so ;; that MAP-BLOCK-NLXES sees the cleanup we insert here. diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index 7b0c3433e..fdca339c5 100644 --- a/src/compiler/mips/alloc.lisp +++ b/src/compiler/mips/alloc.lisp @@ -12,11 +12,6 @@ (in-package "SB!VM") ;;;; LIST and LIST* -(defoptimizer (list stack-allocate-result) ((&rest args)) - (not (null args))) -(defoptimizer (list* stack-allocate-result) ((&rest args)) - (not (null (rest args)))) - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:scs (descriptor-reg) :type list) ptr) diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp index 578da61c2..7ed79a642 100644 --- a/src/compiler/mips/call.lisp +++ b/src/compiler/mips/call.lisp @@ -1150,9 +1150,6 @@ default-value-8 (define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) ;;; Turn more arg (context, count) into a list. -(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) - t) - (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 6420c6231..550c1c9d1 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -634,8 +634,8 @@ ;; true if there was ever a REF or SET node for this leaf. This may ;; be true when REFS and SETS are null, since code can be deleted. (ever-used nil :type boolean) - ;; is it declared dynamic-extent? - (dynamic-extent nil :type boolean) + ;; is it declared dynamic-extent, or truly-dynamic-extent? + (dynamic-extent nil :type (member nil t :truly)) ;; some kind of info used by the back end (info nil)) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index ff9fc4285..e006827a5 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -334,7 +334,7 @@ (loop for what in (cleanup-info cleanup) do (etypecase what (lvar - (if (lvar-good-for-dx-p what component) + (if (lvar-good-for-dx-p what t component) (let ((real (principal-lvar what))) (setf (lvar-dynamic-extent real) cleanup) (real-dx-lvars real)) diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp index 0ab60a1cc..55e5de325 100644 --- a/src/compiler/policies.lisp +++ b/src/compiler/policies.lisp @@ -91,35 +91,6 @@ run-time, which is less efficient. TRACE will show recursive calls. In case of renaming described above, calls to FOO will not be recursive and will refer to the new function, bound to FOO.") -(define-optimization-quality stack-allocate-dynamic-extent - (if (and (> (max speed space) (max debug safety)) - (< safety 3)) - 3 - 0) - ("no" "maybe" "yes" "yes") - "Control whether allocate objects, declared DYNAMIC-EXTENT, on -stack.") - -(define-optimization-quality stack-allocate-value-cells - ;; FIXME, see bug 419 - 0 - ("no" "maybe" "yes" "yes") - "Control whether allocate closure variable storage, declared -DYNAMIC-EXTENT, on stack.") - -(define-optimization-quality stack-allocate-vector - (cond ((= stack-allocate-dynamic-extent 0) 0) - ((= safety 0) 3) - (t 2)) - ("no" "maybe" "one page" "yes") - "Control what vectors, declared DYNAMIC-EXTENT, are allocated on stack: -0: no vectors are allocated on stack; -2: only short vectors (compiler knows them to fit on one page); -3: every. - -This option has an effect only when STACK-ALLOCATE-DYNAMIC-EXTENT is -set.") - (define-optimization-quality float-accuracy 3 ("degraded" "full" "full" "full")) diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index e3dd0fbea..d2b5a2a1c 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -12,11 +12,6 @@ (in-package "SB!VM") ;;;; LIST and LIST* -(defoptimizer (list stack-allocate-result) ((&rest args)) - (not (null args))) -(defoptimizer (list* stack-allocate-result) ((&rest args)) - (not (null (rest args)))) - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:scs (descriptor-reg) :type list) ptr) diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index d83df06e4..d0f6b01bd 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -1095,9 +1095,6 @@ default-value-8 (:translate %more-arg)) ;;; Turn more arg (context, count) into a list. -(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) - t) - (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp index 51350be64..907e27567 100644 --- a/src/compiler/sparc/alloc.lisp +++ b/src/compiler/sparc/alloc.lisp @@ -12,11 +12,6 @@ (in-package "SB!VM") ;;;; LIST and LIST* -(defoptimizer (list stack-allocate-result) ((&rest args)) - (not (null args))) -(defoptimizer (list* stack-allocate-result) ((&rest args)) - (not (null (rest args)))) - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:scs (descriptor-reg) :type list) ptr) diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp index 9c1094dfb..b869141d0 100644 --- a/src/compiler/sparc/call.lisp +++ b/src/compiler/sparc/call.lisp @@ -1094,9 +1094,6 @@ default-value-8 (:translate %more-arg)) ;;; Turn more arg (context, count) into a list. -(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) - t) - (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index e0c521170..dfcf4bfb7 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -12,13 +12,6 @@ (in-package "SB!VM") ;;;; CONS, LIST and LIST* -(defoptimizer (cons stack-allocate-result) ((&rest args)) - t) -(defoptimizer (list stack-allocate-result) ((&rest args)) - (not (null args))) -(defoptimizer (list* stack-allocate-result) ((&rest args)) - (not (null (rest args)))) - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:sc unsigned-reg) ptr temp) @@ -129,39 +122,6 @@ (inst rep) (inst stos zero))) -(in-package "SB!C") - -(defoptimizer (allocate-vector stack-allocate-result) - ((type length words) node) - (ecase (policy node stack-allocate-vector) - (0 nil) - ((1 2) - ;; a vector object should fit in one page - (values-subtypep (lvar-derived-type words) - (load-time-value - (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size* - sb!vm:n-word-bytes) - sb!vm:vector-data-offset)))))) - (3 t))) - -(defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) - (let ((args (basic-combination-args call)) - (template (template-or-lose (if (awhen (node-lvar call) - (lvar-dynamic-extent it)) - 'sb!vm::allocate-vector-on-stack - 'sb!vm::allocate-vector-on-heap)))) - (dolist (arg args) - (setf (lvar-info arg) - (make-ir2-lvar (primitive-type (lvar-type arg))))) - (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) - (ltn-default-call call) - (return-from allocate-vector-ltn-annotate-optimizer (values))) - (setf (basic-combination-info call) template) - (setf (node-tail-p call) nil) - - (dolist (arg args) - (annotate-1-value-lvar arg)))) - (in-package "SB!VM") ;;; diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index 8dfada6f0..6676cc47a 100644 --- a/src/compiler/x86-64/call.lisp +++ b/src/compiler/x86-64/call.lisp @@ -1271,9 +1271,6 @@ (inst mov value (make-ea :qword :base object :index value)))) ;;; Turn more arg (context, count) into a list. -(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) - t) - (define-vop (listify-rest-args) (:translate %listify-rest-args) (:policy :safe) diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index 67ea2a2ca..c66be9c94 100644 --- a/src/compiler/x86/alloc.lisp +++ b/src/compiler/x86/alloc.lisp @@ -12,13 +12,6 @@ (in-package "SB!VM") ;;;; CONS, LIST and LIST* -(defoptimizer (cons stack-allocate-result) ((&rest args)) - t) -(defoptimizer (list stack-allocate-result) ((&rest args)) - (not (null args))) -(defoptimizer (list* stack-allocate-result) ((&rest args)) - (not (null (rest args)))) - (define-vop (list-or-list*) (:args (things :more t)) (:temporary (:sc unsigned-reg) ptr temp) @@ -159,41 +152,6 @@ (inst rep) (inst stos zero))) -(in-package "SB!C") - -(defoptimizer (allocate-vector stack-allocate-result) - ((type length words) node) - (ecase (policy node stack-allocate-vector) - (0 nil) - ((1 2) - ;; a vector object should fit in one page - (values-subtypep (lvar-derived-type words) - (load-time-value - (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size* - sb!vm:n-word-bytes) - sb!vm:vector-data-offset)))))) - (3 t))) - -(defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) - (let ((args (basic-combination-args call)) - (template (template-or-lose (if (awhen (node-lvar call) - (lvar-dynamic-extent it)) - 'sb!vm::allocate-vector-on-stack - 'sb!vm::allocate-vector-on-heap)))) - (dolist (arg args) - (setf (lvar-info arg) - (make-ir2-lvar (primitive-type (lvar-type arg))))) - (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) - (ltn-default-call call) - (return-from allocate-vector-ltn-annotate-optimizer (values))) - (setf (basic-combination-info call) template) - (setf (node-tail-p call) nil) - - (dolist (arg args) - (annotate-1-value-lvar arg)))) - -(in-package "SB!VM") - ;;; (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg) :target boxed) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 3e4d05785..5c1152a9e 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1327,9 +1327,6 @@ (inst mov value (make-ea :dword :base object :index value)))) ;;; Turn more arg (context, count) into a list. -(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) - t) - (define-vop (listify-rest-args) (:translate %listify-rest-args) (:policy :safe) diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp index 200705faa..46f3f8507 100644 --- a/src/pcl/sequence.lisp +++ b/src/pcl/sequence.lisp @@ -216,7 +216,7 @@ (,setf (new-value) (funcall ,nsetf new-value ,s ,nstate)) (,index () (funcall ,nindex ,s ,nstate)) (,copy () (funcall ,ncopy ,s ,nstate))) - (declare (dynamic-extent #',step #',endp #',elt + (declare (truly-dynamic-extent #',step #',endp #',elt #',setf #',index #',copy)) ,@body)))) @@ -479,7 +479,7 @@ (:argument-precedence-order sequence new old)) (defmethod sequence:substitute (new old (sequence sequence) &rest args &key (start 0) end from-end test test-not count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore start end from-end test test-not count key)) (let ((result (copy-seq sequence))) (apply #'sequence:nsubstitute new old result args))) @@ -489,7 +489,7 @@ (:argument-precedence-order sequence new predicate)) (defmethod sequence:substitute-if (new predicate (sequence sequence) &rest args &key (start 0) end from-end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore start end from-end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:nsubstitute-if new predicate result args))) @@ -500,7 +500,7 @@ (defmethod sequence:substitute-if-not (new predicate (sequence sequence) &rest args &key (start 0) end from-end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore start end from-end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:nsubstitute-if-not new predicate result args))) @@ -670,7 +670,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do () ((funcall endp2 sequence state2 limit2 from-end2) (finish)) (let ((e (funcall elt2 sequence state2))) @@ -710,7 +710,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do () ((funcall endp2 sequence state2 limit2 from-end2) (finish)) (let ((e (funcall elt2 sequence state2))) @@ -750,7 +750,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do () ((funcall endp2 sequence state2 limit2 from-end2) (finish)) (let ((e (funcall elt2 sequence state2))) @@ -774,7 +774,7 @@ (:argument-precedence-order sequence item)) (defmethod sequence:remove (item (sequence sequence) &rest args &key from-end test test-not (start 0) end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end test test-not start end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete item result args))) @@ -784,7 +784,7 @@ (:argument-precedence-order sequence predicate)) (defmethod sequence:remove-if (predicate (sequence sequence) &rest args &key from-end (start 0) end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end start end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete-if predicate result args))) @@ -794,7 +794,7 @@ (:argument-precedence-order sequence predicate)) (defmethod sequence:remove-if-not (predicate (sequence sequence) &rest args &key from-end (start 0) end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end start end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete-if-not predicate result args))) @@ -820,7 +820,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do ((end (or end (length sequence))) (step 0 (1+ step))) ((funcall endp2 sequence state2 limit2 from-end2) (finish)) @@ -849,14 +849,14 @@ (sequence &key from-end test test-not start end key)) (defmethod sequence:remove-duplicates ((sequence sequence) &rest args &key from-end test test-not (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end test test-not start end key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete-duplicates result args))) (defgeneric sequence:sort (sequence predicate &key key)) (defmethod sequence:sort ((sequence sequence) predicate &rest args &key key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore key)) (let* ((length (length sequence)) (vector (make-array length))) @@ -879,7 +879,7 @@ (defgeneric sequence:stable-sort (sequence predicate &key key)) (defmethod sequence:stable-sort ((sequence sequence) predicate &rest args &key key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore key)) (let* ((length (length sequence)) (vector (make-array length))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index df9bf956f..685ff6d5b 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -14,13 +14,12 @@ (when (eq sb-ext:*evaluator-mode* :interpret) (sb-ext:quit :unix-status 104)) -(setq sb-c::*check-consistency* t) +(setq sb-c::*check-consistency* t + sb-ext:*stack-allocate-dynamic-extent* t) (defmacro defun-with-dx (name arglist &body body) - `(locally - (declare (optimize sb-c::stack-allocate-dynamic-extent)) - (defun ,name ,arglist - ,@body))) + `(defun ,name ,arglist + ,@body)) (declaim (notinline opaque-identity)) (defun opaque-identity (x) @@ -129,11 +128,10 @@ ;;; value-cells (defun-with-dx dx-value-cell (x) - (declare (optimize sb-c::stack-allocate-value-cells)) ;; Not implemented everywhere, yet. #+(or x86 x86-64 mips) (let ((cell x)) - (declare (dynamic-extent cell)) + (declare (sb-int:truly-dynamic-extent cell)) (flet ((f () (incf cell))) (declare (dynamic-extent #'f)) @@ -385,7 +383,8 @@ ;;; handler-case and handler-bind should use DX internally (defun dx-handler-bind (x) - (handler-bind ((error (lambda (c) (break "OOPS: ~S caused ~S" x c))) + (handler-bind ((error + (lambda (c) (break "OOPS: ~S caused ~S" x c))) ((and serious-condition (not error)) #'(lambda (c) (break "OOPS2: ~S did ~S" x c)))) (/ 2 x))) @@ -397,7 +396,7 @@ (:no-error (res) (1- res)))))) -;;; with-spinlock should use DX and not cons +;;; with-spinlock and with-mutex should use DX and not cons (defvar *slock* (sb-thread::make-spinlock :name "slocklock")) @@ -405,6 +404,12 @@ (sb-thread::with-spinlock (*slock*) (true *slock*))) +(defvar *mutex* (sb-thread::make-mutex :name "mutexlock")) + +(defun test-mutex () + (sb-thread:with-mutex (*mutex*) + (true *mutex*))) + ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons (defvar *table* (make-hash-table)) @@ -466,7 +471,9 @@ ;; Not strictly DX.. (assert-no-consing (test-hash-table)) #+sb-thread - (assert-no-consing (test-spinlock))) + (progn + (assert-no-consing (test-spinlock)) + (assert-no-consing (test-mutex)))) ;;; Bugs found by Paul F. Dietz diff --git a/version.lisp-expr b/version.lisp-expr index e2f68b1b3..2d779d406 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,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.19.6" +"1.0.19.7"