Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30418/src/code
Modified Files:
array.lisp late-extensions.lisp target-defstruct.lisp
target-hash-table.lisp target-thread.lisp
Log Message:
1.0.5.6: compare-and-swap / instance-set-conditional refactoring
* Rename *-COMPARE-AND-EXCHANGE *-COMPARE-AND-SWAP.
* DEFINE-FULL-COMPARE-AND-SWAP, use it to implement
%INSTANCE-COMPARE-AND-SWAP (previously %INTANCE-SET-CONDITIONAL) on x86oids.
* Implement %SIMPLE-VECTOR-COMPARE-AND-SWAP. Not used right now, but required
by a forthcoming patch.
* Implement non-x86oid (non-threaded) versions of the above.
* Check that the slot isn't raw in DEFINE-STRUCURE-SLOT-COMPARE-AND-SWAP.
* Whitespace.
Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- array.lisp 24 Apr 2007 15:39:01 -0000 1.62
+++ array.lisp 29 Apr 2007 17:17:26 -0000 1.63
@@ -56,6 +56,15 @@
(values vector index))
(values array index)))
+(defun %simple-vector-compare-and-swap (vector index old new)
+ #!+(or x86 x86-64)
+ (%simple-vector-compare-and-swap vector index old new)
+ #!-(or x86 x86-64)
+ (let ((n-old (svref vector index)))
+ (when (eq old n-old)
+ (setf (svref vector index) new))
+ n-old))
+
;;; It'd waste space to expand copies of error handling in every
;;; inline %WITH-ARRAY-DATA, so we have them call this function
;;; instead. This is just a wrapper which is known never to return.
Index: late-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-extensions.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- late-extensions.lisp 7 Apr 2007 18:27:06 -0000 1.12
+++ late-extensions.lisp 29 Apr 2007 17:17:26 -0000 1.13
@@ -49,7 +49,7 @@
;;; Used internally, but it would be nice to provide something
;;; like this for users as well.
#!+sb-thread
-(defmacro define-structure-slot-compare-and-exchange
+(defmacro define-structure-slot-compare-and-swap
(name &key structure slot)
(let* ((dd (find-defstruct-description structure t))
(slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
@@ -57,12 +57,16 @@
(index (when slotd (dsd-index slotd))))
(unless index
(error "Slot ~S not found in ~S." slot structure))
+ (unless (eq t (dsd-raw-type slotd))
+ (error "Cannot define compare-and-swap on a raw slot."))
+ (when (dsd-read-only slotd)
+ (error "Cannot define compare-and-swap on a read-only slot."))
`(progn
(declaim (inline ,name))
(defun ,name (instance old new)
(declare (type ,structure instance)
- (type ,type new))
- (sb!vm::%instance-set-conditional instance ,index old new)))))
+ (type ,type old new))
+ (%instance-compare-and-swap instance ,index old new)))))
;;; Ditto
#!+sb-thread
Index: target-defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-defstruct.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- target-defstruct.lisp 7 Apr 2007 13:58:57 -0000 1.38
+++ target-defstruct.lisp 29 Apr 2007 17:17:26 -0000 1.39
@@ -31,6 +31,15 @@
(defun %instance-set (instance index new-value)
(setf (%instance-ref instance index) new-value))
+(defun %instance-compare-and-swap (instance index old new)
+ #!+(or x86 x86-64)
+ (%instance-compare-and-swap instance index old new)
+ #!-(or x86 x86-64)
+ (let ((n-old (%instance-ref instance index)))
+ (when (eq old n-old)
+ (%instance-set instance index new))
+ n-old))
+
#!-hppa
(progn
(defun %raw-instance-ref/word (instance index)
Index: target-hash-table.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-hash-table.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- target-hash-table.lisp 29 Apr 2007 14:04:17 -0000 1.35
+++ target-hash-table.lisp 29 Apr 2007 17:17:26 -0000 1.36
@@ -23,13 +23,13 @@
#!-sb-thread
(declare (ignore spinlock))
`(without-gcing
- (unwind-protect
- (progn
- #!+sb-thread
- (sb!thread::get-spinlock ,spinlock)
- ,@body)
- #!+sb-thread
- (sb!thread::release-spinlock ,spinlock))))
+ (unwind-protect
+ (progn
+ #!+sb-thread
+ (sb!thread::get-spinlock ,spinlock)
+ ,@body)
+ #!+sb-thread
+ (sb!thread::release-spinlock ,spinlock))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant max-hash sb!xc:most-positive-fixnum))
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -d -r1.71 -r1.72
--- target-thread.lisp 11 Apr 2007 18:08:42 -0000 1.71
+++ target-thread.lisp 29 Apr 2007 17:17:26 -0000 1.72
@@ -183,8 +183,8 @@
;;;; spinlocks
#!+sb-thread
-(define-structure-slot-compare-and-exchange
- compare-and-exchange-spinlock-value
+(define-structure-slot-compare-and-swap
+ compare-and-swap-spinlock-value
:structure spinlock
:slot value)
@@ -198,14 +198,14 @@
;; store any value
#!+sb-thread
(loop until
- (eql 0 (compare-and-exchange-spinlock-value spinlock 0 1)))
+ (eql 0 (compare-and-swap-spinlock-value spinlock 0 1)))
t)
(defun release-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
#!-sb-thread (ignore spinlock))
;; %instance-set-conditional cannot compare arbitrary objects
- ;; meaningfully, so (compare-and-exchange-spinlock-value our-value 0)
+ ;; meaningfully, so (compare-and-swap-spinlock-value our-value 0)
;; does not work for bignum thread ids.
#!+sb-thread
(setf (spinlock-value spinlock) 0)
@@ -226,8 +226,8 @@
(define-structure-slot-addressor mutex-value-address
:structure mutex
:slot value)
- (define-structure-slot-compare-and-exchange
- compare-and-exchange-mutex-value
+ (define-structure-slot-compare-and-swap
+ compare-and-swap-mutex-value
:structure mutex
:slot value))
@@ -266,7 +266,7 @@
(loop
(unless
(setf old
- (compare-and-exchange-mutex-value mutex nil new-value))
+ (compare-and-swap-mutex-value mutex nil new-value))
(return t))
(unless wait-p (return nil))
(with-pinned-objects (mutex old)
|