;;;; -*- coding: utf-8; -*-
changes in sbcl-1.0.8 relative to sbcl-1.0.7:
+ * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides
+ atomic compare-and-swap operations on threaded platforms.
* enhancement: experimental function SB-EXT:RESTRICT-COMPILER-POLICY
allows assining a global minimum value to optimization qualities
(overriding proclamations and declarations).
;; :alien-callbacks
;; Alien callbacks have been implemented for this platform.
;;
+ ;; :compare-and-swap-vops
+ ;; The backend implements compare-and-swap VOPs.
+ ;;
;; operating system features:
;; :linux = We're intended to run under some version of Linux.
;; :bsd = We're intended to run under some version of BSD Unix. (This
# if we're building for x86. -- CSR, 2002-02-21 Then we do something
# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
if [ "$sbcl_arch" = "x86" ]; then
- printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :unwind-to-frame-and-call-vop' >> $ltf
+ printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
+ printf ' :compare-and-swap-vop :unwind-to-frame-and-call-vop' >> $ltf
printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ] || [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "darwin" ] || [ "$sbcl_os" = "win32" ]; then
printf ' :linkage-table' >> $ltf
printf ' :os-provides-dlopen' >> $ltf
fi
elif [ "$sbcl_arch" = "x86-64" ]; then
- printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table :unwind-to-frame-and-call-vop' >> $ltf
+ printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
+ printf ' :compare-and-swap-vop :unwind-to-frame-and-call-vop' >> $ltf
printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
elif [ "$sbcl_arch" = "mips" ]; then
printf ' :linkage-table' >> $ltf
"CLOSURE-INIT" "CLOSURE-REF"
"CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
"*CODE-COVERAGE-INFO*"
+ "COMPARE-AND-SWAP-SLOT"
"COMPILE-IN-LEXENV"
"COMPILE-LAMBDA-FOR-DEFUN"
"%COMPILER-DEFUN" "COMPILER-ERROR" "FATAL-COMPILER-ERROR"
"VAR-ALLOC"
"SAFE-FDEFN-FUN"
"NOTE-FIXUP"
+ "DEF-CASSER"
"DEF-REFFER"
"EMIT-NOP"
"DEF-SETTER"
"*POSIX-ARGV*" "*CORE-PATHNAME*"
"POSIX-GETENV" "POSIX-ENVIRON"
+ "COMPARE-AND-SWAP"
+
;; People have various good reasons to mess with the GC.
"*AFTER-GC-HOOKS*"
"BYTES-CONSED-BETWEEN-GCS"
"%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASIN" "%ASINH"
"%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC"
"%CHECK-BOUND" "%CHECK-VECTOR-SEQUENCE-BOUNDS"
- "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
+ "%CLOSURE-FUN" "%CLOSURE-INDEX-REF"
+ "%COMPARE-AND-SWAP-CAR"
+ "%COMPARE-AND-SWAP-CDR"
+ "%COMPARE-AND-SWAP-INSTANCE-REF"
+ "%COMPARE-AND-SWAP-SVREF"
+ "%COMPARE-AND-SWAP-SYMBOL-PLIST"
+ "%COMPARE-AND-SWAP-SYMBOL-VALUE"
+ "%COS" "%COS-QUICK"
"%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
"%DOUBLE-FLOAT" "%DPB" "%EQL" "%EXP" "%EXPM1" "%FIND-POSITION"
"%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
"%SET-SIGNED-SAP-REF-WORD"
"%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF"
"%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"
#!+long-float "DECODE-LONG-FLOAT"
"DECODE-SINGLE-FLOAT"
"DEFINE-STRUCTURE-SLOT-ADDRESSOR"
- "DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP"
"DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
"!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO"
"DISPLACED-TO-ARRAY-TOO-SMALL-ERROR"
"SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P"
#!+sb-unicode "SIMPLE-CHARACTER-STRING-P"
"SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY"
- "SIMPLE-VECTOR-COMPARE-AND-SWAP"
"SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND"
"SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
"STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR"
"STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC"
"SYMBOLS-DESIGNATOR"
- "%INSTANCE-COMPARE-AND-SWAP"
"%INSTANCE-LENGTH"
"%INSTANCE-REF"
"%INSTANCE-SET"
(values vector index))
(values array index)))
-(declaim (inline simple-vector-compare-and-swap))
-(defun simple-vector-compare-and-swap (vector index old new)
- #!+(or x86 x86-64)
- (%simple-vector-compare-and-swap vector
- (%check-bound vector (length 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.
(let* ((accessor-name (dsd-accessor-name dsd))
(dsd-type (dsd-type dsd)))
(when accessor-name
+ (setf (info :function :structure-accessor accessor-name) dd)
(let ((inherited (accessor-inherited-data accessor-name dd)))
(cond
((not inherited)
;;; Used internally, but it would be nice to provide something
;;; like this for users as well.
-(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)))
- (type (when slotd (dsd-type slotd)))
- (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 old new))
- (%instance-compare-and-swap instance ,index old new)))))
-;;; Ditto
#!+sb-thread
(defmacro define-structure-slot-addressor (name &key structure slot)
(let* ((dd (find-defstruct-description structure t))
(- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
sb!vm:instance-pointer-lowtag)))))))
+(defmacro compare-and-swap (place old new)
+ "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
+Two values are considered to match if they are EQ. Returns the previous value
+of PLACE: if the returned value if EQ to OLD, the swap was carried out.
+
+PLACE must be an accessor form whose CAR is one of the following:
+
+ CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
+
+or the name of a DEFSTRUCT created accessor for a slot whose declared type is
+either FIXNUM or T. Results are unspecified if the slot has a declared type
+other then FIXNUM or T.
+
+EXPERIMENTAL: Interface subject to change."
+ (flet ((invalid-place ()
+ (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
+ (unless (consp place)
+ (invalid-place))
+ ;; FIXME: Not the nicest way to do this...
+ (destructuring-bind (op &rest args) place
+ (case op
+ ((car first)
+ `(%compare-and-swap-car (the cons ,@args) ,old ,new))
+ ((cdr rest)
+ `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
+ (symbol-plist
+ `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old ,new))
+ (symbol-value
+ `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
+ (svref
+ (let ((vector (car args))
+ (index (cadr args)))
+ (unless (and vector index (not (cddr args)))
+ (invalid-place))
+ (with-unique-names (v)
+ `(let ((,v ,vector))
+ (declare (simple-vector ,v))
+ (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
+ (t
+ (let ((dd (info :function :structure-accessor op)))
+ (if dd
+ (let* ((structure (dd-name dd))
+ (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
+ (index (dsd-index slotd))
+ (type (dsd-type slotd)))
+ (unless (eq t (dsd-raw-type slotd))
+ (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
+ place))
+ (when (dsd-read-only slotd)
+ (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
+ place))
+ `(truly-the (values ,type &optional)
+ (%compare-and-swap-instance-ref (the ,structure ,@args)
+ ,index
+ (the ,type ,old) (the ,type ,new))))
+ (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
+
+(macrolet ((def (name lambda-list ref &optional set)
+ `(defun ,name (,@lambda-list old new)
+ #!+compare-and-swap-vops
+ (,name ,@lambda-list old new)
+ #!-compare-and-swap-vops
+ (let ((current (,ref ,@lambda-list)))
+ (when (eq current old)
+ ,(if set
+ `(,set ,@lambda-list new)
+ `(setf (,ref ,@lambda-list) new)))
+ current))))
+ (def %compare-and-swap-car (cons) car)
+ (def %compare-and-swap-cdr (cons) cdr)
+ (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
+ (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
+ (def %compare-and-swap-symbol-value (symbol) symbol-value)
+ (def %compare-and-swap-svref (vector index) svref))
(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)
(declare (type (unsigned-byte 27) n))
(sb!vm::current-thread-offset-sap n))
-;;;; spinlocks
-(define-structure-slot-compare-and-swap
- compare-and-swap-spinlock-value
- :structure spinlock
- :slot value)
-
(declaim (inline get-spinlock release-spinlock))
;; Should always be called with interrupts disabled.
(defun get-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0)))
(let* ((new *current-thread*)
- (old (compare-and-swap-spinlock-value spinlock nil new)))
+ (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)))
(when old
(when (eq old new)
(error "Recursive lock attempt on ~S." spinlock))
#!+sb-thread
(flet ((cas ()
- (unless (compare-and-swap-spinlock-value spinlock nil new)
+ (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
(return-from get-spinlock t))))
(if (and (not *interrupts-enabled*) *allow-with-interrupts*)
;; If interrupts are enabled, but we are allowed to enabled them,
"The value of the mutex. NIL if the mutex is free. Setfable.")
#!+(and sb-thread (not sb-lutex))
-(progn
- (define-structure-slot-addressor mutex-value-address
+(define-structure-slot-addressor mutex-value-address
:structure mutex
:slot value)
- (define-structure-slot-compare-and-swap
- compare-and-swap-mutex-value
- :structure mutex
- :slot value))
(defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t))
#!+sb-doc
(setf (mutex-value mutex) new-value))
#!-sb-lutex
(let (old)
- (when (and (setf old (compare-and-swap-mutex-value mutex nil new-value))
+ (when (and (setf old (sb!ext:compare-and-swap (mutex-value mutex) nil new-value))
waitp)
(loop while old
do (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
(or to-sec -1)
(or to-usec 0))))
(signal-deadline)))
- (setf old (compare-and-swap-mutex-value mutex nil new-value))))
+ (setf old (sb!ext:compare-and-swap (mutex-value mutex) nil new-value))))
(not old))))
(defun release-mutex (mutex)
(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)))
+(defknown %compare-and-swap-svref (simple-vector index t t) t
+ (unsafe))
+(defknown %compare-and-swap-instance-ref (instance index t t) t
+ (unsafe))
+(defknown %compare-and-swap-symbol-value (symbol t t) t
+ (unsafe unwind))
(ir2-convert-fixed-allocation node block name words header
lowtag inits)))))
name)
+
+(defun %def-casser (name offset lowtag)
+ (let ((fun-info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert fun-info)
+ (lambda (node block)
+ (ir2-convert-casser node block name offset lowtag)))))
(define-primitive-object (cons :lowtag list-pointer-lowtag
:alloc-trans cons)
- (car :ref-trans car :set-trans sb!c::%rplaca :init :arg)
- (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg))
+ (car :ref-trans car :set-trans sb!c::%rplaca :init :arg
+ :cas-trans %compare-and-swap-car)
+ (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg
+ :cas-trans %compare-and-swap-cdr))
(define-primitive-object (instance :lowtag instance-pointer-lowtag
:widetag instance-header-widetag
(plist :ref-trans symbol-plist
:set-trans %set-symbol-plist
+ :cas-trans %compare-and-swap-symbol-plist
:init :null)
(name :ref-trans symbol-name :init :arg)
(package :ref-trans symbol-package
name offset lowtag)
(move-lvar-result node block (list value-tn) (node-lvar node))))
+#!+compare-and-swap-vops
+(defoptimizer ir2-convert-casser
+ ((object old new) node block name offset lowtag)
+ (let* ((lvar (node-lvar node))
+ (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
+ (res (first locs)))
+ (vop compare-and-swap-slot node block
+ (lvar-tn node block object)
+ (lvar-tn node block old)
+ (lvar-tn node block new)
+ name offset lowtag
+ res)
+ (move-lvar-result node block locs lvar)))
+
(defun emit-inits (node block name result lowtag inits args)
(let ((unbound-marker-tn nil)
(funcallable-instance-tramp-tn nil))
((:type slot-type) t) init
(ref-known nil ref-known-p) ref-trans
(set-known nil set-known-p) set-trans
+ cas-trans
&allow-other-keys)
(if (atom spec) (list spec) spec)
(slots (make-slot slot-name docs rest-p offset
,slot-type
,set-known)))
(forms `(def-setter ,set-trans ,offset ,lowtag)))
+ (when cas-trans
+ (when rest-p
+ (error ":REST-P and :CAS-TRANS incompatible."))
+ (forms
+ `(progn
+ (defknown ,cas-trans (,type ,slot-type ,slot-type)
+ ,slot-type (unsafe))
+ #!+compare-and-swap-vops
+ (def-casser ,cas-trans ,offset ,lowtag))))
(when init
(inits (cons init offset)))
(when rest-p
`(%def-setter ',name ,offset ,lowtag))
(defmacro def-alloc (name words variable-length-p header lowtag inits)
`(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits))
+#!+compare-and-swap-vops
+(defmacro def-casser (name offset lowtag)
+ `(%def-casser ',name ,offset ,lowtag))
;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
;;; are defined later in another file, since they use structure slot
;;; setters defined later, and we can't have physical forward
:type :definition
:type-spec (or fdefn null)
:default nil)
+
+(define-info-type
+ :class :function
+ :type :structure-accessor
+ :type-spec (or defstruct-description null)
+ :default nil)
\f
;;;; definitions for other miscellaneous information
(frob :kind)
(frob :inline-expansion-designator)
(frob :source-transform)
+ (frob :structure-accessor)
(frob :assumed-type)))
(values))
(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)
+(define-full-compare-and-swap %compare-and-swap-svref simple-vector
+ vector-data-offset other-pointer-lowtag
+ (descriptor-reg any-reg) *
+ %compare-and-swap-svref)
\f
;;;; integer vectors whose elements are smaller than a byte, i.e.,
;;;; bit, 2-bit, and 4-bit vectors
temp))
;; Else, value not immediate.
(storew value object offset lowtag))))
-\f
-
+(define-vop (compare-and-swap-slot)
+ (:args (object :scs (descriptor-reg) :to :eval)
+ (old :scs (descriptor-reg any-reg) :target rax)
+ (new :scs (descriptor-reg any-reg)))
+ (:temporary (:sc descriptor-reg :offset rax-offset
+ :from (:argument 1) :to :result :target result)
+ rax)
+ (:info name offset lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:generator 5
+ (move rax old)
+ #!+sb-thread
+ (inst lock)
+ (inst cmpxchg (make-ea :qword :base object
+ :disp (- (* offset n-word-bytes) lowtag))
+ new)
+ (move result rax)))
+\f
;;;; symbol hacking VOPs
+(define-vop (%compare-and-swap-symbol-value)
+ (:translate %compare-and-swap-symbol-value)
+ (:args (symbol :scs (descriptor-reg) :to (:result 1))
+ (old :scs (descriptor-reg any-reg) :target rax)
+ (new :scs (descriptor-reg any-reg)))
+ (:temporary (:sc descriptor-reg :offset rax-offset) rax)
+ #!+sb-thread
+ (:temporary (:sc descriptor-reg) tls)
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 15
+ ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
+ ;; or UNBOUND-MARKER as NEW: in either case we would end up
+ ;; doing possible damage with CMPXCHG -- so don't do that!
+ (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
+ (check (gen-label)))
+ (move rax old)
+ #!+sb-thread
+ (progn
+ (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+ ;; Thread-local area, not LOCK needed.
+ (inst cmpxchg (make-ea :qword :base thread-base-tn
+ :index tls :scale 1)
+ new)
+ (inst cmp rax no-tls-value-marker-widetag)
+ (inst jmp :ne check)
+ (move rax old)
+ (inst lock))
+ (inst cmpxchg (make-ea :qword :base symbol
+ :disp (- (* symbol-value-slot n-word-bytes)
+ other-pointer-lowtag)
+ :scale 1)
+ new)
+ (emit-label check)
+ (move result rax)
+ (inst cmp result unbound-marker-widetag)
+ (inst jmp :e unbound))))
+
;;; these next two cf the sparc version, by jrd.
;;; FIXME: Deref this ^ reference.
(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)
+(define-full-compare-and-swap %compare-and-swap-instance-ref instance
+ instance-slots-offset instance-pointer-lowtag
+ (any-reg descriptor-reg) *
+ %compare-and-swap-instance-ref)
\f
;;;; code object frobbing
#!+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)
+(define-full-compare-and-swap %compare-and-swap-svref simple-vector
+ vector-data-offset other-pointer-lowtag
+ (descriptor-reg any-reg) *
+ %compare-and-swap-svref)
\f
;;;; integer vectors whose elements are smaller than a byte, i.e.,
;;;; bit, 2-bit, and 4-bit vectors
(:results)
(:generator 1
(storew (encode-value-if-immediate value) object offset lowtag)))
-\f
-
+(define-vop (compare-and-swap-slot)
+ (:args (object :scs (descriptor-reg) :to :eval)
+ (old :scs (descriptor-reg any-reg) :target eax)
+ (new :scs (descriptor-reg any-reg)))
+ (:temporary (:sc descriptor-reg :offset eax-offset
+ :from (:argument 1) :to :result :target result)
+ eax)
+ (:info name offset lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:generator 5
+ (move eax old)
+ #!+sb-thread
+ (inst lock)
+ (inst cmpxchg (make-ea :dword :base object
+ :disp (- (* offset n-word-bytes) lowtag))
+ new)
+ (move result eax)))
+\f
;;;; symbol hacking VOPs
+(define-vop (%compare-and-swap-symbol-value)
+ (:translate %compare-and-swap-symbol-value)
+ (:args (symbol :scs (descriptor-reg) :to (:result 1))
+ (old :scs (descriptor-reg any-reg) :target eax)
+ (new :scs (descriptor-reg any-reg)))
+ (:temporary (:sc descriptor-reg :offset eax-offset) eax)
+ #!+sb-thread
+ (:temporary (:sc descriptor-reg) tls)
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 15
+ ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
+ ;; or UNBOUND-MARKER as NEW: in either case we would end up
+ ;; doing possible damage with CMPXCHG -- so don't do that!
+ (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
+ (check (gen-label)))
+ (move eax old)
+ #!+sb-thread
+ (progn
+ (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+ ;; Thread-local area, not LOCK needed.
+ (inst fs-segment-prefix)
+ (inst cmpxchg (make-ea :dword :base tls) new)
+ (inst cmp eax no-tls-value-marker-widetag)
+ (inst jmp :ne check)
+ (move eax old)
+ (inst lock))
+ (inst cmpxchg (make-ea :dword :base symbol
+ :disp (- (* symbol-value-slot n-word-bytes)
+ other-pointer-lowtag))
+ new)
+ (emit-label check)
+ (move result eax)
+ (inst cmp result unbound-marker-widetag)
+ (inst jmp :e unbound))))
+
;;; these next two cf the sparc version, by jrd.
;;; FIXME: Deref this ^ reference.
(any-reg descriptor-reg) *
%instance-set)
-(define-full-compare-and-swap instance-compare-and-swap instance
+(define-full-compare-and-swap %compare-and-swap-instance-ref instance
instance-slots-offset instance-pointer-lowtag
(any-reg descriptor-reg) *
- %instance-compare-and-swap)
+ %compare-and-swap-instance-ref)
\f
;;;; code object frobbing
(defun cache-key-p (thing)
(not (symbolp thing)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
- :structure cache
- :slot depth))
-
-;;; Utility macro for atomic updates without locking... doesn't
-;;; do much right now, and it would be nice to make this more magical.
-(defmacro compare-and-swap (place old new)
- (unless (consp place)
- (error "Don't know how to compare and swap ~S." place))
- (ecase (car place)
- (svref
- `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
- (cache-depth
- `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
-
;;; Atomically update the current probe depth of a cache.
(defun note-cache-depth (cache depth)
(loop for old = (cache-depth cache)
(type-error ()
:good))))
-;;; SIMPLE-VECTOR-COMPARE-AND-SWAP
-
-(let ((v (vector 1)))
- ;; basics
- (assert (eql 1 (sb-kernel:simple-vector-compare-and-swap v 0 1 2)))
- (assert (eql 2 (sb-kernel:simple-vector-compare-and-swap v 0 1 3)))
- (assert (eql 2 (svref v 0)))
- ;; bounds
- (multiple-value-bind (res err)
- (ignore-errors (sb-kernel:simple-vector-compare-and-swap v -1 1 2))
- (assert (not res))
- (assert (typep err 'type-error)))
- (multiple-value-bind (res err)
- (ignore-errors (sb-kernel:simple-vector-compare-and-swap v 1 1 2))
- (assert (not res))
- (assert (typep err 'type-error))))
-
-;; type of the first argument
-(multiple-value-bind (res err)
- (ignore-errors (sb-kernel:simple-vector-compare-and-swap "foo" 1 1 2))
- (assert (not res))
- (assert (typep err 'type-error)))
--- /dev/null
+;;; Basics
+
+(defstruct xxx yyy)
+
+(macrolet ((test (init op)
+ `(let ((x ,init)
+ (y (list 'foo))
+ (z (list 'bar)))
+ (assert (eql nil (compare-and-swap (,op x) nil y)))
+ (assert (eql y (compare-and-swap (,op x) nil z)))
+ (assert (eql y (,op x)))
+ (let ((x "foo"))
+ (multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (,op x) nil nil))
+ (assert (not res))
+ (assert (typep err 'type-error)))))))
+ (test (cons nil :no) car)
+ (test (cons nil :no) first)
+ (test (cons :no nil) cdr)
+ (test (cons :no nil) rest)
+ (test '.foo. symbol-plist)
+ (test (progn (set '.bar. nil) '.bar.) symbol-value)
+ (test (make-xxx) xxx-yyy))
+
+(defvar *foo*)
+
+;;; thread-local bindings
+
+(let ((*foo* 42))
+ (let ((*foo* nil))
+ (assert (eql nil (compare-and-swap (symbol-value '*foo*) nil t)))
+ (assert (eql t (compare-and-swap (symbol-value '*foo*) nil :foo)))
+ (assert (eql t *foo*)))
+ (assert (eql 42 *foo*)))
+
+;;; unbound symbols + symbol-value
+
+(assert (not (boundp '*foo*)))
+
+(multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
+ (assert (not res))
+ (assert (typep err 'unbound-variable)))
+
+(defvar *bar* t)
+
+(let ((*bar* nil))
+ (makunbound '*bar*)
+ (multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
+ (assert (not res))
+ (assert (typep err 'unbound-variable))))
+
+;;; SVREF
+
+(defvar *v* (vector 1))
+
+;; basics
+(assert (eql 1 (compare-and-swap (svref *v* 0) 1 2)))
+(assert (eql 2 (compare-and-swap (svref *v* 0) 1 3)))
+(assert (eql 2 (svref *v* 0)))
+
+;; bounds
+(multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
+ (assert (not res))
+ (assert (typep err 'type-error)))
+(multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
+ (assert (not res))
+ (assert (typep err 'type-error)))
+
+;; type of the first argument
+(multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
+ (assert (not res))
+ (assert (typep err 'type-error)))
;;; 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.18"
+"1.0.7.19"
projects / sbcl.git / commitdiff