* 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.
"HALT"
"IF-EQ" "INLINE-SYNTACTIC-CLOSURE-LAMBDA"
"INSERT-STEP-CONDITIONS"
- "INSTANCE-REF" "INSTANCE-SET"
"IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
"IR2-PHYSENV-NUMBER-STACK-P"
"KNOWN-CALL-LOCAL" "KNOWN-RETURN"
"%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64"
"%SET-SIGNED-SAP-REF-WORD"
"%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF"
- "%SET-SYMBOL-HASH" "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT"
+ "%SET-SYMBOL-HASH"
+ "%SIMPLE-VECTOR-COMPARE-AND-SWAP"
+ "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT"
"%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING"
"%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH"
"%UNARY-ROUND" "%UNARY-TRUNCATE" "%UNARY-FTRUNCATE"
#!+long-float "DECODE-LONG-FLOAT"
"DECODE-SINGLE-FLOAT"
"DEFINE-STRUCTURE-SLOT-ADDRESSOR"
- "DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE"
+ "DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP"
"DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
"!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO"
"DISPLACED-TO-ARRAY-TOO-SMALL-ERROR"
"SPECIALIZABLE" "SPECIALIZABLE-VECTOR" "SPECIFIER-TYPE"
"STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR"
"STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC"
- "SYMBOLS-DESIGNATOR" "%INSTANCE-LENGTH" "%INSTANCE-REF"
- "%INSTANCE-SET" "SYSTEM-AREA-CLEAR"
+ "SYMBOLS-DESIGNATOR"
+ "%INSTANCE-COMPARE-AND-SWAP"
+ "%INSTANCE-LENGTH"
+ "%INSTANCE-REF"
+ "%INSTANCE-SET"
+ "SYSTEM-AREA-CLEAR"
"TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/"
"TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-="
"TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-EQV"
(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.
;;; 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)))
(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
(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)
#!-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))
;;;; 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)
;; 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)
(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))
(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)
(values)
())
(defknown style-warn (string &rest t) null ())
+
+;;;; atomic ops
+#!+(or x86 x86-64)
+(progn
+ (defknown %simple-vector-compare-and-swap (simple-vector index t t) t
+ (unsafe))
+ (defknown %instance-compare-and-swap (instance index t t) t
+ (unsafe)))
signed-num signed-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num
unsigned-reg))
+
+(define-full-compare-and-swap simple-vector-compare-and-swap
+ simple-vector vector-data-offset other-pointer-lowtag
+ (descriptor-reg any-reg) *
+ %simple-vector-compare-and-swap)
\f
;;;; integer vectors whose elements are smaller than a byte, i.e.,
;;;; bit, 2-bit, and 4-bit vectors
(define-full-setter instance-index-set * instance-slots-offset
instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
-
-(defknown %instance-set-conditional (instance index t t) t
- (unsafe))
-
-(define-vop (instance-set-conditional)
- (:translate %instance-set-conditional)
- (:args (object :scs (descriptor-reg) :to :eval)
- (slot :scs (any-reg) :to :result)
- (old-value :scs (descriptor-reg any-reg) :target rax)
- (new-value :scs (descriptor-reg any-reg)))
- (:arg-types instance positive-fixnum * *)
- (:temporary (:sc descriptor-reg :offset rax-offset
- :from (:argument 2) :to :result :target result) rax)
- (:results (result :scs (descriptor-reg any-reg)))
- ;(:guard (backend-featurep :i486))
- (:policy :fast-safe)
- (:generator 5
- (move rax old-value)
- (inst lock)
- (inst cmpxchg (make-ea :qword :base object :index slot :scale 1
- :disp (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
- new-value)
- (move result rax)))
-
-
+(define-full-compare-and-swap instance-compare-and-swap instance
+ instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg)
+ * %instance-compare-and-swap)
\f
;;;; code object frobbing
(define-full-setter code-header-set * 0 other-pointer-lowtag
(any-reg descriptor-reg) * code-header-set)
-
-
\f
;;;; raw instance slot accessors
\f
;;;; indexed references
+(defmacro define-full-compare-and-swap
+ (name type offset lowtag scs el-type &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :eval)
+ (index :scs (any-reg) :to :result)
+ (old-value :scs ,scs :target rax)
+ (new-value :scs ,scs))
+ (:arg-types ,type tagged-num ,el-type ,el-type)
+ (:temporary (:sc descriptor-reg :offset rax-offset
+ :from (:argument 2) :to :result :target value) rax)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (move rax old-value)
+ #!+sb-thread
+ (inst lock)
+ (inst cmpxchg (make-ea :qword :base object :index index
+ :disp (- (* ,offset n-word-bytes) ,lowtag))
+ new-value)
+ (move value rax)))))
+
(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
`(progn
(define-vop (,name)
#!+sb-unicode
(def-full-data-vector-frobs simple-character-string character character-reg))
+(define-full-compare-and-swap simple-vector-compare-and-swap
+ simple-vector vector-data-offset other-pointer-lowtag
+ (descriptor-reg any-reg) *
+ %simple-vector-compare-and-swap)
\f
;;;; integer vectors whose elements are smaller than a byte, i.e.,
;;;; bit, 2-bit, and 4-bit vectors
(loadw res struct 0 instance-pointer-lowtag)
(inst shr res n-widetag-bits)))
-(define-full-reffer instance-index-ref * instance-slots-offset
- instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
-
-(define-full-setter instance-index-set * instance-slots-offset
- instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
-
-
-(defknown %instance-set-conditional (instance index t t) t
- (unsafe))
-
-(define-vop (instance-set-conditional)
- (:translate %instance-set-conditional)
- (:args (object :scs (descriptor-reg) :to :eval)
- (slot :scs (any-reg) :to :result)
- (old-value :scs (descriptor-reg any-reg) :target eax)
- (new-value :scs (descriptor-reg any-reg)))
- (:arg-types instance positive-fixnum * *)
- (:temporary (:sc descriptor-reg :offset eax-offset
- :from (:argument 2) :to :result :target result) eax)
- (:results (result :scs (descriptor-reg any-reg)))
- ;(:guard (backend-featurep :i486))
- (:policy :fast-safe)
- (:generator 5
- (move eax old-value)
- (inst lock)
- (inst cmpxchg (make-ea :dword :base object :index slot :scale 1
- :disp (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
- new-value)
- (move result eax)))
-
-
+(define-full-reffer instance-index-ref *
+ instance-slots-offset instance-pointer-lowtag
+ (any-reg descriptor-reg) *
+ %instance-ref)
+
+(define-full-setter instance-index-set *
+ instance-slots-offset instance-pointer-lowtag
+ (any-reg descriptor-reg) *
+ %instance-set)
+
+(define-full-compare-and-swap instance-compare-and-swap instance
+ instance-slots-offset instance-pointer-lowtag
+ (any-reg descriptor-reg) *
+ %instance-compare-and-swap)
\f
;;;; code object frobbing
(define-full-setter code-header-set * 0 other-pointer-lowtag
(any-reg descriptor-reg) * code-header-set)
-
-
\f
;;;; raw instance slot accessors
\f
;;;; indexed references
+(defmacro define-full-compare-and-swap
+ (name type offset lowtag scs el-type &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :eval)
+ (index :scs (any-reg immediate unsigned-reg) :to :result)
+ (old-value :scs ,scs :target eax)
+ (new-value :scs ,scs))
+ (:arg-types ,type tagged-num ,el-type ,el-type)
+ (:temporary (:sc descriptor-reg :offset eax-offset
+ :from (:argument 2) :to :result :target value) eax)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (move eax old-value)
+ #!+sb-thread
+ (inst lock)
+ (let ((ea (sc-case index
+ (immediate
+ (make-ea :dword :base object
+ :disp (- (* (+ ,offset (tn-value index))
+ n-word-bytes)
+ ,lowtag)))
+ (unsigned-reg
+ (make-ea :dword :base object :index index :scale 4
+ :disp (- (* ,offset n-word-bytes)
+ ,lowtag)))
+ (t
+ (make-ea :dword :base object :index index
+ :disp (- (* ,offset n-word-bytes)
+ ,lowtag))))))
+ (inst cmpxchg ea new-value))
+ (move value eax)))))
+
(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
`(progn
(define-vop (,name)
;;; 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.5.5"
+"1.0.5.6"
projects / sbcl.git / commitdiff