Tighter floating-point type constraints in some cases
[sbcl.git] / src / code / cas.lisp
1 (in-package "SB!IMPL")
2
3 ;;;; COMPARE-AND-SWAP
4 ;;;;
5 ;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now.
6 ;;;;
7 ;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER,
8 ;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with
9 ;;;; SETF.
10
11 (defglobal **cas-expanders** (make-hash-table :test #'eq
12                                               #-sb-xc-host #-sb-xc-host
13                                               :synchronized t))
14
15 (define-function-name-syntax cas (list)
16   (destructuring-bind (cas symbol) list
17     (aver (eq 'cas cas))
18     (values t symbol)))
19
20 ;;; This is what it all comes down to.
21 (def!macro cas (place old new &environment env)
22   "Synonym for COMPARE-AND-SWAP.
23
24 Addtionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to
25 define CAS-functions analogously to SETF-functions:
26
27   (defvar *foo* nil)
28
29   (defun (cas foo) (old new)
30     (cas (symbol-value '*foo*) old new))
31
32 First argument of a CAS function is the expected old value, and the second
33 argument of is the new value. Note that the system provides no automatic
34 atomicity for CAS functions, nor can it verify that they are atomic: it is up
35 to the implementor of a CAS function to ensure its atomicity.
36
37 EXPERIMENTAL: Interface subject to change."
38   (multiple-value-bind (temps place-args old-temp new-temp cas-form)
39       (get-cas-expansion place env)
40     `(let* (,@(mapcar #'list temps place-args)
41             (,old-temp ,old)
42             (,new-temp ,new))
43        ,cas-form)))
44
45 (defun get-cas-expansion (place &optional environment)
46   #!+sb-doc
47   "Analogous to GET-SETF-EXPANSION. Returns the following six values:
48
49  * list of temporary variables
50
51  * list of value-forms whose results those variable must be bound
52
53  * temporary variable for the old value of PLACE
54
55  * temporary variable for the new value of PLACE
56
57  * form using the aforementioned temporaries which performs the
58    compare-and-swap operation on PLACE
59
60  * form using the aforementioned temporaries with which to perform a volatile
61    read of PLACE
62
63 Example:
64
65   (get-cas-expansion '(car x))
66   ; => (#:CONS871), (X), #:OLD872, #:NEW873,
67   ;    (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873).
68   ;    (CAR #:CONS871)
69
70   (defmacro my-atomic-incf (place &optional (delta 1) &environment env)
71     (multiple-value-bind (vars vals old new cas-form read-form)
72         (get-cas-expansion place env)
73      (let ((delta-value (gensym \"DELTA\")))
74        `(let* (,@(mapcar 'list vars vals)
75                (,old ,read-form)
76                (,delta-value ,delta)
77                (,new (+ ,old ,delta-value)))
78           (loop until (eq ,old (setf ,old ,cas-form))
79                 do (setf ,new (+ ,old ,delta-value)))
80           ,new))))
81
82 EXPERIMENTAL: Interface subject to change."
83   (flet ((invalid-place ()
84            (error "Invalid place to CAS: ~S" place)))
85     (let ((expanded (sb!xc:macroexpand place environment)))
86       (unless (consp expanded)
87         ;; FIXME: Allow (CAS *FOO* <OLD> <NEW>), maybe?
88         (invalid-place))
89       (let ((name (car expanded)))
90         (unless (symbolp name)
91           (invalid-place))
92         (let ((info (gethash name **cas-expanders**)))
93           (cond
94             ;; CAS expander.
95             (info
96              (funcall info place environment))
97
98             ;; Structure accessor
99             ((setf info (info :function :structure-accessor name))
100              (expand-structure-slot-cas info name expanded))
101
102             ;; CAS function
103             (t
104              (with-unique-names (old new)
105                (let ((vars nil)
106                      (vals nil)
107                      (args nil))
108                  (dolist (x (reverse (cdr expanded)))
109                    (cond ((constantp x environment)
110                           (push x args))
111                          (t
112                           (let ((tmp (gensymify x)))
113                             (push tmp args)
114                             (push tmp vars)
115                             (push x vals)))))
116                  (values vars vals old new
117                          `(funcall #'(cas ,name) ,old ,new ,@args)
118                          `(,name ,@args)))))))))))
119
120 (defun expand-structure-slot-cas (dd name place)
121   (let* ((structure (dd-name dd))
122          (slotd (find name (dd-slots dd) :key #'dsd-accessor-name))
123          (index (dsd-index slotd))
124          (type (dsd-type slotd)))
125     (unless (eq t (dsd-raw-type slotd))
126       (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
127                 for a typed slot: ~S"
128              place))
129     (when (dsd-read-only slotd)
130       (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
131                 for a read-only slot: ~S"
132              place))
133     (destructuring-bind (op arg) place
134       (aver (eq op name))
135       (with-unique-names (instance old new)
136         (values (list instance)
137                 (list arg)
138                 old
139                 new
140                 `(truly-the (values ,type &optional)
141                             (%compare-and-swap-instance-ref
142                              (the ,structure ,instance)
143                              ,index
144                              (the ,type ,old)
145                              (the ,type ,new)))
146                 `(,op ,instance))))))
147
148 (def!macro define-cas-expander (accessor lambda-list &body body)
149   "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR.
150 BODY must return six values as specified in GET-CAS-EXPANSION.
151
152 Note that the system provides no automatic atomicity for CAS expansion, nor
153 can it verify that they are atomic: it is up to the implementor of a CAS
154 expansion to ensure its atomicity.
155
156 EXPERIMENTAL: Interface subject to change."
157   (with-unique-names (whole environment)
158     (multiple-value-bind (body decls doc)
159         (parse-defmacro lambda-list whole body accessor
160                         'define-cas-expander
161                         :environment environment
162                         :wrap-block nil)
163       `(eval-when (:compile-toplevel :load-toplevel :execute)
164          (setf (gethash ',accessor **cas-expanders**)
165                (lambda (,whole ,environment)
166                  ,@(when doc (list doc))
167                  ,@decls
168                  ,body))))))
169
170 (def!macro defcas (&whole form accessor lambda-list function
171                   &optional docstring)
172   "Analogous to short-form DEFSETF. Defines FUNCTION as responsible
173 for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST
174 must correspond to the lambda-list of the accessor.
175
176 Note that the system provides no automatic atomicity for CAS expansions
177 resulting from DEFCAS, nor can it verify that they are atomic: it is up to the
178 user of DEFCAS to ensure that the function specified is atomic.
179
180 EXPERIMENTAL: Interface subject to change."
181   (multiple-value-bind (reqs opts restp rest keyp keys allowp auxp)
182       (parse-lambda-list lambda-list)
183     (declare (ignore keys))
184     (when (or keyp allowp auxp)
185       (error "&KEY, &AUX, and &ALLOW-OTHER-KEYS not allowed in DEFCAS ~
186               lambda-list.~%  ~S" form))
187     `(define-cas-expander ,accessor ,lambda-list
188        ,@(when docstring (list docstring))
189        (let ((temps (mapcar #'gensymify
190                             ',(append reqs opts
191                                       (when restp (list (gensymify rest))))))
192              (args (list ,@(append reqs
193                                    opts
194                                    (when restp (list rest)))))
195              (old (gensym "OLD"))
196              (new (gensym "NEW")))
197          (values temps
198                  args
199                  old
200                  new
201                  `(,',function ,@temps ,old ,new)
202                  `(,',accessor ,@temps))))))
203
204 (def!macro compare-and-swap (place old new)
205   #!+sb-doc
206   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
207 Two values are considered to match if they are EQ. Returns the previous value
208 of PLACE: if the returned value is EQ to OLD, the swap was carried out.
209
210 PLACE must be an accessor form whose CAR is one of the following:
211
212  CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE
213  SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS,
214
215 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
216 either FIXNUM or T. Results are unspecified if the slot has a declared type
217 other then FIXNUM or T.
218
219 In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless
220 OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is
221 returned and NEW is assigned to the slot.
222
223 Additionally, the results are unspecified if there is an applicable method on
224 either SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or
225 SB-MOP:SLOT-BOUNDP-USING-CLASS.
226
227 EXPERIMENTAL: Interface subject to change."
228   `(cas ,place ,old ,new))
229
230 ;;; Out-of-line definitions for various primitive cas functions.
231 (macrolet ((def (name lambda-list ref &optional set)
232              #!+compare-and-swap-vops
233              (declare (ignore ref set))
234              `(defun ,name (,@lambda-list old new)
235                 #!+compare-and-swap-vops
236                 (,name ,@lambda-list old new)
237                 #!-compare-and-swap-vops
238                 (progn
239                   #!+sb-thread
240                   ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
241                   #!-sb-thread
242                   (let ((current (,ref ,@lambda-list)))
243                     (when (eq current old)
244                       ,(if set
245                            `(,set ,@lambda-list new)
246                            `(setf (,ref ,@lambda-list) new)))
247                     current)))))
248   (def %compare-and-swap-car (cons) car)
249   (def %compare-and-swap-cdr (cons) cdr)
250   (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
251   (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
252   (def %compare-and-swap-symbol-value (symbol) symbol-value)
253   (def %compare-and-swap-svref (vector index) svref))
254