Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769

Modified Files:
	BUGS NEWS build-order.lisp-expr make-host-2.lisp 
	package-data-list.lisp-expr version.lisp-expr 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.541
retrieving revision 1.542
diff -u -d -r1.541 -r1.542
--- BUGS	30 Jul 2008 13:44:55 -0000	1.541
+++ BUGS	30 Jul 2008 17:58:39 -0000	1.542
@@ -1805,27 +1805,26 @@
 
 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:
 

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1375
retrieving revision 1.1376
diff -u -d -r1.1375 -r1.1376
--- NEWS	30 Jul 2008 13:53:11 -0000	1.1375
+++ NEWS	30 Jul 2008 17:58:39 -0000	1.1376
@@ -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)

Index: build-order.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/build-order.lisp-expr,v
retrieving revision 1.82
retrieving revision 1.83
diff -u -d -r1.82 -r1.83
--- build-order.lisp-expr	4 Jun 2008 12:39:38 -0000	1.82
+++ build-order.lisp-expr	30 Jul 2008 17:58:39 -0000	1.83
@@ -35,6 +35,7 @@
 (
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;; miscellaneous
+ ("src/code/cross-early" :not-target)
 
  ;; This comes early because it's useful for debugging everywhere.
  ("src/code/show")

Index: make-host-2.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-host-2.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- make-host-2.lisp	16 May 2008 18:55:00 -0000	1.3
+++ make-host-2.lisp	30 Jul 2008 17:58:39 -0000	1.4
@@ -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)

Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.461
retrieving revision 1.462
diff -u -d -r1.461 -r1.462
--- package-data-list.lisp-expr	16 Jul 2008 19:21:03 -0000	1.461
+++ package-data-list.lisp-expr	30 Jul 2008 17:58:39 -0000	1.462
@@ -584,6 +584,9 @@
                "*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 @@
                "FP-ZERO-P"
                "NEG-FP-ZERO"
 
+               ;; Stack allocation without any questions asked
+               "TRULY-DYNAMIC-EXTENT"
+
                ;; generic set implementation
                "ADD-TO-XSET"
                "ALLOC-XSET"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4040
retrieving revision 1.4041
diff -u -d -r1.4040 -r1.4041
--- version.lisp-expr	30 Jul 2008 16:35:25 -0000	1.4040
+++ version.lisp-expr	30 Jul 2008 17:58:40 -0000	1.4041
@@ -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"

Update of /cvsroot/sbcl/sbcl/doc/manual
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/doc/manual

Modified Files:
	efficiency.texinfo 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: efficiency.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/manual/efficiency.texinfo,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- efficiency.texinfo	16 Apr 2005 06:18:31 -0000	1.12
+++ efficiency.texinfo	30 Jul 2008 17:58:40 -0000	1.13
@@ -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 @@
 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 @@
 @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
-      
-@...
-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 @@
 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 @@
 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).
