x86: Check for stack overflow for large stack allocated objects.

On x86, the stack guard page could get missed when allocating large
objects on the stack (over 1 page). Instead of giving up or only
allowing this on low safety, just check explicitly whether an overflow
could happen and signal an appropriate condition.

Other platforms don't need this overflow check as urgently, since they
do zero-filling which ensures that they will in fact hit the guard
page eventually before the stack is manipulated again. (Although there
may not be any space left for the handler to do its thing. In any
case, a similar check could be added.)

We can remove the TRULY-DYNAMIC-EXTENT declaration now, since its only
purpose was to facilitate the old way of just avoiding allocations
that could silently overflow the stack. If we really want to skip the
overflow check during self-build always, that could just be achieved
via a special variable. No need to have an extra "internal-only"
declaration to do that. This simplifies frontend processing of dynamic
extent.

Add a test exhibiting large stack allocation interacting with the
limited stack size.

Author: karlosz

NEWS

@@ -1,5 +1,11 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
+changes relative to sbcl-2.3.9:
+  * enhancement: The compiler now allows stack allocating vectors of any size
+    on all safety levels, not just those which it can prove are of sub-page
+    sizes. It can do this because it now inserts code to check for stack
+    overflow explicitly on higher safety levels.
+
 changes in sbcl-2.3.9 relative to sbcl-2.3.8:
   * enhancement: stack allocation via DYNAMIC-EXTENT now applies to all values
     that a variable can take on (for example via SETQ), not just the initial

benchmarks/grab-mutex.lisp

