("src/code/macros")
("src/code/loop")
("src/code/late-setf")
+ ("src/code/cas")
+ ("src/code/late-cas")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other target-code-building stuff which can't be processed until
@include macro-sb-ext-atomic-incf.texinfo
@include macro-sb-ext-compare-and-swap.texinfo
+@subsection CAS Protocol
+
+Our @code{compare-and-swap} is user-extensible using a protocol similar
+to @code{setf}:
+
+@include macro-sb-ext-cas.texinfo
+@include macro-sb-ext-define-cas-expander.texinfo
+@include macro-sb-ext-defcas.texinfo
+@include fun-sb-ext-get-cas-expansion.texinfo
+
@node Mutex Support
@comment node-name, next, previous, up
@section Mutex Support
"*USERINIT-PATHNAME-FUNCTION*"
"*SYSINIT-PATHNAME-FUNCTION*"
- ;; Atomic operations and types related to them
+ ;; Compare and Swap support
+ "CAS"
"COMPARE-AND-SWAP"
+ "DEFCAS"
+ "DEFINE-CAS-EXPANDER"
+ "GET-CAS-EXPANSION"
+
+ ;; Other atomic operations and types related to them
"ATOMIC-INCF"
"ATOMIC-DECF"
"WORD"
"RETURN-CHAR-CODE" "RUBOUT-CHAR-CODE" "TAB-CHAR-CODE"
;; symbol-hacking idioms
- "KEYWORDICATE" "SYMBOLICATE"
+ "GENSYMIFY" "KEYWORDICATE" "SYMBOLICATE"
;; certainly doesn't belong in public extensions
;; FIXME: maybe belongs in %KERNEL with other typesystem stuff?
--- /dev/null
+(in-package "SB!IMPL")
+
+;;;; COMPARE-AND-SWAP
+;;;;
+;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now.
+;;;;
+;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER,
+;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with
+;;;; SETF.
+
+(defglobal **cas-expanders** (make-hash-table :test #'eq :synchronized t))
+
+(define-function-name-syntax cas (list)
+ (destructuring-bind (cas symbol) list
+ (aver (eq 'cas cas))
+ (values t symbol)))
+
+;;; This is what it all comes down to.
+(def!macro cas (place old new &environment env)
+ "Synonym for COMPARE-AND-SWAP.
+
+Addtionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to
+define CAS-functions analogously to SETF-functions:
+
+ (defvar *foo* nil)
+
+ (defun (cas foo) (old new)
+ (cas (symbol-value '*foo*) old new))
+
+First argument of a CAS function is the expected old value, and the second
+argument of is the new value. Note that the system provides no automatic
+atomicity for CAS functions, nor can it verify that they are atomic: it is up
+to the implementor of a CAS function to ensure its atomicity.
+
+EXPERIMENTAL: Interface subject to change."
+ (multiple-value-bind (temps place-args old-temp new-temp cas-form)
+ (get-cas-expansion place env)
+ `(let* (,@(mapcar #'list temps place-args)
+ (,old-temp ,old)
+ (,new-temp ,new))
+ ,cas-form)))
+
+(defun get-cas-expansion (place &optional environment)
+ #!+sb-doc
+ "Analogous to GET-SETF-EXPANSION. Return six values needed by the CAS
+machinary: a list of temporary variables, a list of values to which they must
+be bound, a temporary variable for the old value of PLACE, a temporary value
+for the new value of PLACE, a form using the aforementioned temporaries
+which performs the compare-and-swap operation, and a form using the aforementioned
+temporaries with which to perform a volatile read of the place.
+
+Example:
+
+ (get-cas-expansion '(car x))
+ ; => (#:CONS871), (X), #:OLD872, #:NEW873,
+ ; (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873).
+ ; (CAR #:CONS871)
+
+ (defmacro my-atomic-incf (place &optional (delta 1) &environment env)
+ (multiple-value-bind (vars vals old new cas-form read-form)
+ (get-cas-expansion place env)
+ (let ((delta-value (gensym \"DELTA\")))
+ `(let* (,@(mapcar 'list vars vals)
+ (,old ,read-form)
+ (,delta-value ,delta)
+ (,new (+ ,old ,delta-value)))
+ (loop until (eq ,old (setf ,old ,cas-form))
+ do (setf ,new (+ ,old ,delta-value)))
+ ,new))))
+
+EXPERIMENTAL: Interface subject to change."
+ (flet ((invalid-place ()
+ (error "Invalid place to CAS: ~S" place)))
+ (let ((expanded (sb!xc:macroexpand place environment)))
+ (unless (consp expanded)
+ ;; FIXME: Allow (CAS *FOO* <OLD> <NEW>), maybe?
+ (invalid-place))
+ (let ((name (car expanded)))
+ (unless (symbolp name)
+ (invalid-place))
+ (let ((info (gethash name **cas-expanders**)))
+ (cond
+ ;; CAS expander.
+ (info
+ (funcall info place environment))
+
+ ;; Structure accessor
+ ((setf info (info :function :structure-accessor name))
+ (expand-structure-slot-cas info name expanded))
+
+ ;; CAS function
+ (t
+ (with-unique-names (old new)
+ (let ((vars nil)
+ (vals nil)
+ (args nil))
+ (dolist (x (reverse (cdr expanded)))
+ (cond ((constantp x environment)
+ (push x args))
+ (t
+ (let ((tmp (gensymify x)))
+ (push tmp args)
+ (push tmp vars)
+ (push x vals)))))
+ (values vars vals old new
+ `(funcall #'(cas ,name) ,old ,new ,@args)
+ `(,name ,@args)))))))))))
+
+(defun expand-structure-slot-cas (dd name place)
+ (let* ((structure (dd-name dd))
+ (slotd (find name (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))
+ (destructuring-bind (op arg) place
+ (aver (eq op name))
+ (with-unique-names (instance old new)
+ (values (list instance)
+ (list arg)
+ old
+ new
+ `(truly-the (values ,type &optional)
+ (%compare-and-swap-instance-ref
+ (the ,structure ,instance)
+ ,index
+ (the ,type ,old)
+ (the ,type ,new)))
+ `(,op ,instance))))))
+
+(def!macro define-cas-expander (accessor lambda-list &body body)
+ "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR.
+BODY must return six values as specified in GET-CAS-EXPANSION.
+
+Note that the system provides no automatic atomicity for CAS expansion, nor
+can it verify that they are atomic: it is up to the implementor of a CAS
+expansion to ensure its atomicity.
+
+EXPERIMENTAL: Interface subject to change."
+ (with-unique-names (whole environment)
+ (multiple-value-bind (body decls doc)
+ (parse-defmacro lambda-list whole body accessor
+ 'define-cas-expander
+ :environment environment
+ :wrap-block nil)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (gethash ',accessor **cas-expanders**)
+ (lambda (,whole ,environment)
+ ,@(when doc (list doc))
+ ,@decls
+ ,body))))))
+
+(def!macro defcas (&whole form accessor lambda-list function
+ &optional docstring)
+ "Analogous to short-form DEFSETF. Defines FUNCTION as responsible
+for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST
+must correspond to the lambda-list of the accessor.
+
+Note that the system provides no automatic atomicity for CAS expansions
+resulting from DEFCAS, nor can it verify that they are atomic: it is up to the
+user of DEFCAS to ensure that the function specified is atomic.
+
+EXPERIMENTAL: Interface subject to change."
+ (multiple-value-bind (reqs opts restp rest keyp keys allowp auxp)
+ (parse-lambda-list lambda-list)
+ (declare (ignore keys))
+ (when (or keyp allowp auxp)
+ (error "&KEY, &AUX, and &ALLOW-OTHER-KEYS not allowed in DEFCAS ~
+ lambda-list.~% ~S" form))
+ `(define-cas-expander ,accessor ,lambda-list
+ ,@(when docstring (list docstring))
+ (let ((temps (mapcar #'gensymify
+ ',(append reqs opts
+ (when restp (list (gensymify rest))))))
+ (args (list ,@(append reqs
+ opts
+ (when restp (list rest)))))
+ (old (gensym "OLD"))
+ (new (gensym "NEW")))
+ (values temps
+ args
+ old
+ new
+ `(,',function ,@temps ,old ,new)
+ `(,',accessor ,@temps))))))
+
+(def!macro compare-and-swap (place old new)
+ #!+sb-doc
+ "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 is 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, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE
+ SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS,
+
+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.
+
+In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless
+OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is
+returned and NEW is assigned to the slot.
+
+Additionally, the results are unspecified if there is an applicable method on
+either SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or
+SB-MOP:SLOT-BOUNDP-USING-CLASS.
+
+EXPERIMENTAL: Interface subject to change."
+ `(cas ,place ,old ,new))
+
+;;; Out-of-line definitions for various primitive cas functions.
+(macrolet ((def (name lambda-list ref &optional set)
+ #!+compare-and-swap-vops
+ (declare (ignore ref set))
+ `(defun ,name (,@lambda-list old new)
+ #!+compare-and-swap-vops
+ (,name ,@lambda-list old new)
+ #!-compare-and-swap-vops
+ (progn
+ #!+sb-thread
+ ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
+ #!-sb-thread
+ (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))
+
name)
(declaim (declaration enable-package-locks disable-package-locks))
+
+;;; printing structures
+
+(defun sb!kernel::default-structure-print (structure stream depth)
+ (declare (ignore depth))
+ (write structure :stream stream :circle t))
(cond ((sb!xc:constantp x environment)
(push x args))
(t
- (let ((temp (gensym "TMP")))
+ (let ((temp (gensymify x)))
(push temp args)
(push temp vars)
(push x vals)))))
--- /dev/null
+(in-package "SB!IMPL")
+
+(defcas car (cons) %compare-and-swap-car)
+(defcas cdr (cons) %compare-and-swap-cdr)
+(defcas first (cons) %compare-and-swap-car)
+(defcas rest (cons) %compare-and-swap-cdr)
+(defcas symbol-plist (symbol) %compare-and-swap-symbol-plist)
+
+(define-cas-expander symbol-value (name &environment env)
+ (multiple-value-bind (tmp val cname)
+ (if (sb!xc:constantp name env)
+ (values nil nil (constant-form-value name env))
+ (values (gensymify name) name nil))
+ (with-unique-names (old new)
+ (values (when tmp (list tmp))
+ (when val (list val))
+ old
+ new
+ (let ((slow
+ `(locally
+ (declare (symbol ,tmp))
+ (about-to-modify-symbol-value ,tmp 'compare-and-swap ,new)
+ (%compare-and-swap-symbol-value ,tmp ,old ,new))))
+ (if cname
+ (if (member (info :variable :kind cname) '(:special :global))
+ ;; We can generate the type-check reasonably.
+ `(%compare-and-swap-symbol-value
+ ',cname ,old (the ,(info :variable :type cname) ,new))
+ slow)
+ slow))
+ `(symbol-global-value ,tmp)))))
+
+(define-cas-expander svref (vector index)
+ (with-unique-names (v i old new)
+ (values (list v i)
+ (list vector index)
+ old
+ new
+ `(locally (declare (simple-vector ,v))
+ (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,i) ,old ,new))
+ `(svref ,v ,i))))
sb!vm:n-word-bytes)
sb!vm:instance-pointer-lowtag)))))))
-(defmacro compare-and-swap (place old new &environment env)
- "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 is 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 (the list ,new)))
- (symbol-value
- (destructuring-bind (name) args
- (flet ((slow (symbol)
- (with-unique-names (n-symbol n-old n-new)
- `(let ((,n-symbol ,symbol)
- (,n-old ,old)
- (,n-new ,new))
- (declare (symbol ,n-symbol))
- (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new)
- (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
- (if (sb!xc:constantp name env)
- (let ((cname (constant-form-value name env)))
- (if (eq :special (info :variable :kind cname))
- ;; Since we know the symbol is a special, we can just generate
- ;; the type check.
- `(%compare-and-swap-symbol-value
- ',cname ,old (the ,(info :variable :type cname) ,new))
- (slow (list 'quote cname))))
- (slow name)))))
- (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)
- #!+compare-and-swap-vops
- (declare (ignore ref 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))
+;;;; ATOMIC-INCF and ATOMIC-DECF
(defun expand-atomic-frob (name place diff)
(flet ((invalid-place ()
(replace name x :start1 index)
(incf index len)))))))
+(defun gensymify (x)
+ (if (symbolp x)
+ (sb!xc:gensym (symbol-name x))
+ (sb!xc:gensym)))
+
;;; like SYMBOLICATE, but producing keywords
(defun keywordicate (&rest things)
(let ((*package* *keyword-package*))
(%with-cas-lock (,place) ,@body)))
(defmacro %with-cas-lock ((place) &body body &environment env)
- (with-unique-names (self owner)
- ;; Take care not to multiply-evaluate anything.
- ;;
- ;; FIXME: Once we get DEFCAS this can use GET-CAS-EXPANSION.
- (let* ((placex (sb!xc:macroexpand place env))
- (place-op (if (consp placex)
- (car placex)
- (error "~S: ~S is not a valid place for ~S"
- 'with-cas-lock
- place 'sb!ext:compare-and-swap)))
- (place-args (cdr placex))
- (temps (make-gensym-list (length place-args) t))
- (place `(,place-op ,@temps)))
- `(let* (,@(mapcar #'list temps place-args)
+ (with-unique-names (owner self)
+ (multiple-value-bind (vars vals old new cas-form read-form)
+ (sb!ext:get-cas-expansion place env)
+ `(let* (,@(mapcar #'list vars vals)
+ (,owner ,read-form)
(,self *current-thread*)
- (,owner ,place))
+ (,old nil)
+ (,new ,self))
(unwind-protect
(progn
(unless (eq ,owner ,self)
- (loop while (setf ,owner
- (or ,place
- (sb!ext:compare-and-swap ,place nil ,self)))
+ (loop while (setf ,owner (or ,read-form ,cas-form))
do (thread-yield)))
,@body)
(unless (eq ,owner ,self)
- (sb!ext:compare-and-swap ,place ,self nil)))))))
+ (let ((,old ,self)
+ (,new nil))
+ ,cas-form)))))))
;;; Conditions
\f
;;;; the primitive objects themselves
-(define-primitive-object (cons :lowtag list-pointer-lowtag
+(define-primitive-object (cons :type cons
+ :lowtag list-pointer-lowtag
:alloc-trans cons)
(car :ref-trans car :set-trans sb!c::%rplaca :init :arg
:cas-trans %compare-and-swap-car)
(define-primitive-object (symbol :lowtag other-pointer-lowtag
:widetag symbol-header-widetag
- :alloc-trans %make-symbol)
+ :alloc-trans %make-symbol
+ :type symbol)
;; Beware when changing this definition. NIL-the-symbol is defined
;; using this layout, and NIL-the-end-of-list-marker is the cons
\f
;;;; STANDARD-INSTANCE-ACCESS
-(declaim (inline standard-instance-access (setf standard-instance-access)
+(declaim (inline standard-instance-access
+ (setf standard-instance-access)
+ (cas stadard-instance-access)
funcallable-standard-instance-access
- (setf funcallable-standard-instance-access)))
+ (setf funcallable-standard-instance-access)
+ (cas funcallable-standard-instance-access)))
(defun standard-instance-access (instance location)
(clos-slots-ref (std-instance-slots instance) location))
(defun (setf standard-instance-access) (new-value instance location)
(setf (clos-slots-ref (std-instance-slots instance) location) new-value))
+(defun (cas standard-instance-access) (old-value new-value instance location)
+ ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
+ (cas (svref (std-instance-slots instance) location) old-value new-value))
+
(defun funcallable-standard-instance-access (instance location)
(clos-slots-ref (fsc-instance-slots instance) location))
(defun (setf funcallable-standard-instance-access) (new-value instance location)
(setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
+
+(defun (cas funcallable-standard-instance-access) (old-value new-value instance location)
+ ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
+ (cas (svref (fsc-instance-slots instance) location) old-value new-value))
\f
;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
`(accessor-set-slot-value ,object ,slot-name ,new-value)
form))
+(defun (cas slot-value) (old-value new-value object slot-name)
+ (let* ((wrapper (valid-wrapper-of object))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-value
+ (values (slot-missing (wrapper-class* wrapper) object slot-name
+ 'cas (list old-value new-value))))))
+ (location (car cell))
+ (info (cdr cell))
+ (typecheck (slot-info-typecheck info)))
+ (when typecheck
+ (funcall typecheck new-value))
+ (let ((old (cond ((fixnump location)
+ (if (std-instance-p object)
+ (cas (standard-instance-access object location) old-value new-value)
+ (cas (funcallable-standard-instance-access object location)
+ old-value new-value)))
+ ((consp location)
+ (cas (cdr location) old-value new-value))
+ ((not location)
+ ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)...
+ (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object))
+ (t
+ (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell)))))
+ (if (and (eq +slot-unbound+ old)
+ (neq old old-value))
+ (slot-unbound (wrapper-class* wrapper) object slot-name)
+ old))))
+
(defun slot-boundp (object slot-name)
(let* ((wrapper (valid-wrapper-of object))
(cell (or (find-slot-cell wrapper slot-name)
(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)))))))
+ `(with-test (:name (:cas :basics ,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))
+ (unless (not res)
+ (error "Wanted NIL and type-error, got: ~S" res))
+ (assert (typep err 'type-error))))))))
(test (cons nil :no) car)
(test (cons nil :no) first)
(test (cons :no nil) cdr)
;;; 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*)))
+(with-test (:name (:cas :tls))
+ (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)))
+(with-test (:name (:cas :unbound))
+ (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))))
+(with-test (:name (:cas :unbound 2))
+ (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)))
+(with-test (:name (:cas :svref))
+ (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)))
+(with-test (:name (:cas :svref :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))
+(with-test (:name (:cas :svref :type))
+ (multiple-value-bind (res err)
+ (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
(assert (not res))
- (assert (typep err 'type-error)))
+ (assert (typep err 'type-error))))
;; Check that we don't modify constants
(defconstant +a-constant+ 42)
-(assert
- (eq :error
- (handler-case
- (sb-ext:compare-and-swap (symbol-value '+a-constant+) 42 13)
- (error () :error))))
-(let ((name '+a-constant+))
+(with-test (:name (:cas :symbol-value :constant-modification))
(assert
(eq :error
(handler-case
- (sb-ext:compare-and-swap (symbol-value name) 42 13)
- (error () :error)))))
+ (sb-ext:compare-and-swap (symbol-value '+a-constant+) 42 13)
+ (error () :error))))
+ (let ((name '+a-constant+))
+ (assert
+ (eq :error
+ (handler-case
+ (sb-ext:compare-and-swap (symbol-value name) 42 13)
+ (error () :error))))))
;; Check that we don't mess declaimed types
(declaim (boolean *a-boolean*))
(defparameter *a-boolean* t)
-(assert
- (eq :error
- (handler-case
- (sb-ext:compare-and-swap (symbol-value '*a-boolean*) t 42)
- (error () :error))))
-(let ((name '*a-boolean*))
+(with-test (:name (:cas :symbol-value :type-checking))
(assert
(eq :error
(handler-case
- (sb-ext:compare-and-swap (symbol-value name) t 42)
- (error () :error)))))
+ (sb-ext:compare-and-swap (symbol-value '*a-boolean*) t 42)
+ (error () :error))))
+ (let ((name '*a-boolean*))
+ (assert
+ (eq :error
+ (handler-case
+ (sb-ext:compare-and-swap (symbol-value name) t 42)
+ (error () :error))))))
;;;; ATOMIC-INCF and ATOMIC-DECF (we should probably rename this file atomic-ops...)
(loop repeat n
do (sb-ext:atomic-decf (box-word box))))
-(let ((box (make-box)))
- (inc-box box 10000)
- (assert (= 10000 (box-word box)))
- (dec-box box 10000)
- (assert (= 0 (box-word box))))
+(with-test (:name :atomic-incf/decf)
+ (let ((box (make-box)))
+ (inc-box box 10000)
+ (assert (= 10000 (box-word box)))
+ (dec-box box 10000)
+ (assert (= 0 (box-word box)))))
(with-test (:name :atomic-incf-wraparound)
(let ((box (make-box :word (1- (ash 1 sb-vm:n-word-bits)))))
(assert (= (- (ash 1 sb-vm:n-word-bits) 2) (box-word box)))))
#+sb-thread
-(let* ((box (make-box))
- (threads (loop repeat 64
- collect (sb-thread:make-thread (lambda ()
- (inc-box box 1000)
- (dec-box box 10000)
- (inc-box box 10000)
- (dec-box box 1000))
- :name "inc/dec thread"))))
- (mapc #'sb-thread:join-thread threads)
- (assert (= 0 (box-word box))))
+(with-test (:name (:atomic-incf/decf :threads))
+ (let* ((box (make-box))
+ (threads (loop repeat 64
+ collect (sb-thread:make-thread (lambda ()
+ (inc-box box 1000)
+ (dec-box box 10000)
+ (inc-box box 10000)
+ (dec-box box 1000))
+ :name "inc/dec thread"))))
+ (mapc #'sb-thread:join-thread threads)
+ (assert (= 0 (box-word box)))))
+
+;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
+
+(defclass sia-cas-test ()
+ ((a :initarg :a)
+ (b :initarg :b)))
+
+(with-test (:name (:cas :standard-instance-access))
+ (flet ((slot-loc (slot class)
+ (sb-mop:slot-definition-location
+ (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
+ (let* ((class (find-class 'sia-cas-test))
+ (instance (make-instance class :a 'a :b 'b))
+ (a-loc (slot-loc 'a class))
+ (b-loc (slot-loc 'b class)))
+ (assert (eq 'a (slot-value instance 'a)))
+ (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
+ 'x 'oops)))
+ (assert (eq 'a (sb-mop:standard-instance-access instance a-loc)))
+ (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
+ 'a 'a2)))
+ (assert (eq 'a2 (sb-mop:standard-instance-access instance a-loc)))
+ (assert (eq 'a2 (slot-value instance 'a)))
+ (assert (eq 'b (slot-value instance 'b)))
+ (assert (eq 'b (sb-mop:standard-instance-access instance b-loc))))))
+
+(defclass fia-cas-test (sb-mop:funcallable-standard-object)
+ ((a :initarg :a)
+ (b :initarg :b))
+ (:metaclass sb-mop:funcallable-standard-class))
+
+(with-test (:name (:cas :standard-instance-access))
+ (flet ((slot-loc (slot class)
+ (sb-mop:slot-definition-location
+ (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
+ (let* ((class (find-class 'fia-cas-test))
+ (instance (make-instance class :a 'a :b 'b))
+ (a-loc (slot-loc 'a class))
+ (b-loc (slot-loc 'b class)))
+ (sb-mop:set-funcallable-instance-function instance (lambda () :ok))
+ (eq :ok (funcall instance))
+ (assert (eq 'a (slot-value instance 'a)))
+ (assert (eq 'a (compare-and-swap
+ (sb-mop:funcallable-standard-instance-access instance a-loc)
+ 'x 'oops)))
+ (assert (eq 'a (sb-mop:funcallable-standard-instance-access instance a-loc)))
+ (assert (eq 'a (compare-and-swap
+ (sb-mop:funcallable-standard-instance-access instance a-loc)
+ 'a 'a2)))
+ (assert (eq 'a2 (sb-mop:funcallable-standard-instance-access instance a-loc)))
+ (assert (eq 'a2 (slot-value instance 'a)))
+ (assert (eq 'b (slot-value instance 'b)))
+ (assert (eq 'b (sb-mop:funcallable-standard-instance-access instance b-loc))))))
+
+;;; SLOT-VALUE
+
+(defclass standard-thing ()
+ ((x :initform 42)
+ (y)))
+
+(defmethod slot-unbound ((class standard-class) (obj standard-thing) slot)
+ (list :unbound slot))
+
+(defmethod slot-missing ((class standard-class) (obj standard-thing) slot op &optional val)
+ (list :missing slot op val))
+
+(with-test (:name (:cas :slot-value :standard-object))
+ (let ((x (make-instance 'standard-thing)))
+ (assert (eql 42 (slot-value x 'x)))
+ (assert (eql 42 (compare-and-swap (slot-value x 'x) 0 :foo)))
+ (assert (eql 42 (slot-value x 'x)))
+ (assert (eql 42 (compare-and-swap (slot-value x 'x) 42 :foo)))
+ (assert (eql :foo (slot-value x 'x)))))
+
+(with-test (:name (:cas :slot-value :slot-unbound))
+ (let ((x (make-instance 'standard-thing)))
+ (assert (equal '(:unbound y) (slot-value x 'y)))
+ (assert (equal '(:unbound y) (compare-and-swap (slot-value x 'y) 0 :foo)))
+ (assert (equal '(:unbound y) (slot-value x 'y)))
+ (assert (eq sb-pcl:+slot-unbound+
+ (compare-and-swap (slot-value x 'y) sb-pcl:+slot-unbound+ :foo)))
+ (assert (eq :foo (slot-value x 'y)))))
+
+(with-test (:name (:cas :slot-value :slot-missing))
+ (let ((x (make-instance 'standard-thing)))
+ (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))
+ (assert (equal '(:missing z sb-ext:cas (0 :foo)) (compare-and-swap (slot-value x 'z) 0 :foo)))
+ (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))))
+
+(defclass non-standard-class (standard-class)
+ ())
+
+(defmethod sb-mop:validate-superclass ((class non-standard-class) (superclass standard-class))
+ t)
+
+(defclass non-standard-thing-0 ()
+ ((x :initform 13))
+ (:metaclass non-standard-class))
+
+(defclass non-standard-thing-1 ()
+ ((x :initform 13))
+ (:metaclass non-standard-class))
+
+(defclass non-standard-thing-2 ()
+ ((x :initform 13))
+ (:metaclass non-standard-class))
+
+(defclass non-standard-thing-3 ()
+ ((x :initform 13))
+ (:metaclass non-standard-class))
+
+(defvar *access-list* nil)
+
+(defmethod sb-mop:slot-value-using-class
+ ((class non-standard-class) (obj non-standard-thing-1) slotd)
+ (let ((v (call-next-method)))
+ (push :read *access-list*)
+ v))
+
+(defmethod (setf sb-mop:slot-value-using-class)
+ (value (class non-standard-class) (obj non-standard-thing-2) slotd)
+ (let ((v (call-next-method)))
+ (push :write *access-list*)
+ v))
+
+(defmethod sb-mop:slot-boundp-using-class
+ ((class non-standard-class) (obj non-standard-thing-3) slotd)
+ (let ((v (call-next-method)))
+ (push :boundp *access-list*)
+ v))
+
+(with-test (:name (:cas :slot-value :non-standard-object :standard-access))
+ (let ((x (make-instance 'non-standard-thing-0)))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (eql 13 (compare-and-swap (slot-value x 'x) 0 :bar)))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (eql 13 (compare-and-swap (slot-value x 'x) 13 :bar)))
+ (assert (eql :bar (slot-value x 'x)))))
+
+(with-test (:name (:cas :slot-value :non-standard-object :slot-value-using-class))
+ (setf *access-list* nil)
+ (let ((x (make-instance 'non-standard-thing-1)))
+ (declare (notinline slot-value))
+ (assert (null *access-list*))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (equal '(:read) *access-list*))
+ (assert (eq :error
+ (handler-case
+ (compare-and-swap (slot-value x 'x) 0 :bar)
+ (error () :error))))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (equal '(:read :read) *access-list*))))
+
+(with-test (:name (:cas :slot-value :non-standard-object :setf-slot-value-using-class))
+ (setf *access-list* nil)
+ (let ((x (make-instance 'non-standard-thing-2)))
+ (assert (equal '(:write) *access-list*))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (equal '(:write) *access-list*))
+ (assert (eq :error
+ (handler-case
+ (compare-and-swap (slot-value x 'x) 0 :bar)
+ (error () :error))))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (equal '(:write) *access-list*))))
+
+(with-test (:name (:cas :slot-value :non-standard-object :slot-boundp-using-class))
+ (setf *access-list* nil)
+ (let ((x (make-instance 'non-standard-thing-3)))
+ (assert (equal '(:boundp) *access-list*))
+ (assert (eql 13 (slot-value x 'x)))
+ (assert (eq :error
+ (handler-case
+ (compare-and-swap (slot-value x 'x) 0 :bar)
+ (error () :error))))
+ (assert (eql 13 (slot-value x 'x)))))
+
+(defvar *foo* nil)
+
+(defun foo ()
+ *foo*)
+
+(defun (cas foo) (old new)
+ (cas (symbol-value '*foo*) old new))
+
+(with-test (:name (:cas :defun))
+ (assert (null (foo)))
+ (assert (null (cas (foo) nil t)))
+ (assert (eq t (foo)))
+ (assert (eq t (cas (foo) nil :oops)))
+ (assert (eq t (foo))))
+
+(with-test (:name (:cas :flet))
+ (let (x)
+ (flet (((cas x) (old new)
+ (let ((tmp x))
+ (when (eq tmp old)
+ (setf x new))
+ tmp))
+ (x ()
+ x))
+ (assert (null (x)))
+ (assert (null (cas (x) nil t)))
+ (assert (eq t (x)))
+ (assert (eq t (cas (x) nil :oops)))
+ (assert (eq t (x))))))
+
+(defgeneric (cas thing) (old new thing))
+
+(defmethod (cas thing) (old new (thing cons))
+ (cas (car thing) old new))
+
+(defmethod (cas thing) (old new (thing symbol))
+ (cas (symbol-value thing) old new))
+
+(defgeneric thing (thing)
+ (:method ((x cons))
+ (car x))
+ (:method ((x symbol))
+ (symbol-value x)))
+
+(with-test (:name (:cas :defgeneric))
+ (let ((a (list nil))
+ (b (gensym "X")))
+ (set b nil)
+ (assert (null (thing a)))
+ (assert (null (thing b)))
+ (assert (null (cas (thing a) nil t)))
+ (assert (null (cas (thing b) nil t)))
+ (assert (eq t (thing a)))
+ (assert (eq t (thing b)))
+ (assert (eq t (cas (thing a) nil :oops)))
+ (assert (eq t (cas (thing b) nil :oops)))
+ (assert (eq t (thing a)))
+ (assert (eq t (thing b)))))
projects / sbcl.git / commitdiff