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)))))
155 (with-test (:name (:atomic-incf/decf :threads))
156 (let* ((box (make-box))
157 (threads (loop repeat 64
158 collect (sb-thread:make-thread (lambda ()
163 :name "inc/dec thread"))))
164 (mapc #'sb-thread:join-thread threads)
165 (assert (= 0 (box-word box)))))
167 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
169 (defclass sia-cas-test ()
173 (with-test (:name (:cas :standard-instance-access))
174 (flet ((slot-loc (slot class)
175 (sb-mop:slot-definition-location
176 (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
177 (let* ((class (find-class 'sia-cas-test))
178 (instance (make-instance class :a 'a :b 'b))
179 (a-loc (slot-loc 'a class))
180 (b-loc (slot-loc 'b class)))
181 (assert (eq 'a (slot-value instance 'a)))
182 (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
184 (assert (eq 'a (sb-mop:standard-instance-access instance a-loc)))
185 (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
187 (assert (eq 'a2 (sb-mop:standard-instance-access instance a-loc)))
188 (assert (eq 'a2 (slot-value instance 'a)))
189 (assert (eq 'b (slot-value instance 'b)))
190 (assert (eq 'b (sb-mop:standard-instance-access instance b-loc))))))
192 (defclass fia-cas-test (sb-mop:funcallable-standard-object)
195 (:metaclass sb-mop:funcallable-standard-class))
197 (with-test (:name (:cas :standard-instance-access))
198 (flet ((slot-loc (slot class)
199 (sb-mop:slot-definition-location
200 (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
201 (let* ((class (find-class 'fia-cas-test))
202 (instance (make-instance class :a 'a :b 'b))
203 (a-loc (slot-loc 'a class))
204 (b-loc (slot-loc 'b class)))
205 (sb-mop:set-funcallable-instance-function instance (lambda () :ok))
206 (eq :ok (funcall instance))
207 (assert (eq 'a (slot-value instance 'a)))
208 (assert (eq 'a (compare-and-swap
209 (sb-mop:funcallable-standard-instance-access instance a-loc)
211 (assert (eq 'a (sb-mop:funcallable-standard-instance-access instance a-loc)))
212 (assert (eq 'a (compare-and-swap
213 (sb-mop:funcallable-standard-instance-access instance a-loc)
215 (assert (eq 'a2 (sb-mop:funcallable-standard-instance-access instance a-loc)))
216 (assert (eq 'a2 (slot-value instance 'a)))
217 (assert (eq 'b (slot-value instance 'b)))
218 (assert (eq 'b (sb-mop:funcallable-standard-instance-access instance b-loc))))))
222 (defclass standard-thing ()
226 (defmethod slot-unbound ((class standard-class) (obj standard-thing) slot)
227 (list :unbound slot))
229 (defmethod slot-missing ((class standard-class) (obj standard-thing) slot op &optional val)
230 (list :missing slot op val))
232 (with-test (:name (:cas :slot-value :standard-object))
233 (let ((x (make-instance 'standard-thing)))
234 (assert (eql 42 (slot-value x 'x)))
235 (assert (eql 42 (compare-and-swap (slot-value x 'x) 0 :foo)))
236 (assert (eql 42 (slot-value x 'x)))
237 (assert (eql 42 (compare-and-swap (slot-value x 'x) 42 :foo)))
238 (assert (eql :foo (slot-value x 'x)))))
240 (with-test (:name (:cas :slot-value :slot-unbound))
241 (let ((x (make-instance 'standard-thing)))
242 (assert (equal '(:unbound y) (slot-value x 'y)))
243 (assert (equal '(:unbound y) (compare-and-swap (slot-value x 'y) 0 :foo)))
244 (assert (equal '(:unbound y) (slot-value x 'y)))
245 (assert (eq sb-pcl:+slot-unbound+
246 (compare-and-swap (slot-value x 'y) sb-pcl:+slot-unbound+ :foo)))
247 (assert (eq :foo (slot-value x 'y)))))
249 (with-test (:name (:cas :slot-value :slot-missing))
250 (let ((x (make-instance 'standard-thing)))
251 (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))
252 (assert (equal '(:missing z sb-ext:cas (0 :foo)) (compare-and-swap (slot-value x 'z) 0 :foo)))
253 (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))))
255 (defclass non-standard-class (standard-class)
258 (defmethod sb-mop:validate-superclass ((class non-standard-class) (superclass standard-class))
261 (defclass non-standard-thing-0 ()
263 (:metaclass non-standard-class))
265 (defclass non-standard-thing-1 ()
267 (:metaclass non-standard-class))
269 (defclass non-standard-thing-2 ()
271 (:metaclass non-standard-class))
273 (defclass non-standard-thing-3 ()
275 (:metaclass non-standard-class))
277 (defvar *access-list* nil)
279 (defmethod sb-mop:slot-value-using-class
280 ((class non-standard-class) (obj non-standard-thing-1) slotd)
281 (let ((v (call-next-method)))
282 (push :read *access-list*)
285 (defmethod (setf sb-mop:slot-value-using-class)
286 (value (class non-standard-class) (obj non-standard-thing-2) slotd)
287 (let ((v (call-next-method)))
288 (push :write *access-list*)
291 (defmethod sb-mop:slot-boundp-using-class
292 ((class non-standard-class) (obj non-standard-thing-3) slotd)
293 (let ((v (call-next-method)))
294 (push :boundp *access-list*)
297 (with-test (:name (:cas :slot-value :non-standard-object :standard-access))
298 (let ((x (make-instance 'non-standard-thing-0)))
299 (assert (eql 13 (slot-value x 'x)))
300 (assert (eql 13 (compare-and-swap (slot-value x 'x) 0 :bar)))
301 (assert (eql 13 (slot-value x 'x)))
302 (assert (eql 13 (compare-and-swap (slot-value x 'x) 13 :bar)))
303 (assert (eql :bar (slot-value x 'x)))))
305 (with-test (:name (:cas :slot-value :non-standard-object :slot-value-using-class))
306 (setf *access-list* nil)
307 (let ((x (make-instance 'non-standard-thing-1)))
308 (declare (notinline slot-value))
309 (assert (null *access-list*))
310 (assert (eql 13 (slot-value x 'x)))
311 (assert (equal '(:read) *access-list*))
314 (compare-and-swap (slot-value x 'x) 0 :bar)
316 (assert (eql 13 (slot-value x 'x)))
317 (assert (equal '(:read :read) *access-list*))))
319 (with-test (:name (:cas :slot-value :non-standard-object :setf-slot-value-using-class))
320 (setf *access-list* nil)
321 (let ((x (make-instance 'non-standard-thing-2)))
322 (assert (equal '(:write) *access-list*))
323 (assert (eql 13 (slot-value x 'x)))
324 (assert (equal '(:write) *access-list*))
327 (compare-and-swap (slot-value x 'x) 0 :bar)
329 (assert (eql 13 (slot-value x 'x)))
330 (assert (equal '(:write) *access-list*))))
332 (with-test (:name (:cas :slot-value :non-standard-object :slot-boundp-using-class))
333 (setf *access-list* nil)
334 (let ((x (make-instance 'non-standard-thing-3)))
335 (assert (equal '(:boundp) *access-list*))
336 (assert (eql 13 (slot-value x 'x)))
339 (compare-and-swap (slot-value x 'x) 0 :bar)
341 (assert (eql 13 (slot-value x 'x)))))
348 (defun (cas foo) (old new)
349 (cas (symbol-value '*foo*) old new))
351 (with-test (:name (:cas :defun))
352 (assert (null (foo)))
353 (assert (null (cas (foo) nil t)))
354 (assert (eq t (foo)))
355 (assert (eq t (cas (foo) nil :oops)))
356 (assert (eq t (foo))))
358 (with-test (:name (:cas :flet))
360 (flet (((cas x) (old new)
368 (assert (null (cas (x) nil t)))
370 (assert (eq t (cas (x) nil :oops)))
371 (assert (eq t (x))))))
373 (defgeneric (cas thing) (old new thing))
375 (defmethod (cas thing) (old new (thing cons))
376 (cas (car thing) old new))
378 (defmethod (cas thing) (old new (thing symbol))
379 (cas (symbol-value thing) old new))
381 (defgeneric thing (thing)
384 (:method ((x symbol))
387 (with-test (:name (:cas :defgeneric))
391 (assert (null (thing a)))
392 (assert (null (thing b)))
393 (assert (null (cas (thing a) nil t)))
394 (assert (null (cas (thing b) nil t)))
395 (assert (eq t (thing a)))
396 (assert (eq t (thing b)))
397 (assert (eq t (cas (thing a) nil :oops)))
398 (assert (eq t (cas (thing b) nil :oops)))
399 (assert (eq t (thing a)))
400 (assert (eq t (thing b)))))
402 ;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
403 (with-test (:name :symbol-value-cas-expansion)
404 (multiple-value-bind (vars vals old new cas-form read-form)
405 (get-cas-expansion `(symbol-value t))
408 (assert (eq t (eval read-form))))
409 (multiple-value-bind (vars vals old new cas-form read-form)
410 (get-cas-expansion `(symbol-value *))
413 (eval `(let (,@(mapcar 'list vars vals))
417 (eval `(let (,@(mapcar 'list vars vals))
420 (let ((foo (cons :foo nil)))
421 (defun cas-foo (old new)
422 (cas (cdr foo) old new)))
424 (defcas foo () cas-foo)
426 (with-test (:name :cas-and-macroexpansion)
427 (assert (not (cas (foo) nil t)))
428 (assert (eq t (cas (foo) t nil)))
429 (symbol-macrolet ((bar (foo)))
430 (assert (not (cas bar nil :ok)))
431 (assert (eq :ok (cas bar :ok nil)))
432 (assert (not (cas bar nil t)))))
434 (with-test (:name :atomic-push
435 :skipped-on '(not :sb-thread))
436 (let ((store (cons nil nil))
438 (symbol-macrolet ((x (car store))
442 (mapc #'sb-thread:join-thread
443 (loop repeat (ecase sb-vm:n-word-bits (32 100) (64 1000))
444 collect (sb-thread:make-thread
446 (loop for z = (atomic-pop y)
451 (assert (eql n (length x))))))