-
-@...
-* Dynamic-extent allocation::   
-* Modular arithmetic::          
-@... menu
-
-@...  Dynamic-extent allocation
-@...  node-name,  next,  previous,  up
-@... Dynamic-extent allocation
-@... 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
-@...} and @code{debug} at the point of the allocation.  For
-example:
-
-@...
-(locally
-  (declare (optimize speed (safety 1) (debug 1)))
-  (defun foo (&rest rest)
-    (declare (dynamic-extent rest))
-    (length rest)))
-@... lisp
-
-Here the @code{&rest} list will be allocated on the stack.  Note that
-it would not be in the following situation:
-
-@...
-(defun foo (&rest rest)
-  (declare (optimize speed (safety 1) (debug 1)))
-  (declare (dynamic-extent rest))
-  (length rest))
-@... 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
-
-@...
-
-@...
-Stack allocation of @code{&rest} lists, where these are declared
-@...}.
-
-@...
-Stack allocation of @code{list} and @code{list*}, whose result is
-bound to a variable, declared @code{dynamic-extent}, such as
-
-@...
-(let ((list (list 1 2 3)))
-  (declare (dynamic-extent list)
-  ...))
-@... lisp
-
-or
-
-@...
-(flet ((f (x)
-         (declare (dynamic-extent x))
-         ...))
-  ...
-  (f (list 1 2 3))
-  ...)
-@... lisp
-
-@...
-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
-@...}.
-
-Notice, that stack space is limited, so allocation of a large vector
-may cause stack overflow and abnormal termination of the SBCL process.
-
-@...
-Stack allocation of closures, defined with @code{flet} or
-@...} 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}.
-
-@... itemize
-
-Future plans include
-
-@...
-
-@...
-Stack allocation of closures, where these are declared
-@...};
-
-@...
-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
-@...};
-
-@...
-Automatic detection of the common idiom of applying a function to some
-defaults and a @code{&rest} list, even when this is not declared
-@...};
-
-@...
-Automatic detection of the common idiom of calling quantifiers with a
-closure, even when the closure is not declared @code{dynamic-extent}.
-
-@... itemize
-
-@...  Modular arithmetic
-@...  node-name,  next,  previous,  up
-@... Modular arithmetic
-@... Modular arithmetic
-@... Arithmetic, modular
-@... 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{mask})}, where @var{exp} is a tree of such ``good''
-functions and @var{mask} is known to be of type @code{(unsigned-byte
-@...})}, 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.
-
-@...
-(defun i (x y)
-  (declare (type (unsigned-byte 32) x y))
-  (ldb (byte 32 0) (logxor x (lognot y))))
-@... lisp
-
-The result of @code{(lognot y)} will be negative and of type
-@... 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
-@... 32)}, 32-bit machine arithmetic can be used.
-
-As of SBCL 0.8.5 ``good'' functions are @code{+}, @code{-};
-@...}, @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.

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler

Modified Files:
	early-c.lisp ir1tran.lisp ir1util.lisp ir2tran.lisp 
	locall.lisp node.lisp physenvanal.lisp policies.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: early-c.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/early-c.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- early-c.lisp	11 Jul 2008 18:55:08 -0000	1.43
+++ early-c.lisp	30 Jul 2008 17:58:42 -0000	1.44
@@ -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*

Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.165
retrieving revision 1.166
diff -u -d -r1.165 -r1.166
--- ir1tran.lisp	19 Jul 2008 11:32:54 -0000	1.165
+++ ir1tran.lisp	30 Jul 2008 17:58:42 -0000	1.166
@@ -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

Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.117
retrieving revision 1.118
diff -u -d -r1.117 -r1.118
--- ir1util.lisp	20 Jul 2008 07:52:08 -0000	1.117
+++ ir1util.lisp	30 Jul 2008 17:58:42 -0000	1.118
@@ -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)

Index: ir2tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- ir2tran.lisp	30 Jul 2008 13:51:56 -0000	1.75
+++ ir2tran.lisp	30 Jul 2008 17:58:42 -0000	1.76
@@ -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

Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.89
retrieving revision 1.90
diff -u -d -r1.89 -r1.90
--- locall.lisp	20 Jul 2008 07:52:08 -0000	1.89
+++ locall.lisp	30 Jul 2008 17:58:42 -0000	1.90
@@ -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.

Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -d -r1.77 -r1.78
--- node.lisp	16 Jul 2008 20:51:15 -0000	1.77
+++ node.lisp	30 Jul 2008 17:58:42 -0000	1.78
@@ -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))
 

Index: physenvanal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/physenvanal.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- physenvanal.lisp	8 May 2008 11:52:06 -0000	1.24
+++ physenvanal.lisp	30 Jul 2008 17:58:42 -0000	1.25
@@ -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))

Index: policies.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/policies.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- policies.lisp	12 May 2008 14:12:43 -0000	1.21
+++ policies.lisp	30 Jul 2008 17:58:42 -0000	1.22
@@ -91,35 +91,6 @@
 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"))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/code

Modified Files:
	array.lisp backq.lisp defboot.lisp early-extensions.lisp 
	eval.lisp list.lisp numbers.lisp profile.lisp seq.lisp 
	sort.lisp step.lisp target-char.lisp target-error.lisp 
	target-signal.lisp 
