From: Nikodemus Siivola Date: Mon, 10 Sep 2012 22:08:48 +0000 (+0300) Subject: implement ATOMIC-PUSH and ATOMIC-POP X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=af3fdb98f2b8718dbb69eba5db56dee369b142c7;p=sbcl.git implement ATOMIC-PUSH and ATOMIC-POP --- diff --git a/NEWS b/NEWS index 6fc3407..2d4b7c9 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes relative to sbcl-1.0.58: * enhancement: New variable, sb-ext:*disassemble-annotate* for controlling source annotation of DISASSEMBLE output. Defaults to T. + * enhancement: SB-EXT:ATOMIC-PUSH and SB-EXT:ATOMIC-POP allow atomic operations + on list heads. * optimization: CL:SORT and CL:STABLE-SORT of lists are faster and use fewer comparisons, particularly on almost-sorted inputs. * bug fix: Reading floats with large exponents no longer takes too much time diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 1ea5e9a..7365510 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -109,6 +109,8 @@ lockless algorithms. @include macro-sb-ext-atomic-decf.texinfo @include macro-sb-ext-atomic-incf.texinfo +@include macro-sb-ext-atomic-pop.texinfo +@include macro-sb-ext-atomic-push.texinfo @include macro-sb-ext-atomic-update.texinfo @include macro-sb-ext-compare-and-swap.texinfo @@ -119,8 +121,9 @@ similar to @code{setf}, allowing users to add CAS support to new places via eg. @code{defcas}. At the same time, new atomic operations can be built on top of CAS -using @code{get-cas-expansion}. See @code{atomic-update} for an -example. +using @code{get-cas-expansion}. See @code{atomic-update}, +@code{atomic-push}, and €@code{atomic-pop} for example of how to do +this. @include macro-sb-ext-cas.texinfo @include macro-sb-ext-define-cas-expander.texinfo @@ -287,7 +290,8 @@ following functions and macros also serve as @code{:memory} barriers: @itemize @item -@code{sb-ext:atomic-decf} and @code{sb-ext:atomic-incf}. +@code{sb-ext:atomic-decf}, @code{sb-ext:atomic-incf}, @code{sb-ext:atomic-push}, +and @code{sb-ext:atomic-pop}. @item @code{sb-ext:compare-and-swap}. @item diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 42e5b84..bad7f20 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -613,6 +613,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "ATOMIC-INCF" "ATOMIC-DECF" "ATOMIC-UPDATE" + "ATOMIC-PUSH" + "ATOMIC-POP" "WORD" "MOST-POSITIVE-WORD" diff --git a/src/code/cas.lisp b/src/code/cas.lisp index 84f4c43..72e5800 100644 --- a/src/code/cas.lisp +++ b/src/code/cas.lisp @@ -80,9 +80,9 @@ Example: ,new)))) EXPERIMENTAL: Interface subject to change." - (flet ((invalid-place () - (error "Invalid place to CAS: ~S" place))) (let ((expanded (sb!xc:macroexpand place environment))) + (flet ((invalid-place () + (error "Invalid place to CAS: ~S -> ~S" place expanded))) (unless (consp expanded) ;; FIXME: Allow (CAS *FOO* ), maybe? (invalid-place)) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 7228897..48ee190 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -405,3 +405,34 @@ Examples: (loop for ,new = (funcall ,update-fn ,@arguments ,old) until (eq ,old (setf ,old ,cas-form)) finally (return ,new))))) + +(defmacro atomic-push (obj place &environment env) + #!+sb-doc + "Like PUSH, but atomic. PLACE may be read multiple times before +the operation completes -- the write does not occur until such time +that no other thread modified PLACE between the read and the write. + +Works on all CASable places." + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + `(let* (,@(mapcar 'list vars vals) + (,old ,read-form) + (,new (cons ,obj ,old))) + (loop until (eq ,old (setf ,old ,cas-form)) + do (setf (cdr ,new) ,old) + finally (return ,new))))) + +(defmacro atomic-pop (place &environment env) + #!+sb-doc + "Like POP, but atomic. PLACE may be read multiple times before +the operation completes -- the write does not occur until such time +that no other thread modified PLACE between the read and the write. + +Works on all CASable places." + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + `(let* (,@(mapcar 'list vars vals)) + (loop for ,old = ,read-form + for ,new = (cdr ,old) + until (eq ,old (setf ,old ,cas-form)) + finally (return (car ,old)))))) diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp index 6ec6547..1bbecf9 100644 --- a/tests/compare-and-swap.impure.lisp +++ b/tests/compare-and-swap.impure.lisp @@ -412,6 +412,7 @@ (assert (eq :bar (eval `(let (,@(mapcar 'list vars vals)) ,read-form))))))) + (let ((foo (cons :foo nil))) (defun cas-foo (old new) (cas (cdr foo) old new))) @@ -425,3 +426,22 @@ (assert (not (cas bar nil :ok))) (assert (eq :ok (cas bar :ok nil))) (assert (not (cas bar nil t))))) + +(with-test (:name atomic-push + :skipped-on '(not :sb-thread)) + (let ((store (cons nil nil)) + (n 100000)) + (symbol-macrolet ((x (car store)) + (y (cdr store))) + (dotimes (i n) + (push i y)) + (mapc #'sb-thread:join-thread + (loop repeat 1000 + collect (sb-thread:make-thread + (lambda () + (loop for z = (atomic-pop y) + while z + do (atomic-push z x) + (sleep 0.00001)))))) + (assert (not y)) + (assert (eql n (length x))))))