,(/ 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))))))
+
+(defun split-version-string (string)
+ (loop
+ with start = 0
+ and end = (length string)
+ while (and start (< start end))
+ for subversion = (multiple-value-bind (subversion next)
+ (parse-integer string :start start
+ :junk-allowed t)
+ (setf start
+ (and subversion
+ next
+ (< next end)
+ (eql #\. (aref string next))
+ (1+ next)))
+ subversion)
+ when subversion
+ collect subversion))
+
+(defun version>= (x y)
+ (unless (or x y)
+ (return-from version>= t))
+ (let ((head-x (or (first x) 0))
+ (head-y (or (first y) 0)))
+ (or (> head-x head-y)
+ (and (= head-x head-y)
+ (version>= (rest x) (rest y))))))
+
+(defun assert-version->= (&rest subversions)
+ #!+sb-doc
+ "Asserts that the current SBCL is of version equal to or greater than
+the version specified in the arguments. A continuable error is signaled
+otherwise.
+
+The arguments specify a sequence of subversion numbers in big endian order.
+They are compared lexicographically with the runtime version, and versions
+are treated as though trailed by an unbounded number of 0s.
+
+For example, (assert-version->= 1 1 4) asserts that the current SBCL is
+version 1.1.4[.0.0...] or greater, and (assert-version->= 1) that it is
+version 1[.0.0...] or greater."
+ (let ((version (split-version-string (lisp-implementation-version))))
+ (unless (version>= version subversions)
+ (cerror "Disregard this version requirement."
+ "SBCL ~A is too old for this program (version ~{~A~^.~} ~
+ or later is required)."
+ (lisp-implementation-version)
+ subversions))))
projects / sbcl.git / blobdiff