From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 28 Jun 2007 13:04:54 +0000 (+0000)
Subject: 1.0.7.1: dynamic extent value cells
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ec2e02db335d1545b3c18233bf440ca4160f780d;p=sbcl.git

1.0.7.1: dynamic extent value cells

 * Pass DX information from leaf to MAKE-VALUE-CELL, and implement the
   DX allocation for it on x86 and x86-64.

 * Declare some appropriate closed-over variables dynamic-extent:
   allows non-consing WITH-SPINLOCK &co.

 * Tests.
---

diff --git a/NEWS b/NEWS
index a792105..12ab872 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.8 relative to sbcl-1.0.7:
+  * enhancement: closed over variables can be stack-allocated on x86 and
+    x86-64.
+
 changes in sbcl-1.0.7 relative to sbcl-1.0.6:
   * MOP improvement: support for user-defined subclasses of
     SB-MOP:SPECIALIZER has been enhanced.  The experimental interface
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 1288f31..1e8841e 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -901,7 +901,7 @@ possibly temporariliy, because it might be used internally."
                "DEFENUM"
                "DEFPRINTER"
                "AVER" "ENFORCE-TYPE"
-               "DX-FLET"
+               "DX-FLET" "DX-LET"
                "AWHEN" "ACOND" "IT"
                "BINDING*"
                "!DEF-BOOLEAN-ATTRIBUTE"
diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp
index 0f68d1d..16b4999 100644
--- a/src/code/cross-misc.lisp
+++ b/src/code/cross-misc.lisp
@@ -25,10 +25,6 @@
 ;;; may then have to wade through some irrelevant warnings).
 (declaim (declaration inhibit-warnings))
 
-;;; We sometimes want to enable DX unconditionally in our own code,
-;;; but the host can ignore this without harm.
-(declaim (declaration sb!c::stack-allocate-dynamic-extent))
-
 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
 ;;; have a single thread of control.
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 8e10277..2281678 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1275,20 +1275,34 @@ to :INTERPRET, an interpreter will be used.")
 ;;; to force DX allocation in their bodies, which would be bad eg.
 ;;; in safe code.
 (defmacro dx-flet (functions &body forms)
-  `(flet ,functions
-     (declare (optimize sb!c::stack-allocate-dynamic-extent))
-     (flet ,(mapcar
-             (lambda (f)
-               (let ((args (cadr f))
-                     (name (car f)))
-                 (when (intersection args 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 (f)
-                                            `(function ,(car f)))
-                                          functions)))
+  (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 lambda-list-keywords)
+                     ;; No fundamental reason not to support them, but we
+                     ;; don't currently need them here.
+                     (error "Non-required arguments not implemented for DX-FLET."))
+                   `(,name ,args
+                      (,name ,@args))))
+               functions)
+         (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names)))
+         ,@forms))))
+
+;;; Another similar one -- but actually touches the policy of the body,
+;;; so take care with this one...
+(defmacro dx-let (bindings &body forms)
+  `(locally
+       #-sb-xc-host
+       (declare (optimize sb!c::stack-allocate-dynamic-extent))
+     (let ,bindings
+       (declare (dynamic-extent ,@(mapcar (lambda (bind)
+                                            (if (consp bind)
+                                                (car bind)
+                                                bind))
+                                          bindings)))
        ,@forms)))
diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 4ef2e66..5571ef8 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -119,11 +119,14 @@ provided the default value is used for the mutex."
     (funcall function)))
 
 #!+sb-thread
