;;;; -*- 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
"DEFENUM"
"DEFPRINTER"
"AVER" "ENFORCE-TYPE"
- "DX-FLET"
+ "DX-FLET" "DX-LET"
"AWHEN" "ACOND" "IT"
"BINDING*"
"!DEF-BOOLEAN-ATTRIBUTE"
;;; 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.
;;; 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)))
(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))
(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))
(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
(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
(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
(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
(: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))
(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)))
\f
;;;; leaf reference
(: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)
(: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)
(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
(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))))
\f
;;;; automatic allocators for primitive objects
;;; 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
(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))))
\f
;;;; automatic allocators for primitive objects
;;; 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
(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*)))
+
\f
(defmacro assert-no-consing (form &optional times)
`(%assert-no-consing (lambda () ,form) ,times))
(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)))
\f
;;; Bugs found by Paul F. Dietz
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.7"
+"1.0.7.1"
projects / sbcl.git / commitdiff