From b71b8da241791687e7752f917ca032d937ba2bbf Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 8 Jun 2011 10:58:59 +0300 Subject: [PATCH] extensible CAS and CAS extensions DEFINE-CAS-EXPANDER and DEFCAS are analogous to DEFINE-SETF-EXPANDER and DEFSETF, including CAS-functions similar to SETF-functions: (defun (cas foo) (old new ...) ...) THis is exported from SB-EXT for users to play with, and used to implement our CAS places internally. Add support for CAS of: * SLOT-VALUE * STANDARD-INSTANCE-ACCESS * FUNCALLABLE-STANDARD-INSTANCE-ACCESS In case of SLOT-VALUE we don't yet support any optimizations or specify results when SLOT-VALUE-USING-CLASS or friends are in play -- perhaps later we can add (CAS SLOT-VALUE-USING-CLASS) &co in order to support it for arbitrary instances. Adding support for permutation vector optimization should not be too hard either, but let's let the dust settle first... --- build-order.lisp-expr | 2 + doc/manual/threading.texinfo | 10 + package-data-list.lisp-expr | 10 +- src/code/cas.lisp | 243 ++++++++++++++++++++++ src/code/cross-misc.lisp | 6 + src/code/early-setf.lisp | 2 +- src/code/late-cas.lisp | 41 ++++ src/code/late-extensions.lisp | 94 +-------- src/code/primordial-extensions.lisp | 5 + src/code/target-thread.lisp | 30 +-- src/compiler/generic/objdef.lisp | 6 +- src/pcl/slots.lisp | 43 +++- tests/compare-and-swap.impure.lisp | 391 ++++++++++++++++++++++++++++------- 13 files changed, 692 insertions(+), 191 deletions(-) create mode 100644 src/code/cas.lisp create mode 100644 src/code/late-cas.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index bacec9f..e2ec49c 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -749,6 +749,8 @@ ("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 diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index b51ba34..5a6bfb2 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -107,6 +107,16 @@ useful for implementing lockless algorithms. @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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b495959..60b14e9 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -597,8 +597,14 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*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" @@ -1091,7 +1097,7 @@ possibly temporariliy, because it might be used internally." "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? diff --git a/src/code/cas.lisp b/src/code/cas.lisp new file mode 100644 index 0000000..9fcb006 --- /dev/null +++ b/src/code/cas.lisp @@ -0,0 +1,243 @@ +(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* ), 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)) + diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 70d6f35..4503861 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -201,3 +201,9 @@ 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)) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 6533da9..b8a15d4 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -93,7 +93,7 @@ (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))))) diff --git a/src/code/late-cas.lisp b/src/code/late-cas.lisp new file mode 100644 index 0000000..dd912dc --- /dev/null +++ b/src/code/late-cas.lisp @@ -0,0 +1,41 @@ +(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)))) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 45fe8b4..59a2fd6 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -73,99 +73,7 @@ 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 () diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 8375ea6..8f9789c 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -209,6 +209,11 @@ (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*)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 53d2671..cf6ceb5 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -35,32 +35,24 @@ WITH-CAS-LOCK can be entered recursively." (%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 diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 5bfa3bc..243ecc3 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -35,7 +35,8 @@ ;;;; 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) @@ -309,7 +310,8 @@ (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 diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 9054a5a..26a8355 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -68,9 +68,12 @@ ;;;; 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)) @@ -78,11 +81,19 @@ (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)) ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND @@ -165,6 +176,34 @@ `(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) diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp index accb74f..f51559f 100644 --- a/tests/compare-and-swap.impure.lisp +++ b/tests/compare-and-swap.impure.lisp @@ -3,17 +3,19 @@ (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) @@ -26,84 +28,92 @@ ;;; 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...) @@ -120,11 +130,12 @@ (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))))) @@ -137,13 +148,249 @@ (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))))) -- 1.7.10.4