Added Files:
	cross-early.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


--- NEW FILE: cross-early.lisp ---
;;;; 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))

Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -d -r1.74 -r1.75
--- array.lisp	28 Jan 2008 15:11:00 -0000	1.74
+++ array.lisp	30 Jul 2008 17:58:40 -0000	1.75
@@ -527,17 +527,17 @@
       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 @@
 
 #!-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))

Index: backq.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/backq.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- backq.lisp	16 Sep 2007 12:05:17 -0000	1.14
+++ backq.lisp	30 Jul 2008 17:58:40 -0000	1.15
@@ -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*)

Index: defboot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- defboot.lisp	8 Jul 2008 21:31:53 -0000	1.62
+++ defboot.lisp	30 Jul 2008 17:58:40 -0000	1.63
@@ -573,31 +573,27 @@
   (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

Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.95
retrieving revision 1.96
diff -u -d -r1.95 -r1.96
--- early-extensions.lisp	30 Jul 2008 13:51:55 -0000	1.95
+++ early-extensions.lisp	30 Jul 2008 17:58:40 -0000	1.96
@@ -1225,53 +1225,19 @@
 
 ;;; 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))))
+  `(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 -- but actually touches the policy of the body,
-;;; so take care with this one...
+;;; 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")
 

Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- eval.lisp	4 Jun 2008 12:39:40 -0000	1.42
+++ eval.lisp	30 Jul 2008 17:58:40 -0000	1.43
@@ -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)

Index: list.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/list.lisp,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -d -r1.44 -r1.45
--- list.lisp	31 May 2008 17:43:12 -0000	1.44
+++ list.lisp	30 Jul 2008 17:58:40 -0000	1.45
@@ -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

Index: numbers.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/numbers.lisp,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -d -r1.52 -r1.53
--- numbers.lisp	30 Jun 2008 09:00:38 -0000	1.52
+++ numbers.lisp	30 Jul 2008 17:58:40 -0000	1.53
@@ -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 @@
   #!+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))

Index: profile.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/profile.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- profile.lisp	19 Nov 2007 01:04:41 -0000	1.38
+++ profile.lisp	30 Jul 2008 17:58:40 -0000	1.39
@@ -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

Index: seq.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/seq.lisp,v
retrieving revision 1.84
retrieving revision 1.85
diff -u -d -r1.84 -r1.85
--- seq.lisp	3 Jun 2008 15:07:03 -0000	1.84
+++ seq.lisp	30 Jul 2008 17:58:40 -0000	1.85
@@ -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

Index: sort.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sort.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- sort.lisp	28 Jan 2008 15:11:00 -0000	1.24
+++ sort.lisp	30 Jul 2008 17:58:41 -0000	1.25
@@ -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

Index: step.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/step.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- step.lisp	1 Nov 2006 13:00:41 -0000	1.7
+++ step.lisp	30 Jul 2008 17:58:41 -0000	1.8
@@ -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))
 

Index: target-char.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-char.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- target-char.lisp	10 Dec 2007 05:42:47 -0000	1.18
+++ target-char.lisp	30 Jul 2008 17:58:41 -0000	1.19
@@ -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)

Index: target-error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-error.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- target-error.lisp	30 Jul 2008 13:53:12 -0000	1.20
+++ target-error.lisp	30 Jul 2008 17:58:41 -0000	1.21
@@ -56,7 +56,6 @@
           (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 @@
                        ;; 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))))

Index: target-signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-signal.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- target-signal.lisp	19 May 2008 14:06:28 -0000	1.43
+++ target-signal.lisp	30 Jul 2008 17:58:41 -0000	1.44
@@ -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

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/tests

Modified Files:
	dynamic-extent.impure.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: dynamic-extent.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/dynamic-extent.impure.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- dynamic-extent.impure.lisp	20 Jul 2008 07:52:09 -0000	1.29
+++ dynamic-extent.impure.lisp	30 Jul 2008 17:58:43 -0000	1.30
@@ -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

Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/generic

Modified Files:
	vm-ir2tran.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: vm-ir2tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/vm-ir2tran.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- vm-ir2tran.lisp	23 Jun 2008 00:55:49 -0000	1.16
+++ vm-ir2tran.lisp	30 Jul 2008 17:58:42 -0000	1.17
@@ -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)

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/pcl

Modified Files:
	sequence.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: sequence.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/sequence.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- sequence.lisp	5 Dec 2006 17:50:23 -0000	1.1
+++ sequence.lisp	30 Jul 2008 17:58:43 -0000	1.2
@@ -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)))

Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/x86-64

Modified Files:
	alloc.lisp call.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/alloc.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- alloc.lisp	19 Jul 2008 16:07:52 -0000	1.18
+++ alloc.lisp	30 Jul 2008 17:58:43 -0000	1.19
@@ -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")
 
 ;;;

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/call.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- call.lisp	19 Jul 2008 16:07:53 -0000	1.18
+++ call.lisp	30 Jul 2008 17:58:43 -0000	1.19
@@ -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)

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/x86

Modified Files:
	alloc.lisp call.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/alloc.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- alloc.lisp	19 Jul 2008 16:07:52 -0000	1.31
+++ alloc.lisp	30 Jul 2008 17:58:42 -0000	1.32
@@ -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)

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/call.lisp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -d -r1.41 -r1.42
--- call.lisp	19 Jul 2008 16:07:52 -0000	1.41
+++ call.lisp	30 Jul 2008 17:58:42 -0000	1.42
@@ -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)

Update of /cvsroot/sbcl/sbcl/src/compiler/sparc
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/sparc

Modified Files:
	alloc.lisp call.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sparc/alloc.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- alloc.lisp	26 Sep 2007 15:44:23 -0000	1.13
+++ alloc.lisp	30 Jul 2008 17:58:42 -0000	1.14
@@ -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)

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sparc/call.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- call.lisp	2 May 2007 13:07:18 -0000	1.11
+++ call.lisp	30 Jul 2008 17:58:42 -0000	1.12
@@ -1094,9 +1094,6 @@
   (: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)))

Update of /cvsroot/sbcl/sbcl/src/compiler/mips
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/mips

Modified Files:
	alloc.lisp call.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/alloc.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- alloc.lisp	26 Sep 2007 15:44:23 -0000	1.16
+++ alloc.lisp	30 Jul 2008 17:58:42 -0000	1.17
@@ -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)

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/call.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- call.lisp	14 Aug 2007 15:53:26 -0000	1.20
+++ call.lisp	30 Jul 2008 17:58:42 -0000	1.21
@@ -1150,9 +1150,6 @@
 (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)))

Update of /cvsroot/sbcl/sbcl/src/compiler/ppc
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/ppc

Modified Files:
	alloc.lisp call.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/alloc.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- alloc.lisp	26 Sep 2007 15:44:23 -0000	1.17
+++ alloc.lisp	30 Jul 2008 17:58:42 -0000	1.18
@@ -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)

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/call.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- call.lisp	2 Nov 2006 15:35:13 -0000	1.20
+++ call.lisp	30 Jul 2008 17:58:42 -0000	1.21
@@ -1095,9 +1095,6 @@
   (: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)))

Update of /cvsroot/sbcl/sbcl/src/compiler/alpha
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20769/src/compiler/alpha

Modified Files:
	alloc.lisp call.lisp 
Log Message:
1.0.19.7: refactor stack allocation decisions

 * 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.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/alpha/alloc.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- alloc.lisp	26 Sep 2007 15:44:23 -0000	1.19
+++ alloc.lisp	30 Jul 2008 17:58:42 -0000	1.20
@@ -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)

Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/alpha/call.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- call.lisp	18 Sep 2006 20:09:14 -0000	1.30
+++ call.lisp	30 Jul 2008 17:58:42 -0000	1.31
@@ -1110,9 +1110,6 @@
 (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)))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19890/src/code

Modified Files:
	cold-init.lisp error.lisp 
Log Message:
1.0.19.6: fix SB-SHOW build

 * Patch by Josh Elsasser for STYLE-WARN.

 * Make COLD-PRINT able to print improper lists -- early source
   locations are conses with the TLF number in the CDR.


Index: cold-init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -d -r1.77 -r1.78
--- cold-init.lisp	17 May 2008 11:02:28 -0000	1.77
+++ cold-init.lisp	30 Jul 2008 16:35:26 -0000	1.78
@@ -339,14 +339,20 @@
 
 #!+sb-show
 (defun cold-print (x)
-  (typecase x
-    (simple-string (sb!sys:%primitive print x))
-    (symbol (sb!sys:%primitive print (symbol-name x)))
-    (list (let ((count 0))
-            (sb!sys:%primitive print "list:")
-            (dolist (i x)
-              (when (>= (incf count) 4)
-                (sb!sys:%primitive print "...")
-                (return))
-              (cold-print i))))
-    (t (sb!sys:%primitive print (hexstr x)))))
+  (labels ((%cold-print (obj depthoid)
+             (if (> depthoid 4)
+                 (sb!sys:%primitive print "...")
+                 (typecase obj
+                   (simple-string
+                    (sb!sys:%primitive print obj))
+                   (symbol
+                    (sb!sys:%primitive print (symbol-name obj)))
+                   (cons
+                    (sb!sys:%primitive print "cons:")
+                    (let ((d (1+ depthoid)))
+                      (%cold-print (car obj) d)
+                      (%cold-print (cdr obj) d)))
+                   (t
+                    (sb!sys:%primitive print (hexstr x)))))))
+    (%cold-print x 0))
+  (values))
\ No newline at end of file

Index: error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/error.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- error.lisp	8 Jul 2008 21:31:53 -0000	1.34
+++ error.lisp	30 Jul 2008 16:35:26 -0000	1.35
@@ -16,7 +16,7 @@
 ;;; not sure this is the right place, but where else?
 (defun style-warn (datum &rest arguments)
   (/show0 "entering STYLE-WARN")
-  (/show format-control format-arguments)
+  (/show datum arguments)
   (if (stringp datum)
       (with-sane-io-syntax
         (warn 'simple-style-warning

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19890

Modified Files:
	version.lisp-expr 
Log Message:
1.0.19.6: fix SB-SHOW build

 * Patch by Josh Elsasser for STYLE-WARN.

 * Make COLD-PRINT able to print improper lists -- early source
   locations are conses with the TLF number in the CDR.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4039
retrieving revision 1.4040
diff -u -d -r1.4039 -r1.4040
--- version.lisp-expr	30 Jul 2008 14:39:40 -0000	1.4039
+++ version.lisp-expr	30 Jul 2008 16:35:25 -0000	1.4040
@@ -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.5"
+"1.0.19.6"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv1429/src/code

Modified Files:
	fd-stream.lisp 
Log Message:
1.0.19.5: minor wording fix

 * Patch by Zach Beane.


Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.128
retrieving revision 1.129
diff -u -d -r1.128 -r1.129
--- fd-stream.lisp	26 May 2008 07:38:28 -0000	1.128
+++ fd-stream.lisp	30 Jul 2008 14:39:40 -0000	1.129
@@ -450,7 +450,7 @@
     (attempt-resync ()
       :report (lambda (stream)
                 (format stream
-                        "~@<Attempt to resync the stream at a character ~
+                        "~@<Attempt to resync the stream at a ~
                         character boundary and continue.~@:>"))
       (fd-stream-resync stream)
       nil)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv1429

Modified Files:
	version.lisp-expr 
Log Message:
1.0.19.5: minor wording fix

 * Patch by Zach Beane.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4038
retrieving revision 1.4039
diff -u -d -r1.4038 -r1.4039
--- version.lisp-expr	30 Jul 2008 13:53:12 -0000	1.4038
+++ version.lisp-expr	30 Jul 2008 14:39:40 -0000	1.4039
@@ -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.4"
+"1.0.19.5"

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15043/tests

Modified Files:
	condition.impure.lisp 
Log Message:
1.0.19.4: recursive restart computation

 * A call to COMPUTE-RESTARTS from restart test function caused
   infinite recursion. Fix with a stack.

 * Test-case.


Index: condition.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/condition.impure.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- condition.impure.lisp	26 Oct 2007 12:48:14 -0000	1.9
+++ condition.impure.lisp	30 Jul 2008 13:53:12 -0000	1.10
@@ -108,3 +108,16 @@
     ;; whether escaped or not
     (dolist (*print-escape* '(nil t))
       (write c :stream (make-string-output-stream)))))
+
+;;; Reported by Michael Weber: restart computation in :TEST-FUNCTION used to
+;;; cause infinite recursion.
+(defun restart-test-finds-restarts ()
+  (restart-bind
+      ((bar (lambda ()
+              (return-from restart-test-finds-restarts 42))
+         :test-function
+         (lambda (condition)
+           (find-restart 'qux))))
+    (when (find-restart 'bar)
+      (invoke-restart 'bar))))
+(assert (not (restart-test-finds-restarts)))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15043/src/code

Modified Files:
	target-error.lisp 
Log Message:
1.0.19.4: recursive restart computation

 * A call to COMPUTE-RESTARTS from restart test function caused
   infinite recursion. Fix with a stack.

 * Test-case.


Index: target-error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-error.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- target-error.lisp	3 Jul 2008 21:31:58 -0000	1.19
+++ target-error.lisp	30 Jul 2008 13:53:12 -0000	1.20
@@ -41,6 +41,8 @@
         (prin1 (restart-name restart) stream))
       (restart-report restart stream)))
 
+(defvar *restart-test-stack* nil)
+
 (defun compute-restarts (&optional condition)
   #!+sb-doc
   "Return a list of all the currently active restarts ordered from most recently
@@ -53,13 +55,23 @@
           (setq associated (cdr alist))
           (setq other (append (cdr alist) other))))
     (collect ((res))
-      (dolist (restart-cluster *restart-clusters*)
-        (dolist (restart restart-cluster)
-          (when (and (or (not condition)
-                         (member restart associated)
-                         (not (member restart other)))
-                     (funcall (restart-test-function restart) condition))
-            (res restart))))
+      (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)
+                           (memq restart associated)
+                           (not (memq restart other)))
+                       ;; A call to COMPUTE-RESTARTS -- from an error, from
+                       ;; user code, whatever -- inside the test function
+                       ;; would cause infinite recursion here, so we disable
+                       ;; each restart using *restart-test-stack* for the
+                       ;; duraction of the test call.
+                       (not (memq restart stack))
+                       (let ((*restart-test-stack* (cons restart stack)))
+                         (declare (dynamic-extent *restart-test-stack*))
+                         (funcall (restart-test-function restart) condition)))
+             (res restart)))))
       (res))))
 
 #!+sb-doc

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15043

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.19.4: recursive restart computation

 * A call to COMPUTE-RESTARTS from restart test function caused
   infinite recursion. Fix with a stack.

 * Test-case.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1374
retrieving revision 1.1375
diff -u -d -r1.1374 -r1.1375
--- NEWS	30 Jul 2008 13:51:55 -0000	1.1374
+++ NEWS	30 Jul 2008 13:53:11 -0000	1.1375
@@ -9,6 +9,9 @@
     type of a variable or bind a constant is made.
   * bug fix: SET signals an error when an attempt to violate declared
     type of a variable is made.
+  * bug fix: restart computation during the execution of a restart
+    test function no longer causes infinite recursion. (reported by
+    Michael Weber)
 
 changes in sbcl-1.0.19 relative to 1.0.18:
   * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*;

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4037
retrieving revision 1.4038
diff -u -d -r1.4037 -r1.4038
--- version.lisp-expr	30 Jul 2008 13:51:55 -0000	1.4037
+++ version.lisp-expr	30 Jul 2008 13:53:12 -0000	1.4038
@@ -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.3"
+"1.0.19.4"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14190/src/code

Modified Files:
	early-extensions.lisp symbol.lisp 
Log Message:
1.0.19.3: more careful PROGV and SET

 * Don't bind constants in PROGV.

 * Check variable types before binding / assignment.

 * When un-binding, PROGV doesn't temporarily bind a variable to NIL
   anymore, but directly to the unbound marker, so that an interrupt
   handler cannot see a bogus value.

 * Based on patch by Richard Kreuter.


Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -d -r1.94 -r1.95
--- early-extensions.lisp	4 Jun 2008 12:39:40 -0000	1.94
+++ early-extensions.lisp	30 Jul 2008 13:51:55 -0000	1.95
@@ -767,7 +767,7 @@
 ;;;   foo => 13, (constantp 'foo) => t
 ;;;
 ;;; ...in which case you frankly deserve to lose.
-(defun about-to-modify-symbol-value (symbol action)
+(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep))
   (declare (symbol symbol))
   (multiple-value-bind (what continue)
       (when (eq :constant (info :variable :kind symbol))
@@ -782,7 +782,18 @@
     (when what
       (if continue
           (cerror "Modify the constant." what action symbol)
-          (error what action symbol))))
+          (error what action symbol)))
+    (when valuep
+      ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
+      ;; check.
+      (let ((type (info :variable :type symbol)))
+        (unless (sb!kernel::%%typep new-value type)
+          (let ((spec (type-specifier type)))
+            (error 'simple-type-error
+                   :format-control "Cannot ~@? to ~S (not of type ~S.)"
+                   :format-arguments (list action symbol new-value spec)
+                   :datum new-value
+                   :expected-type spec))))))
   (values))
 
 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary

Index: symbol.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/symbol.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- symbol.lisp	4 Jun 2008 12:39:40 -0000	1.23
+++ symbol.lisp	30 Jul 2008 13:51:56 -0000	1.24
@@ -32,7 +32,7 @@
   #!+sb-doc
   "Set SYMBOL's value cell to NEW-VALUE."
   (declare (type symbol symbol))
-  (about-to-modify-symbol-value symbol "set SYMBOL-VALUE of ~S")
+  (about-to-modify-symbol-value symbol "set SYMBOL-VALUE of ~S" new-value)
   (%set-symbol-value symbol new-value))
 
 (defun %set-symbol-value (symbol new-value)

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14190/tests

Modified Files:
	compiler.impure.lisp 
Log Message:
1.0.19.3: more careful PROGV and SET

 * Don't bind constants in PROGV.

 * Check variable types before binding / assignment.

 * When un-binding, PROGV doesn't temporarily bind a variable to NIL
   anymore, but directly to the unbound marker, so that an interrupt
   handler cannot see a bogus value.

 * Based on patch by Richard Kreuter.


Index: compiler.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.impure.lisp,v
retrieving revision 1.92
retrieving revision 1.93
diff -u -d -r1.92 -r1.93
--- compiler.impure.lisp	30 Jun 2008 08:35:59 -0000	1.92
+++ compiler.impure.lisp	30 Jul 2008 13:51:56 -0000	1.93
@@ -928,6 +928,13 @@
     (eval '(labels ((%f (&key x) x)) (%f nil nil)))
   (error (c) :good)
   (:no-error (val) (error "no error: ~S" val)))
+
+;;; PROGV must not bind constants, or violate declared types -- ditto for SET.
+(assert (raises-error? (set pi 3)))
+(assert (raises-error? (progv '(pi s) '(3 pi) (symbol-value x))))
+(declaim (cons *special-cons*))
+(assert (raises-error? (set '*special-cons* "nope") type-error))
+(assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14190/src/compiler

Modified Files:
	ir2tran.lisp 
Log Message:
1.0.19.3: more careful PROGV and SET

 * Don't bind constants in PROGV.

 * Check variable types before binding / assignment.

 * When un-binding, PROGV doesn't temporarily bind a variable to NIL
   anymore, but directly to the unbound marker, so that an interrupt
   handler cannot see a bogus value.

 * Based on patch by Richard Kreuter.


Index: ir2tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -d -r1.74 -r1.75
--- ir2tran.lisp	30 Jul 2008 13:44:55 -0000	1.74
+++ ir2tran.lisp	30 Jul 2008 13:51:56 -0000	1.75
@@ -1430,17 +1430,23 @@
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))
-                          (dolist (var vars)
-                            (%primitive bind nil var)
-                            (makunbound var)))
+                          (let ((unbound-marker (%primitive make-other-immediate-type
+                                                            0 sb!vm:unbound-marker-widetag)))
+                            (dolist (var vars)
+                              ;; CLHS says "bound and then made to have no value" -- user
+                              ;; should not be able to tell the difference between that and this.
+                              (about-to-modify-symbol-value var "bind ~S")
+                              (%primitive bind unbound-marker var))))
                         (,bind (vars vals)
                           (declare (optimize (speed 2) (debug 0)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
-                                (t (%primitive bind
-                                               (car vals)
-                                               (car vars))
-                                   (,bind (cdr vars) (cdr vals))))))
+                                (t
+                                 (let ((val (car vals))
+                                       (var (car vars)))
+                                   (about-to-modify-symbol-value var "bind ~S" val)
+                                   (%primitive bind val var))
+                                 (,bind (cdr vars) (cdr vals))))))
                  (,bind ,vars ,vals))
                nil
                ,@body)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14190

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.19.3: more careful PROGV and SET

 * Don't bind constants in PROGV.

 * Check variable types before binding / assignment.

 * When un-binding, PROGV doesn't temporarily bind a variable to NIL
   anymore, but directly to the unbound marker, so that an interrupt
   handler cannot see a bogus value.

 * Based on patch by Richard Kreuter.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1373
retrieving revision 1.1374
diff -u -d -r1.1373 -r1.1374
--- NEWS	30 Jul 2008 13:49:08 -0000	1.1373
+++ NEWS	30 Jul 2008 13:51:55 -0000	1.1374
@@ -5,6 +5,10 @@
     Halik)
   * bug fix: non-local exit from a WITH-ALIEN form no longer causes
     alien-stack leakage. (reported by Andy Hefner)
+  * bug fix: PROGV signals an error when an attempt to violate declared
+    type of a variable or bind a constant is made.
+  * bug fix: SET signals an error when an attempt to violate declared
+    type of a variable is made.
 
 changes in sbcl-1.0.19 relative to 1.0.18:
   * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*;

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4036
retrieving revision 1.4037
diff -u -d -r1.4036 -r1.4037
--- version.lisp-expr	30 Jul 2008 13:49:08 -0000	1.4036
+++ version.lisp-expr	30 Jul 2008 13:51:55 -0000	1.4037
@@ -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.2"
+"1.0.19.3"

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv13053/tests

Modified Files:
	alien.impure.lisp 
Log Message:
1.0.19.2: fix alien stack leak

 * On x86oids bind *ALIEN-STACK* once for the entire WITH-ALIEN, obviating the need
   to release local aliens one-by-one.

 * On other platforms protect the cleanup with UWP.

 * :STATIC option has been disabled in WITH-ALIEN for a while now --
   not sure why, but remove the corresponding bit from docstring as
   well.

 * Test-case by Andy Hefner.


Index: alien.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/alien.impure.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- alien.impure.lisp	30 Jul 2008 13:44:55 -0000	1.20
+++ alien.impure.lisp	30 Jul 2008 13:49:09 -0000	1.21
@@ -210,4 +210,20 @@
                   (values)))))
     (assert (not (funcall (compile nil fun))))))
 
+;;; Non-local exit from WITH-ALIEN caused alien stack to be leaked.
+(defvar *sap-int*)
+(defun try-to-leak-alien-stack (x)
+  (with-alien ((alien (array (sb-alien:unsigned 8) 72)))
+    (let ((sap-int (sb-sys:sap-int (alien-sap alien))))
+      (if *sap-int*
+          (assert (= *sap-int* sap-int))
+          (setf *sap-int* sap-int)))
+    (when x
+      (return-from try-to-leak-alien-stack 'going))
+    (never)))
+(with-test (:name :nlx-causes-alien-stack-leak)
+  (let ((*sap-int* nil))
+    (loop repeat 1024
+          do (try-to-leak-alien-stack t))))
+
 ;;; success