Permalink
Browse files

1.0.7.19: SB-EXT:COMPARE-AND-SWAP

 * New macro SB-EXT:COMPARE-AND-SWAP provides a supported interface to
   compare-and-swap functionality.

 * New info-type :FUNCTION :STRUCTURE-ACCESSOR allows us to map from
   defstruct slot-accessor names to defstruct descriptions.

 * Add :CAS-TRANS slot keyword to DEFINE-PRIMITIVE object, and the
   compiler machinery needed to support compare and swap on primitive
   object slots.

 * New VOPs COMPARE-AND-SWAP-SLOT and %COMPARE-AND-SWAP-SYMBOL-VALUE.

 * Delete now unnecessary DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP.

 * Use a consistent %COMPARE-AND-SWAP-FOO naming scheme for CAS
   functions.

 * Tests.

 Tested on x86/Linux & x86/Darwin, x86-64/Darwi, and PPC/Darwin.
  • Loading branch information...
1 parent f34fee2 commit bfb19d306581ac86feb4371846c4b9953d692dd8 @nikodemus nikodemus committed Jul 15, 2007
View
2 NEWS
@@ -1,5 +1,7 @@
;;;; -*- 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).
@@ -323,6 +323,9 @@
;; :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
View
@@ -274,7 +274,8 @@ cd $original_dir
# 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
@@ -285,7 +286,8 @@ if [ "$sbcl_arch" = "x86" ]; then
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
@@ -240,6 +240,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"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"
@@ -338,6 +339,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"VAR-ALLOC"
"SAFE-FDEFN-FUN"
"NOTE-FIXUP"
+ "DEF-CASSER"
"DEF-REFFER"
"EMIT-NOP"
"DEF-SETTER"
@@ -578,6 +580,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"*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"
@@ -1137,7 +1141,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%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"
@@ -1180,7 +1191,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%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"
@@ -1246,7 +1256,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
#!+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"
@@ -1463,15 +1472,13 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
"SPECIALIZABLE" "SPECIALIZABLE-VECTOR" "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"
View
@@ -56,19 +56,6 @@
(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.
View
@@ -1034,6 +1034,7 @@
(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)
@@ -48,26 +48,7 @@
;;; 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))
@@ -85,3 +66,77 @@
(- (* ,(+ 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))
@@ -31,15 +31,6 @@
(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)
@@ -181,25 +181,19 @@ in future versions."
(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,
@@ -226,14 +220,9 @@ in future versions."
"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
@@ -275,7 +264,7 @@ NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available."
(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)
@@ -285,7 +274,7 @@ NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available."
(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)
View
@@ -1554,9 +1554,9 @@
(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))
@@ -34,3 +34,9 @@
(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)))))
@@ -40,8 +40,10 @@
(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
@@ -321,6 +323,7 @@
(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
@@ -32,6 +32,20 @@
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))
Oops, something went wrong.

0 comments on commit bfb19d3

Please sign in to comment.