5 (macrolet ((test (init op
)
6 `(with-test (:name
(:cas
:basics
,(intern (symbol-name op
) "KEYWORD")))
10 (assert (eql nil
(compare-and-swap (,op x
) nil y
)))
11 (assert (eql y
(compare-and-swap (,op x
) nil z
)))
12 (assert (eql y
(,op x
)))
14 (multiple-value-bind (res err
)
15 (ignore-errors (compare-and-swap (,op x
) nil nil
))
17 (error "Wanted NIL and type-error, got: ~S" res
))
18 (assert (typep err
'type-error
))))))))
19 (test (cons nil
:no
) car
)
20 (test (cons nil
:no
) first
)
21 (test (cons :no nil
) cdr
)
22 (test (cons :no nil
) rest
)
23 (test '.foo. symbol-plist
)
24 (test (progn (set '.bar. nil
) '.bar.
) symbol-value
)
25 (test (make-xxx) xxx-yyy
))
29 ;;; thread-local bindings
31 (with-test (:name
(:cas
:tls
))
34 (assert (eql nil
(compare-and-swap (symbol-value '*foo
*) nil t
)))
35 (assert (eql t
(compare-and-swap (symbol-value '*foo
*) nil
:foo
)))
36 (assert (eql t
*foo
*)))
37 (assert (eql 42 *foo
*))))
39 ;;; unbound symbols + symbol-value
41 (assert (not (boundp '*foo
*)))
43 (with-test (:name
(:cas
:unbound
))
44 (multiple-value-bind (res err
)
45 (ignore-errors (compare-and-swap (symbol-value '*foo
*) nil t
))
47 (assert (typep err
'unbound-variable
))))
51 (with-test (:name
(:cas
:unbound
2))
54 (multiple-value-bind (res err
)
55 (ignore-errors (compare-and-swap (symbol-value '*bar
*) nil t
))
57 (assert (typep err
'unbound-variable
)))))
61 (defvar *v
* (vector 1))
64 (with-test (:name
(:cas
:svref
))
65 (assert (eql 1 (compare-and-swap (svref *v
* 0) 1 2)))
66 (assert (eql 2 (compare-and-swap (svref *v
* 0) 1 3)))
67 (assert (eql 2 (svref *v
* 0))))
70 (with-test (:name
(:cas
:svref
:bounds
))
71 (multiple-value-bind (res err
)
72 (ignore-errors (compare-and-swap (svref *v
* -
1) 1 2))
74 (assert (typep err
'type-error
)))
75 (multiple-value-bind (res err
)
76 (ignore-errors (compare-and-swap (svref *v
* 1) 1 2))
78 (assert (typep err
'type-error
))))
80 ;; type of the first argument
81 (with-test (:name
(:cas
:svref
:type
))
82 (multiple-value-bind (res err
)
83 (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
85 (assert (typep err
'type-error
))))
87 ;; Check that we don't modify constants
88 (defconstant +a-constant
+ 42)
89 (with-test (:name
(:cas
:symbol-value
:constant-modification
))
93 (sb-ext:compare-and-swap
(symbol-value '+a-constant
+) 42 13)
95 (let ((name '+a-constant
+))
99 (sb-ext:compare-and-swap
(symbol-value name
) 42 13)
100 (error () :error
))))))
102 ;; Check that we don't mess declaimed types
103 (declaim (boolean *a-boolean
*))
104 (defparameter *a-boolean
* t
)
105 (with-test (:name
(:cas
:symbol-value
:type-checking
))
109 (sb-ext:compare-and-swap
(symbol-value '*a-boolean
*) t
42)
111 (let ((name '*a-boolean
*))
115 (sb-ext:compare-and-swap
(symbol-value name
) t
42)
116 (error () :error
))))))
118 ;;;; ATOMIC-INCF and ATOMIC-DECF (we should probably rename this file atomic-ops...)
121 (word 0 :type sb-vm
:word
))
123 ;; Have the following tests check that CAS access to the superclass
124 ;; works in the presence of a subclass sharing the conc-name.
125 (defstruct (subbox (:include box
) (:conc-name
"BOX-")))
127 (defun inc-box (box n
)
128 (declare (fixnum n
) (box box
))
130 do
(sb-ext:atomic-incf
(box-word box
))))
132 (defun dec-box (box n
)
133 (declare (fixnum n
) (box box
))
135 do
(sb-ext:atomic-decf
(box-word box
))))
137 (with-test (:name
:atomic-incf
/decf
)
138 (let ((box (make-box)))
140 (assert (= 10000 (box-word box
)))
142 (assert (= 0 (box-word box
)))))
144 (with-test (:name
:atomic-incf-wraparound
)
145 (let ((box (make-box :word
(1- (ash 1 sb-vm
:n-word-bits
)))))
146 (sb-ext:atomic-incf
(box-word box
) 2)
147 (assert (= 1 (box-word box
)))))
149 (with-test (:name
:atomic-decf-wraparound
)
150 (let ((box (make-box :word
0)))
151 (sb-ext:atomic-decf
(box-word box
) 2)
152 (assert (= (- (ash 1 sb-vm
:n-word-bits
) 2) (box-word box
)))))
154 (with-test (:name
:atomic-incf-full-call-lp1381867
155 :skipped-on
'(not (or :x86
:x86-64
:ppc
)))
156 ;; contortions to avoid reader errors
157 (let* ((%riai
/w
(intern "%RAW-INSTANCE-ATOMIC-INCF/WORD" "SB-KERNEL"))
160 ;; Rebind %RAW-INSTANCE-ATOMIC-INCF/WORD as a local
161 ;; function. Declaring it locally notinline fails because
162 ;; it is marked with the ALWAYS-TRANSLATABLE attribute, so
163 ;; it's a bug to call it even though we've asked to call
164 ;; it. (Maybe that's a bug?) And I don't want to call it
165 ;; explictly - I want the macro to do it so that I don't
166 ;; have to inject any of the sign masking noise and such.
167 (declare (disable-package-locks ,%riai
/w
))
168 (let ((b (make-box :word
0))
169 (delta (- (ash 1 (1- sb-vm
:n-word-bits
))))
170 (f (fdefinition ',%riai
/w
)))
171 (flet ((,%riai
/w
(a b c
) (funcall f a b c
)))
172 (assert (= (atomic-incf (box-word b
) delta
) 0))
173 (assert (= (atomic-incf (box-word b
) delta
)
174 (ash 1 (1- sb-vm
:n-word-bits
))))
175 (assert (= (box-word b
) 0))
176 (atomic-decf (box-word b
))
177 (assert (= (box-word b
) sb-ext
:most-positive-word
)))))))
181 (with-test (:name
(:atomic-incf
/decf
:threads
))
182 (let* ((box (make-box))
183 (threads (loop repeat
64
184 collect
(sb-thread:make-thread
(lambda ()
189 :name
"inc/dec thread"))))
190 (mapc #'sb-thread
:join-thread threads
)
191 (assert (= 0 (box-word box
)))))
193 (defglobal **my-atomic-counter
* 0)
194 (declaim (fixnum **my-atomic-counter
*))
195 ;; Assert that safe (atomic-incf car) type-checks the car.
196 (with-test (:name
:atomic-incf-car-safe
)
197 (let ((x (cons (1+ most-positive-fixnum
) 0))) ; a bignum
198 (assert (eq (handler-case (atomic-incf (car x
))
199 (type-error () 'win
)) 'win
))))
201 ;; Basic correctness tests, not testing atomicity
205 ;; using a constant for the delta
206 (assert (eq (atomic-incf ,place
2) 0))
207 (assert (eq ,place
2))
208 (assert (eq (atomic-incf ,place -
1) 2))
209 (assert (eq ,place
1))
210 (assert (eq (atomic-decf ,place
1) 1))
211 (assert (eq ,place
0))
212 ;; using a non-constant for the delta
213 (assert (eq (atomic-incf ,place
(eval 2)) 0))
214 (assert (eq ,place
2))
215 (assert (eq (atomic-incf ,place
(eval -
1)) 2))
216 (assert (eq ,place
1))
217 (assert (eq (atomic-decf ,place
(eval 1)) 1))
218 (assert (eq ,place
0))
219 (setf ,place most-positive-fixnum
)
221 (assert (eq ,place most-negative-fixnum
))
223 (assert (eq ,place most-positive-fixnum
)))))
224 (with-test (:name
(:atomic-incf
:global-var
))
225 (test-place **my-atomic-counter
*))
226 (with-test (:name
(:atomic-incf
:car
))
227 (let ((x (cons 0 'foo
)))
228 (test-place (car x
))))
229 (with-test (:name
(:atomic-incf
:cdr
))
230 (let ((x (cons 'foo
0)))
231 (test-place (cdr x
))))
232 ;; Fast code for (atomic-{incf|decf} {car|cdr}) is decidedly unsafe
233 ;; on x86-64. Ensure basic correctness when used correctly.
234 (with-test (:name
(:atomic-incf-fast
:car
))
235 (let ((x (cons 0 'foo
)))
236 (declare (optimize (safety 0)))
237 (test-place (car x
))))
238 (with-test (:name
(:atomic-incf-fast
:cdr
))
239 (let ((x (cons 'foo
0)))
240 (declare (optimize (safety 0)))
241 (test-place (cdr x
)))))
243 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
245 (defclass sia-cas-test
()
249 (with-test (:name
(:cas
:standard-instance-access
))
250 (flet ((slot-loc (slot class
)
251 (sb-mop:slot-definition-location
252 (find slot
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
))))
253 (let* ((class (find-class 'sia-cas-test
))
254 (instance (make-instance class
:a
'a
:b
'b
))
255 (a-loc (slot-loc 'a class
))
256 (b-loc (slot-loc 'b class
)))
257 (assert (eq 'a
(slot-value instance
'a
)))
258 (assert (eq 'a
(compare-and-swap (sb-mop:standard-instance-access instance a-loc
)
260 (assert (eq 'a
(sb-mop:standard-instance-access instance a-loc
)))
261 (assert (eq 'a
(compare-and-swap (sb-mop:standard-instance-access instance a-loc
)
263 (assert (eq 'a2
(sb-mop:standard-instance-access instance a-loc
)))
264 (assert (eq 'a2
(slot-value instance
'a
)))
265 (assert (eq 'b
(slot-value instance
'b
)))
266 (assert (eq 'b
(sb-mop:standard-instance-access instance b-loc
))))))
268 (defclass fia-cas-test
(sb-mop:funcallable-standard-object
)
271 (:metaclass sb-mop
:funcallable-standard-class
))
273 (with-test (:name
(:cas
:standard-instance-access
))
274 (flet ((slot-loc (slot class
)
275 (sb-mop:slot-definition-location
276 (find slot
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
))))
277 (let* ((class (find-class 'fia-cas-test
))
278 (instance (make-instance class
:a
'a
:b
'b
))
279 (a-loc (slot-loc 'a class
))
280 (b-loc (slot-loc 'b class
)))
281 (sb-mop:set-funcallable-instance-function instance
(lambda () :ok
))
282 (eq :ok
(funcall instance
))
283 (assert (eq 'a
(slot-value instance
'a
)))
284 (assert (eq 'a
(compare-and-swap
285 (sb-mop:funcallable-standard-instance-access instance a-loc
)
287 (assert (eq 'a
(sb-mop:funcallable-standard-instance-access instance a-loc
)))
288 (assert (eq 'a
(compare-and-swap
289 (sb-mop:funcallable-standard-instance-access instance a-loc
)
291 (assert (eq 'a2
(sb-mop:funcallable-standard-instance-access instance a-loc
)))
292 (assert (eq 'a2
(slot-value instance
'a
)))
293 (assert (eq 'b
(slot-value instance
'b
)))
294 (assert (eq 'b
(sb-mop:funcallable-standard-instance-access instance b-loc
))))))
298 (defclass standard-thing
()
302 (defmethod slot-unbound ((class standard-class
) (obj standard-thing
) slot
)
303 (list :unbound slot
))
305 (defmethod slot-missing ((class standard-class
) (obj standard-thing
) slot op
&optional val
)
306 (list :missing slot op val
))
308 (with-test (:name
(:cas
:slot-value
:standard-object
))
309 (let ((x (make-instance 'standard-thing
)))
310 (assert (eql 42 (slot-value x
'x
)))
311 (assert (eql 42 (compare-and-swap (slot-value x
'x
) 0 :foo
)))
312 (assert (eql 42 (slot-value x
'x
)))
313 (assert (eql 42 (compare-and-swap (slot-value x
'x
) 42 :foo
)))
314 (assert (eql :foo
(slot-value x
'x
)))))
316 (with-test (:name
(:cas
:slot-value
:slot-unbound
))
317 (let ((x (make-instance 'standard-thing
)))
318 (assert (equal '(:unbound y
) (slot-value x
'y
)))
319 (assert (equal '(:unbound y
) (compare-and-swap (slot-value x
'y
) 0 :foo
)))
320 (assert (equal '(:unbound y
) (slot-value x
'y
)))
321 (assert (eq sb-pcl
:+slot-unbound
+
322 (compare-and-swap (slot-value x
'y
) sb-pcl
:+slot-unbound
+ :foo
)))
323 (assert (eq :foo
(slot-value x
'y
)))))
325 (with-test (:name
(:cas
:slot-value
:slot-missing
))
326 (let ((x (make-instance 'standard-thing
)))
327 (assert (equal '(:missing z slot-value nil
) (slot-value x
'z
)))
328 (assert (equal '(:missing z sb-ext
:cas
(0 :foo
)) (compare-and-swap (slot-value x
'z
) 0 :foo
)))
329 (assert (equal '(:missing z slot-value nil
) (slot-value x
'z
)))))
331 (defclass non-standard-class
(standard-class)
334 (defmethod sb-mop:validate-superclass
((class non-standard-class
) (superclass standard-class
))
337 (defclass non-standard-thing-0
()
339 (:metaclass non-standard-class
))
341 (defclass non-standard-thing-1
()
343 (:metaclass non-standard-class
))
345 (defclass non-standard-thing-2
()
347 (:metaclass non-standard-class
))
349 (defclass non-standard-thing-3
()
351 (:metaclass non-standard-class
))
353 (defvar *access-list
* nil
)
355 (defmethod sb-mop:slot-value-using-class
356 ((class non-standard-class
) (obj non-standard-thing-1
) slotd
)
357 (let ((v (call-next-method)))
358 (push :read
*access-list
*)
361 (defmethod (setf sb-mop
:slot-value-using-class
)
362 (value (class non-standard-class
) (obj non-standard-thing-2
) slotd
)
363 (let ((v (call-next-method)))
364 (push :write
*access-list
*)
367 (defmethod sb-mop:slot-boundp-using-class
368 ((class non-standard-class
) (obj non-standard-thing-3
) slotd
)
369 (let ((v (call-next-method)))
370 (push :boundp
*access-list
*)
373 (with-test (:name
(:cas
:slot-value
:non-standard-object
:standard-access
))
374 (let ((x (make-instance 'non-standard-thing-0
)))
375 (assert (eql 13 (slot-value x
'x
)))
376 (assert (eql 13 (compare-and-swap (slot-value x
'x
) 0 :bar
)))
377 (assert (eql 13 (slot-value x
'x
)))
378 (assert (eql 13 (compare-and-swap (slot-value x
'x
) 13 :bar
)))
379 (assert (eql :bar
(slot-value x
'x
)))))
381 (with-test (:name
(:cas
:slot-value
:non-standard-object
:slot-value-using-class
))
382 (setf *access-list
* nil
)
383 (let ((x (make-instance 'non-standard-thing-1
)))
384 (declare (notinline slot-value
))
385 (assert (null *access-list
*))
386 (assert (eql 13 (slot-value x
'x
)))
387 (assert (equal '(:read
) *access-list
*))
390 (compare-and-swap (slot-value x
'x
) 0 :bar
)
392 (assert (eql 13 (slot-value x
'x
)))
393 (assert (equal '(:read
:read
) *access-list
*))))
395 (with-test (:name
(:cas
:slot-value
:non-standard-object
:setf-slot-value-using-class
))
396 (setf *access-list
* nil
)
397 (let ((x (make-instance 'non-standard-thing-2
)))
398 (assert (equal '(:write
) *access-list
*))
399 (assert (eql 13 (slot-value x
'x
)))
400 (assert (equal '(:write
) *access-list
*))
403 (compare-and-swap (slot-value x
'x
) 0 :bar
)
405 (assert (eql 13 (slot-value x
'x
)))
406 (assert (equal '(:write
) *access-list
*))))
408 (with-test (:name
(:cas
:slot-value
:non-standard-object
:slot-boundp-using-class
))
409 (setf *access-list
* nil
)
410 (let ((x (make-instance 'non-standard-thing-3
)))
411 (assert (equal '(:boundp
) *access-list
*))
412 (assert (eql 13 (slot-value x
'x
)))
415 (compare-and-swap (slot-value x
'x
) 0 :bar
)
417 (assert (eql 13 (slot-value x
'x
)))))
424 (defun (cas foo
) (old new
)
425 (cas (symbol-value '*foo
*) old new
))
427 (with-test (:name
(:cas
:defun
))
428 (assert (null (foo)))
429 (assert (null (cas (foo) nil t
)))
430 (assert (eq t
(foo)))
431 (assert (eq t
(cas (foo) nil
:oops
)))
432 (assert (eq t
(foo))))
434 (with-test (:name
(:cas
:flet
))
436 (flet (((cas x
) (old new
)
444 (assert (null (cas (x) nil t
)))
446 (assert (eq t
(cas (x) nil
:oops
)))
447 (assert (eq t
(x))))))
449 (defgeneric (cas thing
) (old new thing
))
451 (defmethod (cas thing
) (old new
(thing cons
))
452 (cas (car thing
) old new
))
454 (defmethod (cas thing
) (old new
(thing symbol
))
455 (cas (symbol-value thing
) old new
))
457 (defgeneric thing
(thing)
460 (:method
((x symbol
))
463 (with-test (:name
(:cas
:defgeneric
))
467 (assert (null (thing a
)))
468 (assert (null (thing b
)))
469 (assert (null (cas (thing a
) nil t
)))
470 (assert (null (cas (thing b
) nil t
)))
471 (assert (eq t
(thing a
)))
472 (assert (eq t
(thing b
)))
473 (assert (eq t
(cas (thing a
) nil
:oops
)))
474 (assert (eq t
(cas (thing b
) nil
:oops
)))
475 (assert (eq t
(thing a
)))
476 (assert (eq t
(thing b
)))))
478 ;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
479 (with-test (:name
:symbol-value-cas-expansion
)
480 (multiple-value-bind (vars vals old new cas-form read-form
)
481 (get-cas-expansion `(symbol-value t
))
482 (declare (ignore old new cas-form
))
485 (assert (eq t
(eval read-form
))))
486 (multiple-value-bind (vars vals old new cas-form read-form
)
487 (get-cas-expansion `(symbol-value *))
488 (declare (ignore old new cas-form
))
491 (eval `(let (,@(mapcar 'list vars vals
))
495 (eval `(let (,@(mapcar 'list vars vals
))
498 (let ((foo (cons :foo nil
)))
499 (defun cas-foo (old new
)
500 (cas (cdr foo
) old new
)))
502 (defcas foo
() cas-foo
)
504 (with-test (:name
:cas-and-macroexpansion
)
505 (assert (not (cas (foo) nil t
)))
506 (assert (eq t
(cas (foo) t nil
)))
507 (symbol-macrolet ((bar (foo)))
508 (assert (not (cas bar nil
:ok
)))
509 (assert (eq :ok
(cas bar
:ok nil
)))
510 (assert (not (cas bar nil t
)))))
512 (with-test (:name
:atomic-push
513 :skipped-on
'(not :sb-thread
))
514 (let ((store (cons nil nil
))
516 (symbol-macrolet ((x (car store
))
520 (mapc #'sb-thread
:join-thread
521 (loop repeat
(ecase sb-vm
:n-word-bits
(32 100) (64 1000))
522 collect
(sb-thread:make-thread
524 (loop for z
= (atomic-pop y
)
529 (assert (eql n
(length x
))))))
531 (with-test (:name
:local-special-symbol-value
)
533 (= (funcall (compile nil
536 (declare (special x
))
537 (cas (symbol-value 'x
) 10 12)
545 (declare (special x
))
546 (atomic-pop (symbol-value 'x
))))))