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
)))
157 ;; Rebind %RAW-INSTANCE-ATOMIC-INCF/WORD as a local function.
158 ;; Declaring it locally notinline fails because it is marked
159 ;; with the ALWAYS-TRANSLATABLE attribute, so it's a bug to call it
160 ;; even though we've asked to call it. (Maybe that's a bug?)
161 ;; And I don't want to call it explictly - I want the macro to do it
162 ;; so that I don't have to inject any of the sign making noise and such.
163 (declare (disable-package-locks sb-kernel
:%raw-instance-atomic-incf
/word
))
164 (let ((b (make-box :word
0))
165 (delta (- (ash 1 (1- sb-vm
:n-word-bits
))))
166 (f (eval '#'sb-kernel
:%raw-instance-atomic-incf
/word
)))
167 (flet ((sb-kernel:%raw-instance-atomic-incf
/word
(a b c
)
169 (assert (= (atomic-incf (box-word b
) delta
) 0))
170 (assert (= (atomic-incf (box-word b
) delta
)
171 (ash 1 (1- sb-vm
:n-word-bits
))))
172 (assert (= (box-word b
) 0))
173 (atomic-decf (box-word b
))
174 (assert (= (box-word b
) sb-ext
:most-positive-word
))))))
177 (with-test (:name
(:atomic-incf
/decf
:threads
))
178 (let* ((box (make-box))
179 (threads (loop repeat
64
180 collect
(sb-thread:make-thread
(lambda ()
185 :name
"inc/dec thread"))))
186 (mapc #'sb-thread
:join-thread threads
)
187 (assert (= 0 (box-word box
)))))
189 (defglobal **my-atomic-counter
* 0)
190 (declaim (fixnum **my-atomic-counter
*))
191 ;; Assert that safe (atomic-incf car) type-checks the car.
192 (with-test (:name
:atomic-incf-car-safe
)
193 (let ((x (cons (1+ most-positive-fixnum
) 0))) ; a bignum
194 (assert (eq (handler-case (atomic-incf (car x
))
195 (type-error () 'win
)) 'win
))))
197 ;; Basic correctness tests, not testing atomicity
201 ;; using a constant for the delta
202 (assert (eq (atomic-incf ,place
2) 0))
203 (assert (eq ,place
2))
204 (assert (eq (atomic-incf ,place -
1) 2))
205 (assert (eq ,place
1))
206 (assert (eq (atomic-decf ,place
1) 1))
207 (assert (eq ,place
0))
208 ;; using a non-constant for the delta
209 (assert (eq (atomic-incf ,place
(eval 2)) 0))
210 (assert (eq ,place
2))
211 (assert (eq (atomic-incf ,place
(eval -
1)) 2))
212 (assert (eq ,place
1))
213 (assert (eq (atomic-decf ,place
(eval 1)) 1))
214 (assert (eq ,place
0))
215 (setf ,place most-positive-fixnum
)
217 (assert (eq ,place most-negative-fixnum
))
219 (assert (eq ,place most-positive-fixnum
)))))
220 (with-test (:name
(:atomic-incf
:global-var
))
221 (test-place **my-atomic-counter
*))
222 (with-test (:name
(:atomic-incf
:car
))
223 (let ((x (cons 0 'foo
)))
224 (test-place (car x
))))
225 (with-test (:name
(:atomic-incf
:cdr
))
226 (let ((x (cons 'foo
0)))
227 (test-place (cdr x
))))
228 ;; Fast code for (atomic-{incf|decf} {car|cdr}) is decidedly unsafe
229 ;; on x86-64. Ensure basic correctness when used correctly.
230 (with-test (:name
(:atomic-incf-fast
:car
))
231 (let ((x (cons 0 'foo
)))
232 (declare (optimize (safety 0)))
233 (test-place (car x
))))
234 (with-test (:name
(:atomic-incf-fast
:cdr
))
235 (let ((x (cons 'foo
0)))
236 (declare (optimize (safety 0)))
237 (test-place (cdr x
)))))
239 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
241 (defclass sia-cas-test
()
245 (with-test (:name
(:cas
:standard-instance-access
))
246 (flet ((slot-loc (slot class
)
247 (sb-mop:slot-definition-location
248 (find slot
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
))))
249 (let* ((class (find-class 'sia-cas-test
))
250 (instance (make-instance class
:a
'a
:b
'b
))
251 (a-loc (slot-loc 'a class
))
252 (b-loc (slot-loc 'b class
)))
253 (assert (eq 'a
(slot-value instance
'a
)))
254 (assert (eq 'a
(compare-and-swap (sb-mop:standard-instance-access instance a-loc
)
256 (assert (eq 'a
(sb-mop:standard-instance-access instance a-loc
)))
257 (assert (eq 'a
(compare-and-swap (sb-mop:standard-instance-access instance a-loc
)
259 (assert (eq 'a2
(sb-mop:standard-instance-access instance a-loc
)))
260 (assert (eq 'a2
(slot-value instance
'a
)))
261 (assert (eq 'b
(slot-value instance
'b
)))
262 (assert (eq 'b
(sb-mop:standard-instance-access instance b-loc
))))))
264 (defclass fia-cas-test
(sb-mop:funcallable-standard-object
)
267 (:metaclass sb-mop
:funcallable-standard-class
))
269 (with-test (:name
(:cas
:standard-instance-access
))
270 (flet ((slot-loc (slot class
)
271 (sb-mop:slot-definition-location
272 (find slot
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
))))
273 (let* ((class (find-class 'fia-cas-test
))
274 (instance (make-instance class
:a
'a
:b
'b
))
275 (a-loc (slot-loc 'a class
))
276 (b-loc (slot-loc 'b class
)))
277 (sb-mop:set-funcallable-instance-function instance
(lambda () :ok
))
278 (eq :ok
(funcall instance
))
279 (assert (eq 'a
(slot-value instance
'a
)))
280 (assert (eq 'a
(compare-and-swap
281 (sb-mop:funcallable-standard-instance-access instance a-loc
)
283 (assert (eq 'a
(sb-mop:funcallable-standard-instance-access instance a-loc
)))
284 (assert (eq 'a
(compare-and-swap
285 (sb-mop:funcallable-standard-instance-access instance a-loc
)
287 (assert (eq 'a2
(sb-mop:funcallable-standard-instance-access instance a-loc
)))
288 (assert (eq 'a2
(slot-value instance
'a
)))
289 (assert (eq 'b
(slot-value instance
'b
)))
290 (assert (eq 'b
(sb-mop:funcallable-standard-instance-access instance b-loc
))))))
294 (defclass standard-thing
()
298 (defmethod slot-unbound ((class standard-class
) (obj standard-thing
) slot
)
299 (list :unbound slot
))
301 (defmethod slot-missing ((class standard-class
) (obj standard-thing
) slot op
&optional val
)
302 (list :missing slot op val
))
304 (with-test (:name
(:cas
:slot-value
:standard-object
))
305 (let ((x (make-instance 'standard-thing
)))
306 (assert (eql 42 (slot-value x
'x
)))
307 (assert (eql 42 (compare-and-swap (slot-value x
'x
) 0 :foo
)))
308 (assert (eql 42 (slot-value x
'x
)))
309 (assert (eql 42 (compare-and-swap (slot-value x
'x
) 42 :foo
)))
310 (assert (eql :foo
(slot-value x
'x
)))))
312 (with-test (:name
(:cas
:slot-value
:slot-unbound
))
313 (let ((x (make-instance 'standard-thing
)))
314 (assert (equal '(:unbound y
) (slot-value x
'y
)))
315 (assert (equal '(:unbound y
) (compare-and-swap (slot-value x
'y
) 0 :foo
)))
316 (assert (equal '(:unbound y
) (slot-value x
'y
)))
317 (assert (eq sb-pcl
:+slot-unbound
+
318 (compare-and-swap (slot-value x
'y
) sb-pcl
:+slot-unbound
+ :foo
)))
319 (assert (eq :foo
(slot-value x
'y
)))))
321 (with-test (:name
(:cas
:slot-value
:slot-missing
))
322 (let ((x (make-instance 'standard-thing
)))
323 (assert (equal '(:missing z slot-value nil
) (slot-value x
'z
)))
324 (assert (equal '(:missing z sb-ext
:cas
(0 :foo
)) (compare-and-swap (slot-value x
'z
) 0 :foo
)))
325 (assert (equal '(:missing z slot-value nil
) (slot-value x
'z
)))))
327 (defclass non-standard-class
(standard-class)
330 (defmethod sb-mop:validate-superclass
((class non-standard-class
) (superclass standard-class
))
333 (defclass non-standard-thing-0
()
335 (:metaclass non-standard-class
))
337 (defclass non-standard-thing-1
()
339 (:metaclass non-standard-class
))
341 (defclass non-standard-thing-2
()
343 (:metaclass non-standard-class
))
345 (defclass non-standard-thing-3
()
347 (:metaclass non-standard-class
))
349 (defvar *access-list
* nil
)
351 (defmethod sb-mop:slot-value-using-class
352 ((class non-standard-class
) (obj non-standard-thing-1
) slotd
)
353 (let ((v (call-next-method)))
354 (push :read
*access-list
*)
357 (defmethod (setf sb-mop
:slot-value-using-class
)
358 (value (class non-standard-class
) (obj non-standard-thing-2
) slotd
)
359 (let ((v (call-next-method)))
360 (push :write
*access-list
*)
363 (defmethod sb-mop:slot-boundp-using-class
364 ((class non-standard-class
) (obj non-standard-thing-3
) slotd
)
365 (let ((v (call-next-method)))
366 (push :boundp
*access-list
*)
369 (with-test (:name
(:cas
:slot-value
:non-standard-object
:standard-access
))
370 (let ((x (make-instance 'non-standard-thing-0
)))
371 (assert (eql 13 (slot-value x
'x
)))
372 (assert (eql 13 (compare-and-swap (slot-value x
'x
) 0 :bar
)))
373 (assert (eql 13 (slot-value x
'x
)))
374 (assert (eql 13 (compare-and-swap (slot-value x
'x
) 13 :bar
)))
375 (assert (eql :bar
(slot-value x
'x
)))))
377 (with-test (:name
(:cas
:slot-value
:non-standard-object
:slot-value-using-class
))
378 (setf *access-list
* nil
)
379 (let ((x (make-instance 'non-standard-thing-1
)))
380 (declare (notinline slot-value
))
381 (assert (null *access-list
*))
382 (assert (eql 13 (slot-value x
'x
)))
383 (assert (equal '(:read
) *access-list
*))
386 (compare-and-swap (slot-value x
'x
) 0 :bar
)
388 (assert (eql 13 (slot-value x
'x
)))
389 (assert (equal '(:read
:read
) *access-list
*))))
391 (with-test (:name
(:cas
:slot-value
:non-standard-object
:setf-slot-value-using-class
))
392 (setf *access-list
* nil
)
393 (let ((x (make-instance 'non-standard-thing-2
)))
394 (assert (equal '(:write
) *access-list
*))
395 (assert (eql 13 (slot-value x
'x
)))
396 (assert (equal '(:write
) *access-list
*))
399 (compare-and-swap (slot-value x
'x
) 0 :bar
)
401 (assert (eql 13 (slot-value x
'x
)))
402 (assert (equal '(:write
) *access-list
*))))
404 (with-test (:name
(:cas
:slot-value
:non-standard-object
:slot-boundp-using-class
))
405 (setf *access-list
* nil
)
406 (let ((x (make-instance 'non-standard-thing-3
)))
407 (assert (equal '(:boundp
) *access-list
*))
408 (assert (eql 13 (slot-value x
'x
)))
411 (compare-and-swap (slot-value x
'x
) 0 :bar
)
413 (assert (eql 13 (slot-value x
'x
)))))
420 (defun (cas foo
) (old new
)
421 (cas (symbol-value '*foo
*) old new
))
423 (with-test (:name
(:cas
:defun
))
424 (assert (null (foo)))
425 (assert (null (cas (foo) nil t
)))
426 (assert (eq t
(foo)))
427 (assert (eq t
(cas (foo) nil
:oops
)))
428 (assert (eq t
(foo))))
430 (with-test (:name
(:cas
:flet
))
432 (flet (((cas x
) (old new
)
440 (assert (null (cas (x) nil t
)))
442 (assert (eq t
(cas (x) nil
:oops
)))
443 (assert (eq t
(x))))))
445 (defgeneric (cas thing
) (old new thing
))
447 (defmethod (cas thing
) (old new
(thing cons
))
448 (cas (car thing
) old new
))
450 (defmethod (cas thing
) (old new
(thing symbol
))
451 (cas (symbol-value thing
) old new
))
453 (defgeneric thing
(thing)
456 (:method
((x symbol
))
459 (with-test (:name
(:cas
:defgeneric
))
463 (assert (null (thing a
)))
464 (assert (null (thing b
)))
465 (assert (null (cas (thing a
) nil t
)))
466 (assert (null (cas (thing b
) nil t
)))
467 (assert (eq t
(thing a
)))
468 (assert (eq t
(thing b
)))
469 (assert (eq t
(cas (thing a
) nil
:oops
)))
470 (assert (eq t
(cas (thing b
) nil
:oops
)))
471 (assert (eq t
(thing a
)))
472 (assert (eq t
(thing b
)))))
474 ;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
475 (with-test (:name
:symbol-value-cas-expansion
)
476 (multiple-value-bind (vars vals old new cas-form read-form
)
477 (get-cas-expansion `(symbol-value t
))
478 (declare (ignore old new cas-form
))
481 (assert (eq t
(eval read-form
))))
482 (multiple-value-bind (vars vals old new cas-form read-form
)
483 (get-cas-expansion `(symbol-value *))
484 (declare (ignore old new cas-form
))
487 (eval `(let (,@(mapcar 'list vars vals
))
491 (eval `(let (,@(mapcar 'list vars vals
))
494 (let ((foo (cons :foo nil
)))
495 (defun cas-foo (old new
)
496 (cas (cdr foo
) old new
)))
498 (defcas foo
() cas-foo
)
500 (with-test (:name
:cas-and-macroexpansion
)
501 (assert (not (cas (foo) nil t
)))
502 (assert (eq t
(cas (foo) t nil
)))
503 (symbol-macrolet ((bar (foo)))
504 (assert (not (cas bar nil
:ok
)))
505 (assert (eq :ok
(cas bar
:ok nil
)))
506 (assert (not (cas bar nil t
)))))
508 (with-test (:name
:atomic-push
509 :skipped-on
'(not :sb-thread
))
510 (let ((store (cons nil nil
))
512 (symbol-macrolet ((x (car store
))
516 (mapc #'sb-thread
:join-thread
517 (loop repeat
(ecase sb-vm
:n-word-bits
(32 100) (64 1000))
518 collect
(sb-thread:make-thread
520 (loop for z
= (atomic-pop y
)
525 (assert (eql n
(length x
))))))
527 (with-test (:name
:local-special-symbol-value
)
529 (= (funcall (compile nil
532 (declare (special x
))
533 (cas (symbol-value 'x
) 10 12)
541 (declare (special x
))
542 (atomic-pop (symbol-value 'x
))))))