3 (defcas car
(cons) %compare-and-swap-car
)
4 (defcas cdr
(cons) %compare-and-swap-cdr
)
5 (defcas first
(cons) %compare-and-swap-car
)
6 (defcas rest
(cons) %compare-and-swap-cdr
)
7 (defcas symbol-plist
(symbol) %compare-and-swap-symbol-plist
)
9 ;;; Out-of-line definitions for various primitive cas functions.
10 (macrolet ((def (name lambda-list ref
&optional set
)
11 #!+compare-and-swap-vops
12 (declare (ignore ref set
))
13 `(defun ,name
(,@lambda-list old new
)
14 #!+compare-and-swap-vops
15 (,name
,@lambda-list old new
)
16 #!-compare-and-swap-vops
19 ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
21 (let ((current (,ref
,@lambda-list
)))
22 ;; Shouldn't this be inside a WITHOUT-INTERRUPTS ?
23 (when (eq current old
)
25 `(,set
,@lambda-list new
)
26 `(setf (,ref
,@lambda-list
) new
)))
28 (def %compare-and-swap-car
(cons) car
)
29 (def %compare-and-swap-cdr
(cons) cdr
)
30 (def %instance-cas
(instance index
) %instance-ref %instance-set
)
32 (def %raw-instance-cas
/word
(instance index
)
33 %raw-instance-ref
/word
34 %raw-instance-set
/word
)
35 (def %compare-and-swap-symbol-info
(symbol) symbol-info
)
36 (def %compare-and-swap-symbol-value
(symbol) symbol-value
)
37 (def %compare-and-swap-svref
(vector index
) svref
))
39 ;; Atomic increment/decrement ops on tagged storage cells (as contrasted with
40 ;; specialized arrays and raw structure slots) are defined in terms of CAS.
42 ;; This code would be more concise if workable versions
43 ;; of +-MODFX, --MODFX were defined generically.
44 (macrolet ((modular (fun a b
)
46 `(,(let ((*package
* (find-package "SB!VM")))
47 (symbolicate fun
"-MODFX"))
50 ;; algorithm of https://graphics.stanford.edu/~seander/bithacks
51 `(let ((res (logand (,fun
,a
,b
)
52 (ash sb
!ext
:most-positive-word
53 (- sb
!vm
:n-fixnum-tag-bits
))))
54 (m (ash 1 (1- sb
!vm
:n-fixnum-bits
))))
55 (- (logxor res m
) m
))))
57 ;; Atomically frob the CAR or CDR of a cons, or a symbol-value.
58 ;; The latter will be a global value because the ATOMIC-INCF/DECF
59 ;; macros work on a symbol only if it is known global.
60 (macrolet ((def-frob (name op type slot
)
61 `(defun ,name
(place delta
)
62 (declare (type ,type place
) (type fixnum delta
))
63 (loop (let ((old (the fixnum
(,slot place
))))
64 (when (eq (cas (,slot place
) old
65 (modular ,op old delta
)) old
)
67 (def-frob %atomic-inc-symbol-global-value
+ symbol symbol-value
)
68 (def-frob %atomic-dec-symbol-global-value - symbol symbol-value
)
69 (def-frob %atomic-inc-car
+ cons car
)
70 (def-frob %atomic-dec-car - cons car
)
71 (def-frob %atomic-inc-cdr
+ cons cdr
)
72 (def-frob %atomic-dec-cdr - cons cdr
)))
74 ;;; ATOMIC-MUMBLE functions are not used when self-building.
76 (defmacro atomic-update
(place update-fn
&rest arguments
&environment env
)
77 "Updates PLACE atomically to the value returned by calling function
78 designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE.
80 PLACE may be read and UPDATE-FN evaluated and called multiple times before the
81 update succeeds: atomicity in this context means that the value of PLACE did
82 not change between the time it was read, and the time it was replaced with the
85 PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP.
89 ;;; Conses T to the head of FOO-LIST.
91 (defvar *foo* (make-foo))
92 (atomic-update (foo-list *foo*) #'cons t)
94 (let ((x (cons :count 0)))
95 (mapc #'sb-thread:join-thread
97 collect (sb-thread:make-thread
100 do (atomic-update (cdr x) #'1+)
102 ;; Guaranteed to be (:COUNT . 1000000) -- if you replace
103 ;; atomic update with (INCF (CDR X)) above, the result becomes
107 (multiple-value-bind (vars vals old new cas-form read-form
)
108 (get-cas-expansion place env
)
109 `(let* (,@(mapcar 'list vars vals
)
111 (loop for
,new
= (funcall ,update-fn
,@arguments
,old
)
112 until
(eq ,old
(setf ,old
,cas-form
))
113 finally
(return ,new
)))))
115 (defmacro atomic-push
(obj place
&environment env
)
116 "Like PUSH, but atomic. PLACE may be read multiple times before
117 the operation completes -- the write does not occur until such time
118 that no other thread modified PLACE between the read and the write.
120 Works on all CASable places."
121 (multiple-value-bind (vars vals old new cas-form read-form
)
122 (get-cas-expansion place env
)
123 `(let* (,@(mapcar 'list vars vals
)
125 (,new
(cons ,obj
,old
)))
126 (loop until
(eq ,old
(setf ,old
,cas-form
))
127 do
(setf (cdr ,new
) ,old
)
128 finally
(return ,new
)))))
130 (defmacro atomic-pop
(place &environment env
)
131 "Like POP, but atomic. PLACE may be read multiple times before
132 the operation completes -- the write does not occur until such time
133 that no other thread modified PLACE between the read and the write.
135 Works on all CASable places."
136 (multiple-value-bind (vars vals old new cas-form read-form
)
137 (get-cas-expansion place env
)
138 `(let* (,@(mapcar 'list vars vals
)
140 (loop (let ((,new
(cdr ,old
)))
141 (when (eq ,old
(setf ,old
,cas-form
))
142 (return (car (truly-the list
,old
)))))))))