[Sbcl-commits] CVS: sbcl/tests dynamic-extent.impure.lisp, 1.29, 1.30

[Nikodemus S. <de...@us...>]

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