Fix FORMAT compilation on non-simple strings.
[sbcl.git] / src / code / late-cas.lisp
blob74ec0b40313f67ad41771a5fe614d0fdd3b2233a
1 (in-package "SB!IMPL")
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
17 (progn
18 #!+sb-thread
19 ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
20 #!-sb-thread
21 (let ((current (,ref ,@lambda-list)))
22 ;; Shouldn't this be inside a WITHOUT-INTERRUPTS ?
23 (when (eq current old)
24 ,(if set
25 `(,set ,@lambda-list new)
26 `(setf (,ref ,@lambda-list) new)))
27 current)))))
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)
31 #!+(or x86-64 x86)
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)
45 #!+(or x86 x86-64)
46 `(,(let ((*package* (find-package "SB!VM")))
47 (symbolicate fun "-MODFX"))
48 ,a ,b)
49 #!-(or x86 x86-64)
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)
66 (return 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
83 computed value.
85 PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP.
87 Examples:
89 ;;; Conses T to the head of FOO-LIST.
90 (defstruct 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
96 (loop repeat 1000
97 collect (sb-thread:make-thread
98 (lambda ()
99 (loop repeat 1000
100 do (atomic-update (cdr x) #'1+)
101 (sleep 0.00001))))))
102 ;; Guaranteed to be (:COUNT . 1000000) -- if you replace
103 ;; atomic update with (INCF (CDR X)) above, the result becomes
104 ;; unpredictable.
107 (multiple-value-bind (vars vals old new cas-form read-form)
108 (get-cas-expansion place env)
109 `(let* (,@(mapcar 'list vars vals)
110 (,old ,read-form))
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)
124 (,old ,read-form)
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)
139 (,old ,read-form))
140 (loop (let ((,new (cdr ,old)))
141 (when (eq ,old (setf ,old ,cas-form))
142 (return (car (truly-the list ,old)))))))))