+;;; KLUDGE: These need to use DX-LET, because the cleanup form that
+;;; closes over GOT-IT causes a value-cell to be allocated for it -- and
+;;; we prefer that to go on the stack since it can.
 (progn
   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
     (declare (function function))
     (flet ((%call-with-system-mutex ()
-             (let (got-it)
+             (dx-let (got-it)
                (unwind-protect
                     (when (setf got-it (get-mutex mutex))
                       (funcall function))
@@ -138,8 +141,8 @@ provided the default value is used for the mutex."
   (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p)
     (declare (function function))
     (flet ((%call-with-system-spinlock ()
-             (let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
-                   (got-it nil))
+             (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
+                      (got-it nil))
                (unwind-protect
                     (when (or inner-lock-p (setf got-it (get-spinlock lock)))
                       (funcall function))
@@ -151,9 +154,20 @@ provided the default value is used for the mutex."
           (without-interrupts
             (%call-with-system-spinlock)))))
 
+  (defun call-with-spinlock (function spinlock)
+    (declare (function function))
+    (dx-let ((got-it nil))
+      (without-interrupts
+        (unwind-protect
+             (when (setf got-it (allow-with-interrupts
+                                 (get-spinlock spinlock)))
+               (with-local-interrupts (funcall function)))
+          (when got-it
+            (release-spinlock spinlock))))))
+
   (defun call-with-mutex (function mutex value waitp)
     (declare (function function))
-    (let ((got-it nil))
+    (dx-let ((got-it nil))
       (without-interrupts
         (unwind-protect
              (when (setq got-it (allow-with-interrupts
@@ -164,8 +178,8 @@ provided the default value is used for the mutex."
 
   (defun call-with-recursive-lock (function mutex)
     (declare (function function))
-    (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
-          (got-it nil))
+    (dx-let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
+             (got-it nil))
       (without-interrupts
         (unwind-protect
              (when (or inner-lock-p (setf got-it (allow-with-interrupts
@@ -174,20 +188,11 @@ provided the default value is used for the mutex."
           (when got-it
             (release-mutex mutex))))))
 
-  (defun call-with-spinlock (function spinlock)
-    (declare (function function))
-    (let ((got-it nil))
-      (without-interrupts
-        (unwind-protect
-             (when (setf got-it (allow-with-interrupts
-                                 (get-spinlock spinlock)))
-               (with-local-interrupts (funcall function)))
-          (when got-it
-            (release-spinlock spinlock))))))
+
 
   (defun call-with-recursive-spinlock (function spinlock)
     (declare (function function))
-    (let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
+    (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
           (got-it nil))
       (without-interrupts
         (unwind-protect
diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp
index 4852fec..92a4eb7 100644
--- a/src/compiler/alpha/alloc.lisp
+++ b/src/compiler/alpha/alloc.lisp
@@ -147,6 +147,8 @@
 (define-vop (make-value-cell)
   (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
   (:temporary (:scs (non-descriptor-reg)) temp)
+  (:info stack-allocate-p)
+  (:ignore stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:generator 10
     (with-fixed-allocation
diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp
index 8ad6676..0d41dcb 100644
--- a/src/compiler/hppa/alloc.lisp
+++ b/src/compiler/hppa/alloc.lisp
@@ -133,6 +133,8 @@
   (:args (value :to :save :scs (descriptor-reg any-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:results (result :scs (descriptor-reg)))
+  (:info stack-allocate-p)
+  (:ignore stack-allocate-p)
   (:generator 10
     (with-fixed-allocation
         (result temp value-cell-header-widetag value-cell-size))
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index db050bc..ebc963c 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -52,12 +52,13 @@
   (emit-move-template node block (type-check-template type) value result)
   (values))
 
-;;; Allocate an indirect value cell. Maybe do some clever stack
-;;; allocation someday.
+;;; Allocate an indirect value cell.
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)
-  (vop make-value-cell node block value res))
+  (let ((leaf (tn-leaf res)))
+    (vop make-value-cell node block value (and leaf (leaf-dynamic-extent leaf))
+         res)))
 
 ;;;; leaf reference
 
diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
index eb194d5..44d523a 100644
--- a/src/compiler/mips/alloc.lisp
+++ b/src/compiler/mips/alloc.lisp
@@ -154,6 +154,8 @@
   (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+  (:info stack-allocate-p)
+  (:ignore stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:generator 10
     (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size)
diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
index 55c6df5..0f8f20d 100644
--- a/src/compiler/ppc/alloc.lisp
+++ b/src/compiler/ppc/alloc.lisp
@@ -157,6 +157,8 @@
   (:args (value :to :save :scs (descriptor-reg any-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:info stack-allocate-p)
+  (:ignore stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:generator 10
     (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size)
diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp
index aa46f2f..7d39b39 100644
--- a/src/compiler/sparc/alloc.lisp
+++ b/src/compiler/sparc/alloc.lisp
@@ -149,6 +149,8 @@
 (define-vop (make-value-cell)
   (:args (value :to :save :scs (descriptor-reg any-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
+  (:info stack-allocate-p)
+  (:ignore stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:generator 10
     (with-fixed-allocation
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index 76bad49..c89b135 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -225,10 +225,11 @@
 (define-vop (make-value-cell)
   (:args (value :scs (descriptor-reg any-reg) :to :result))
   (:results (result :scs (descriptor-reg) :from :eval))
+  (:info stack-allocate-p)
   (:node-var node)
   (:generator 10
     (with-fixed-allocation
-        (result value-cell-header-widetag value-cell-size node)
+        (result value-cell-header-widetag value-cell-size node stack-allocate-p)
       (storew value result value-cell-value-slot other-pointer-lowtag))))
 
 ;;;; automatic allocators for primitive objects
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 16a7774..32b3923 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -226,13 +226,13 @@
 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 ;;; header having the specified WIDETAG value. The result is placed in
 ;;; RESULT-TN.
-(defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
+(defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p)
                                  &body forms)
   (unless forms
     (bug "empty &body in WITH-FIXED-ALLOCATION"))
-  (once-only ((result-tn result-tn) (size size))
-    `(pseudo-atomic
-      (allocation ,result-tn (pad-data-block ,size) ,inline)
+  (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
+    `(maybe-pseudo-atomic ,stack-allocate-p
+      (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p)
       (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
               ,result-tn)
       (inst lea ,result-tn
diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index 8bc9c86..f3cf5f9 100644
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -255,10 +255,11 @@
 (define-vop (make-value-cell)
   (:args (value :scs (descriptor-reg any-reg) :to :result))
   (:results (result :scs (descriptor-reg) :from :eval))
+  (:info stack-allocate-p)
   (:node-var node)
   (:generator 10
     (with-fixed-allocation
-        (result value-cell-header-widetag value-cell-size node)
+        (result value-cell-header-widetag value-cell-size node stack-allocate-p)
       (storew value result value-cell-value-slot other-pointer-lowtag))))
 
 ;;;; automatic allocators for primitive objects
diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 01c6226..fe0469b 100644
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -280,13 +280,13 @@
 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 ;;; header having the specified WIDETAG value. The result is placed in
 ;;; RESULT-TN.
-(defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
+(defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p)
                                  &body forms)
   (unless forms
     (bug "empty &body in WITH-FIXED-ALLOCATION"))
-  (once-only ((result-tn result-tn) (size size))
-    `(pseudo-atomic
-      (allocation ,result-tn (pad-data-block ,size) ,inline)
+  (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
+    `(maybe-pseudo-atomic ,stack-allocate-p
+      (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p)
       (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
               ,result-tn)
       (inst lea ,result-tn
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index ba18278..ead5757 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -126,6 +126,26 @@
 
 (assert (eq t (dxclosure 13)))
 
+;;; value-cells
+
+(defun-with-dx dx-value-cell (x)
+  ;; Not implemented everywhere, yet.
+  #+(or x86 x86-64)
+  (let ((cell x))
+    (declare (dynamic-extent cell))
+    (flet ((f ()
+             (incf cell)))
+      (declare (dynamic-extent #'f))
+      (true #'f))))
+
+;;; with-spinlock should use DX and not cons
+
+(defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
+
+(defun test-spinlock ()
+  (sb-thread::with-spinlock (*slock*)
+    (true *slock*)))
+
 
 (defmacro assert-no-consing (form &optional times)
   `(%assert-no-consing (lambda () ,form) ,times))
@@ -147,7 +167,10 @@
   (assert-no-consing (test-nip-values))
   (assert-no-consing (test-let-var-subst1 17))
   (assert-no-consing (test-let-var-subst2 17))
-  (assert-no-consing (test-lvar-subst 11)))
+  (assert-no-consing (test-lvar-subst 11))
+  (assert-no-consing (dx-value-cell 13))
+  #+sb-thread
+  (assert-no-consing (test-spinlock)))
 
 
 ;;; Bugs found by Paul F. Dietz
diff --git a/version.lisp-expr b/version.lisp-expr
index 4aecb60..21c9ae6 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.7"
+"1.0.7.1"