* Remove SB-C::STACK-ALLOCATE-* policies.
* Obey DYNAMIC-EXTENT declarations if SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT*
is true (the default), with the following exceptions:
** Value cells are not stack allocated.
** Vectors that may be longer then a single page are stack
allocated only in SAFETY 0 policies.
* New declaration: SB-INT:TRULY-DYNAMIC-EXTENT. Always stack-allocates,
regardless of SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT*. Also causes stack
allocation of value cells and potentially large vectors.
Used exclusively inside SBCL.
* Move STACK-ALLOCATE-RESULT optimizers from backends to
src/compiler/generic/vm-ir2tran.lisp.
* Documentation.
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:
;;;; -*- 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)
(
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; miscellaneous
+ ("src/code/cross-early" :not-target)
;; This comes early because it's useful for debugging everywhere.
("src/code/show")
@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
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
@c <!-- FIXME: Python dislikes assignments, but not in type
@c inference. The real problems are loop induction, closed over
@c variables and aliases. -->
-
+
@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
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)}
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.
;; 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)
"*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*"
"FP-ZERO-P"
"NEG-FP-ZERO"
+ ;; Stack allocation without any questions asked
+ "TRULY-DYNAMIC-EXTENT"
+
;; generic set implementation
"ADD-TO-XSET"
"ALLOC-XSET"
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))
#!-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))
;; 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*)
--- /dev/null
+;;;; 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))
(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
;;; Helper for making the DX closure allocation in macros expanding
;;; to CALL-WITH-FOO less ugly.
-;;;
-;;; This expands to something like
-;;;
-;;; (flet ((foo (...) <body-of-foo>))
-;;; (declare (optimize stack-allocate-dynamic-extent))
-;;; (flet ((foo (...)
-;;; (foo ...))
-;;; (declare (dynamic-extent #'foo))
-;;; <body-of-dx-flet>)))
-;;;
-;;; 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")
(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)
(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
(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
(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)
(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)
(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)
(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)
(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)
(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)
#!+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))
#!+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))
(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
#!+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
(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)
(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)
(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)))
(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))
"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
"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
"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
"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
#!+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
#!+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
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
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
"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)))
#!+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)
#!+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)
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
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
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
(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
(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
(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)
(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)
(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)
(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)
#!+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))
#!+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))
"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)
: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))
(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
#!+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
#!+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
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))
(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))))
(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)
(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)
(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)
(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)
(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)
#!+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)
#!+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)
#!+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)
#!+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)
#!+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)
#!+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)
(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)
;; 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))))
(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
(in-package "SB!VM")
\f
;;;; 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)
(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)))
(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*
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)
(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)
(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.
(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
(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)
(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)))
\f
;;;; leaf reference
(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
(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.
(in-package "SB!VM")
\f
;;;; 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)
(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)))
;; 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))
(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))
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"))
(in-package "SB!VM")
\f
;;;; 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)
(: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)))
(in-package "SB!VM")
\f
;;;; 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)
(: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)))
(in-package "SB!VM")
\f
;;;; 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)
(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")
;;;
(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)
(in-package "SB!VM")
\f
;;;; 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)
(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)
(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)
(,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))))
(: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)))
(: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)))
(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)))
(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)))
(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)))
(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)))
(: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)))
(: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)))
(: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)))
(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))
(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)))
(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)))
(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)
;;; 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))
;;; 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)))
(: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"))
(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))
;; 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))))
\f
;;; Bugs found by Paul F. Dietz
;;; 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"
projects / sbcl.git / commitdiff