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 ()
;;;; WAIT-FOR -- waiting on arbitrary conditions
-(defun %wait-for (test timeout)
+(defun %%wait-for (test stop-sec stop-usec)
(declare (function test))
(labels ((try ()
(declare (optimize (safety 0)))
(awhen (funcall test)
- (return-from %wait-for it)))
+ (return-from %%wait-for it)))
(tick (sec usec)
(declare (fixnum sec usec))
;; TICK is microseconds
(get-tick ()
(multiple-value-call #'tick
(decode-internal-time (get-internal-real-time)))))
- ;; Compute timeout: must come first so that deadlines already passed
- ;; are noticed before the first try.
- (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
- (decode-timeout timeout)
- (declare (ignore to-sec to-usec))
- (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
- (start (get-tick))
- ;; Rough estimate of how long a single attempt takes.
- (try-ticks (progn
- (try) (try) (try)
- (max 1 (truncate (- (get-tick) start) 3)))))
- ;; Scale sleeping between attempts:
- ;;
- ;; Start by sleeping for as many ticks as an average attempt
- ;; takes, then doubling for each attempt.
- ;;
- ;; Max out at 0.1 seconds, or the 2 x time of a single try,
- ;; whichever is longer -- with a hard cap of 10 seconds.
- ;;
- ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
- (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
- (expt 10 7)))
- for scale of-type fixnum = 1
- then (let ((x (logand most-positive-fixnum (* 2 scale))))
- (if (> scale x)
- most-positive-fixnum
- x))
- do (try)
- (let* ((now (get-tick))
- (sleep-ticks (min (* try-ticks scale) max-ticks))
- (sleep
- (if timeout-tick
- ;; If sleep would take us past the
- ;; timeout, shorten it so it's just
- ;; right.
- (if (>= (+ now sleep-ticks) timeout-tick)
- (- timeout-tick now)
- sleep-ticks)
- sleep-ticks)))
- (declare (fixnum sleep))
- (cond ((plusp sleep)
- ;; microseconds to seconds and nanoseconds
- (multiple-value-bind (sec nsec)
- (truncate (* 1000 sleep) (expt 10 9))
- (with-interrupts
- (sb!unix:nanosleep sec nsec))))
- (deadlinep
- (signal-deadline))
- (t
- (return-from %wait-for nil)))))))))
+ (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
+ (start (get-tick))
+ ;; Rough estimate of how long a single attempt takes.
+ (try-ticks (progn
+ (try) (try) (try)
+ (max 1 (truncate (- (get-tick) start) 3)))))
+ ;; Scale sleeping between attempts:
+ ;;
+ ;; Start by sleeping for as many ticks as an average attempt
+ ;; takes, then doubling for each attempt.
+ ;;
+ ;; Max out at 0.1 seconds, or the 2 x time of a single try,
+ ;; whichever is longer -- with a hard cap of 10 seconds.
+ ;;
+ ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
+ (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
+ (expt 10 7)))
+ for scale of-type fixnum = 1
+ then (let ((x (logand most-positive-fixnum (* 2 scale))))
+ (if (> scale x)
+ most-positive-fixnum
+ x))
+ do (try)
+ (let* ((now (get-tick))
+ (sleep-ticks (min (* try-ticks scale) max-ticks))
+ (sleep
+ (if timeout-tick
+ ;; If sleep would take us past the
+ ;; timeout, shorten it so it's just
+ ;; right.
+ (if (>= (+ now sleep-ticks) timeout-tick)
+ (- timeout-tick now)
+ sleep-ticks)
+ sleep-ticks)))
+ (declare (fixnum sleep))
+ (cond ((plusp sleep)
+ ;; microseconds to seconds and nanoseconds
+ (multiple-value-bind (sec nsec)
+ (truncate (* 1000 sleep) (expt 10 9))
+ (with-interrupts
+ (sb!unix:nanosleep sec nsec))))
+ (t
+ (return-from %%wait-for nil))))))))
+
+(defun %wait-for (test timeout)
+ (declare (function test))
+ (tagbody
+ :restart
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout)
+ (declare (ignore to-sec to-usec))
+ (return-from %wait-for
+ (or (%%wait-for test stop-sec stop-usec)
+ (when deadlinep
+ (signal-deadline)
+ (go :restart)))))))
(defmacro wait-for (test-form &key timeout)
+ #!+sb-doc
"Wait until TEST-FORM evaluates to true, then return its primary value.
If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before
returning NIL.
Experimental: subject to change without prior notice."
`(dx-flet ((wait-for-test () (progn ,test-form)))
(%wait-for #'wait-for-test ,timeout)))
+
+(defmacro with-progressive-timeout ((name &key seconds)
+ &body body)
+ #!+sb-doc
+ "Binds NAME as a local function for BODY. Each time #'NAME is called, it
+returns SECONDS minus the time that has elapsed since BODY was entered, or
+zero if more time than SECONDS has elapsed. If SECONDS is NIL, #'NAME
+returns NIL each time."
+ (with-unique-names (deadline time-left sec)
+ `(let* ((,sec ,seconds)
+ (,deadline
+ (when ,sec
+ (+ (get-internal-real-time)
+ (round (* ,seconds internal-time-units-per-second))))))
+ (flet ((,name ()
+ (when ,deadline
+ (let ((,time-left (- ,deadline (get-internal-real-time))))
+ (if (plusp ,time-left)
+ (* (coerce ,time-left 'single-float)
+ ,(/ 1.0 internal-time-units-per-second))
+ 0)))))
+ ,@body))))
+
+(defmacro atomic-update (place update-fn &rest arguments &environment env)
+ #!+sb-doc
+ "Updates PLACE atomically to the value returned by calling function
+designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE.
+
+PLACE may be read and UPDATE-FN evaluated and called multiple times before the
+update succeeds: atomicity in this context means that value of place did not
+change between the time it was read, and the time it was replaced with the
+computed value.
+
+PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP.
+
+Examples:
+
+ ;;; Conses T to the head of FOO-LIST.
+ (defstruct foo list)
+ (defvar *foo* (make-foo))
+ (atomic-update (foo-list *foo*) #'cons t)
+
+ (let ((x (cons :count 0)))
+ (mapc #'sb-thread:join-thread
+ (loop repeat 1000
+ collect (sb-thread:make-thread
+ (lambda ()
+ (loop repeat 1000
+ do (atomic-update (cdr x) #'1+)
+ (sleep 0.00001))))))
+ ;; Guaranteed to be (:COUNT . 1000000) -- if you replace
+ ;; atomic update with (INCF (CDR X)) above, the result becomes
+ ;; unpredictable.
+ x)
+"
+ (multiple-value-bind (vars vals old new cas-form read-form)
+ (get-cas-expansion place env)
+ `(let* (,@(mapcar 'list vars vals)
+ (,old ,read-form))
+ (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))))))