@@ -19,7 +19,7 @@
 
 (defmacro timing-test (&body body)
   `(let ((m *mutex*) (waste (make-array 100 :element-type 'sb-vm:word)))
-     (declare (truly-dynamic-extent waste))
+     (declare (dynamic-extent waste))
      (setq sb-thread::*grab-mutex-calls-performed* 0)
      ;; Get all threads to agree on the moment they should start
      (sb-thread:signal-semaphore *ready-semaphore*)

contrib/sb-introspect/introspect.lisp

@@ -884,7 +884,7 @@ Experimental: interface subject to change."
                         (not (xset-member-p part seen)))
                  (add-to-xset part seen)
                  (funcall fun part))))
-      (declare (truly-dynamic-extent #'call))
+      (declare (dynamic-extent #'call))
       (when ext
         (multiple-value-bind (value foundp)
             (let ((table sb-pcl::*eql-specializer-table*))

doc/manual/efficiency.texinfo

@@ -112,9 +112,8 @@ one-dimensional, and has a constant @code{:element-type}.
 
 @cindex Safety optimization quality
 @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.
+may cause stack overflow. Stack overflow checks are done except in zero
+@code{safety} policies.
 
 @item
 @findex @cl{flet}

src/code/aprof.lisp

@@ -102,7 +102,7 @@
          (sb-fasl:get-asm-routine 'sb-vm::enable-sized-alloc-counter t))
         (stack (make-array 1 :element-type 'sb-vm:word))
         (insts (code-instructions code)))
-    (declare (truly-dynamic-extent stack))
+    (declare (dynamic-extent stack))
     (with-alien ((allocation-tracker-counted (function void system-area-pointer) :extern)
                  (allocation-tracker-sized (function void system-area-pointer) :extern))
       (do-packed-varints (loc locs)

src/code/array.lisp

@@ -924,7 +924,7 @@ of specialized arrays is supported."
 
 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 (defun %array-row-major-index (array &rest subscripts)
-  (declare (truly-dynamic-extent subscripts)
+  (declare (dynamic-extent subscripts)
            (array array))
   (let ((length (length subscripts)))
     (cond ((array-header-p array)
@@ -958,7 +958,7 @@ of specialized arrays is supported."
 
 (defun array-in-bounds-p (array &rest subscripts)
   "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
-  (declare (truly-dynamic-extent subscripts))
+  (declare (dynamic-extent subscripts))
   (let ((length (length subscripts)))
     (cond ((array-header-p array)
            (let ((rank (%array-rank array)))
@@ -979,12 +979,12 @@ of specialized arrays is supported."
                      (length (truly-the (simple-array * (*)) array)))))))))
 
 (defun array-row-major-index (array &rest subscripts)
-  (declare (truly-dynamic-extent subscripts))
+  (declare (dynamic-extent subscripts))
   (apply #'%array-row-major-index array subscripts))
 
 (defun aref (array &rest subscripts)
   "Return the element of the ARRAY specified by the SUBSCRIPTS."
-  (declare (truly-dynamic-extent subscripts))
+  (declare (dynamic-extent subscripts))
   (row-major-aref array (apply #'%array-row-major-index array subscripts)))
 
 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
@@ -993,7 +993,7 @@ of specialized arrays is supported."
 ;;; haven't found technical advantages or disadvantages for either
 ;;; scheme.
 (defun (setf aref) (new-value array &rest subscripts)
-  (declare (truly-dynamic-extent subscripts)
+  (declare (dynamic-extent subscripts)
            (type array array))
   (setf (row-major-aref array (apply #'%array-row-major-index array subscripts))
         new-value))
@@ -1020,14 +1020,14 @@ of specialized arrays is supported."
 (defun bit (bit-array &rest subscripts)
   "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
   (declare (type (array bit) bit-array)
-           (truly-dynamic-extent subscripts)
+           (dynamic-extent subscripts)
            (optimize (safety 1)))
   (row-major-aref bit-array (apply #'%array-row-major-index bit-array subscripts)))
 
 (defun (setf bit) (new-value bit-array &rest subscripts)
   (declare (type (array bit) bit-array)
            (type bit new-value)
-           (truly-dynamic-extent subscripts)
+           (dynamic-extent subscripts)
            (optimize (safety 1)))
   (setf (row-major-aref bit-array
                         (apply #'%array-row-major-index bit-array subscripts))
@@ -1036,15 +1036,15 @@ of specialized arrays is supported."
 (defun sbit (simple-bit-array &rest subscripts)
   "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
   (declare (type (simple-array bit) simple-bit-array)
-           (truly-dynamic-extent subscripts)
+           (dynamic-extent subscripts)
            (optimize (safety 1)))
   (row-major-aref simple-bit-array
                   (apply #'%array-row-major-index simple-bit-array subscripts)))
 
 (defun (setf sbit) (new-value bit-array &rest subscripts)
   (declare (type (simple-array bit) bit-array)
            (type bit new-value)
-           (truly-dynamic-extent subscripts)
+           (dynamic-extent subscripts)
            (optimize (safety 1)))
   (setf (row-major-aref bit-array
                         (apply #'%array-row-major-index bit-array subscripts))

src/code/cross-early.lisp

@@ -11,8 +11,6 @@
 
 (in-package "SB-IMPL")
 
-(declaim (declaration truly-dynamic-extent))
-
 ;;; MAYBE-INLINE, FREEZE-TYPE, and block compilation declarations can be safely ignored
 ;;; (possibly at some cost in efficiency).
 (declaim (declaration freeze-type maybe-inline start-block end-block))

src/code/debug.lisp

@@ -2049,7 +2049,7 @@ forms that explicitly control this kind of evaluation.")
            (string (make-array 127 :element-type 'base-char))
            (n 0)
            code)
-      (declare (truly-dynamic-extent cursor string))
+      (declare (dynamic-extent cursor string))
       (aver (zerop
              (sb-alien:alien-funcall sb-unw-init
                                      (vector-sap cursor) (sb-alien:alien-sap context))))

src/code/early-extensions.lisp

@@ -265,8 +265,7 @@
           (push `(,name (&rest args) ,macro-body) macros))))
     `(macrolet ,macros
        (let* ,(nreverse binds)
-         ,@(if dx `((declare (#+sb-xc-host dynamic-extent ; maybe host can do
-                              #-sb-xc-host truly-dynamic-extent ,@dx))))
+         ,@(if dx `((declare (dynamic-extent ,@dx))))
          ;; Even if the user reads each collection result,
          ;; reader conditionals might statically eliminate all writes.
          ;; Since we don't know, all the -n-tail variable are ignorable.
@@ -1282,7 +1281,6 @@ NOTE: This interface is experimental and subject to change."
                                 ((or (listp id) ; must be a type-specifier
                                      (memq id '(special ignorable ignore
                                                 dynamic-extent
-                                                truly-dynamic-extent
                                                 sb-c::constant-value
                                                 sb-c::no-constraints))
                                      (info :type :kind id))

src/code/eval.lisp

@@ -340,7 +340,7 @@
 
 (defun values (&rest values)
   "Return all arguments, in order, as values."
-  (declare (truly-dynamic-extent values))
+  (declare (dynamic-extent values))
   (values-list values))
 
 (defun values-list (list)