5 (macrolet ((test (init op
)
6 `(with-test (:name
(:cas
:basics
,op
))
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 (defun inc-box (box n
)
124 (declare (fixnum n
) (box box
))
126 do
(sb-ext:atomic-incf
(box-word box
))))
128 (defun dec-box (box n
)
129 (declare (fixnum n
) (box box
))
131 do
(sb-ext:atomic-decf
(box-word box
))))
133 (with-test (:name
:atomic-incf
/decf
)
134 (let ((box (make-box)))
136 (assert (= 10000 (box-word box
)))
138 (assert (= 0 (box-word box
)))))
140 (with-test (:name
:atomic-incf-wraparound
)
141 (let ((box (make-box :word
(1- (ash 1 sb-vm
:n-word-bits
)))))
142 (sb-ext:atomic-incf
(box-word box
) 2)
143 (assert (= 1 (box-word box
)))))
145 (with-test (:name
:atomic-decf-wraparound
)
146 (let ((box (make-box :word
0)))
147 (sb-ext:atomic-decf
(box-word box
) 2)
148 (assert (= (- (ash 1 sb-vm
:n-word-bits
) 2) (box-word box
)))))
151 (with-test (:name
(:atomic-incf
/decf
:threads
))
152 (let* ((box (make-box))
153 (threads (loop repeat
64
154 collect
(sb-thread:make-thread
(lambda ()
159 :name
"inc/dec thread"))))
160 (mapc #'sb-thread
:join-thread threads
)
161 (assert (= 0 (box-word box
)))))
163 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
165 (defclass sia-cas-test
()
169 (with-test (:name
(:cas
:standard-instance-access
))
170 (flet ((slot-loc (slot class
)
171 (sb-mop:slot-definition-location
172 (find slot
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
))))
173 (let* ((class (find-class 'sia-cas-test
))
174 (instance (make-instance class
:a
'a
:b
'b
))
175 (a-loc (slot-loc 'a class
))
176 (b-loc (slot-loc 'b class
)))
177 (assert (eq 'a
(slot-value instance
'a
)))
178 (assert (eq 'a
(compare-and-swap (sb-mop:standard-instance-access instance a-loc
)
180 (assert (eq 'a
(sb-mop:standard-instance-access instance a-loc
)))
181 (assert (eq 'a
(compare-and-swap (sb-mop:standard-instance-access instance a-loc
)
183 (assert (eq 'a2
(sb-mop:standard-instance-access instance a-loc
)))
184 (assert (eq 'a2
(slot-value instance
'a
)))
185 (assert (eq 'b
(slot-value instance
'b
)))
186 (assert (eq 'b
(sb-mop:standard-instance-access instance b-loc
))))))
188 (defclass fia-cas-test
(sb-mop:funcallable-standard-object
)
191 (:metaclass sb-mop
:funcallable-standard-class
))
193 (with-test (:name
(:cas
:standard-instance-access
))
194 (flet ((slot-loc (slot class
)
195 (sb-mop:slot-definition-location
196 (find slot
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
))))
197 (let* ((class (find-class 'fia-cas-test
))
198 (instance (make-instance class
:a
'a
:b
'b
))
199 (a-loc (slot-loc 'a class
))
200 (b-loc (slot-loc 'b class
)))
201 (sb-mop:set-funcallable-instance-function instance
(lambda () :ok
))
202 (eq :ok
(funcall instance
))
203 (assert (eq 'a
(slot-value instance
'a
)))
204 (assert (eq 'a
(compare-and-swap
205 (sb-mop:funcallable-standard-instance-access instance a-loc
)
207 (assert (eq 'a
(sb-mop:funcallable-standard-instance-access instance a-loc
)))
208 (assert (eq 'a
(compare-and-swap
209 (sb-mop:funcallable-standard-instance-access instance a-loc
)
211 (assert (eq 'a2
(sb-mop:funcallable-standard-instance-access instance a-loc
)))
212 (assert (eq 'a2
(slot-value instance
'a
)))
213 (assert (eq 'b
(slot-value instance
'b
)))
214 (assert (eq 'b
(sb-mop:funcallable-standard-instance-access instance b-loc
))))))
218 (defclass standard-thing
()
222 (defmethod slot-unbound ((class standard-class
) (obj standard-thing
) slot
)
223 (list :unbound slot
))
225 (defmethod slot-missing ((class standard-class
) (obj standard-thing
) slot op
&optional val
)
226 (list :missing slot op val
))
228 (with-test (:name
(:cas
:slot-value
:standard-object
))
229 (let ((x (make-instance 'standard-thing
)))
230 (assert (eql 42 (slot-value x
'x
)))
231 (assert (eql 42 (compare-and-swap (slot-value x
'x
) 0 :foo
)))
232 (assert (eql 42 (slot-value x
'x
)))
233 (assert (eql 42 (compare-and-swap (slot-value x
'x
) 42 :foo
)))
234 (assert (eql :foo
(slot-value x
'x
)))))
236 (with-test (:name
(:cas
:slot-value
:slot-unbound
))
237 (let ((x (make-instance 'standard-thing
)))
238 (assert (equal '(:unbound y
) (slot-value x
'y
)))
239 (assert (equal '(:unbound y
) (compare-and-swap (slot-value x
'y
) 0 :foo
)))
240 (assert (equal '(:unbound y
) (slot-value x
'y
)))
241 (assert (eq sb-pcl
:+slot-unbound
+
242 (compare-and-swap (slot-value x
'y
) sb-pcl
:+slot-unbound
+ :foo
)))
243 (assert (eq :foo
(slot-value x
'y
)))))
245 (with-test (:name
(:cas
:slot-value
:slot-missing
))
246 (let ((x (make-instance 'standard-thing
)))
247 (assert (equal '(:missing z slot-value nil
) (slot-value x
'z
)))
248 (assert (equal '(:missing z sb-ext
:cas
(0 :foo
)) (compare-and-swap (slot-value x
'z
) 0 :foo
)))
249 (assert (equal '(:missing z slot-value nil
) (slot-value x
'z
)))))
251 (defclass non-standard-class
(standard-class)
254 (defmethod sb-mop:validate-superclass
((class non-standard-class
) (superclass standard-class
))
257 (defclass non-standard-thing-0
()
259 (:metaclass non-standard-class
))
261 (defclass non-standard-thing-1
()
263 (:metaclass non-standard-class
))
265 (defclass non-standard-thing-2
()
267 (:metaclass non-standard-class
))
269 (defclass non-standard-thing-3
()
271 (:metaclass non-standard-class
))
273 (defvar *access-list
* nil
)
275 (defmethod sb-mop:slot-value-using-class
276 ((class non-standard-class
) (obj non-standard-thing-1
) slotd
)
277 (let ((v (call-next-method)))
278 (push :read
*access-list
*)
281 (defmethod (setf sb-mop
:slot-value-using-class
)
282 (value (class non-standard-class
) (obj non-standard-thing-2
) slotd
)
283 (let ((v (call-next-method)))
284 (push :write
*access-list
*)
287 (defmethod sb-mop:slot-boundp-using-class
288 ((class non-standard-class
) (obj non-standard-thing-3
) slotd
)
289 (let ((v (call-next-method)))
290 (push :boundp
*access-list
*)
293 (with-test (:name
(:cas
:slot-value
:non-standard-object
:standard-access
))
294 (let ((x (make-instance 'non-standard-thing-0
)))
295 (assert (eql 13 (slot-value x
'x
)))
296 (assert (eql 13 (compare-and-swap (slot-value x
'x
) 0 :bar
)))
297 (assert (eql 13 (slot-value x
'x
)))
298 (assert (eql 13 (compare-and-swap (slot-value x
'x
) 13 :bar
)))
299 (assert (eql :bar
(slot-value x
'x
)))))
301 (with-test (:name
(:cas
:slot-value
:non-standard-object
:slot-value-using-class
))
302 (setf *access-list
* nil
)
303 (let ((x (make-instance 'non-standard-thing-1
)))
304 (declare (notinline slot-value
))
305 (assert (null *access-list
*))
306 (assert (eql 13 (slot-value x
'x
)))
307 (assert (equal '(:read
) *access-list
*))
310 (compare-and-swap (slot-value x
'x
) 0 :bar
)
312 (assert (eql 13 (slot-value x
'x
)))
313 (assert (equal '(:read
:read
) *access-list
*))))
315 (with-test (:name
(:cas
:slot-value
:non-standard-object
:setf-slot-value-using-class
))
316 (setf *access-list
* nil
)
317 (let ((x (make-instance 'non-standard-thing-2
)))
318 (assert (equal '(:write
) *access-list
*))
319 (assert (eql 13 (slot-value x
'x
)))
320 (assert (equal '(:write
) *access-list
*))
323 (compare-and-swap (slot-value x
'x
) 0 :bar
)
325 (assert (eql 13 (slot-value x
'x
)))
326 (assert (equal '(:write
) *access-list
*))))
328 (with-test (:name
(:cas
:slot-value
:non-standard-object
:slot-boundp-using-class
))
329 (setf *access-list
* nil
)
330 (let ((x (make-instance 'non-standard-thing-3
)))
331 (assert (equal '(:boundp
) *access-list
*))
332 (assert (eql 13 (slot-value x
'x
)))
335 (compare-and-swap (slot-value x
'x
) 0 :bar
)
337 (assert (eql 13 (slot-value x
'x
)))))
344 (defun (cas foo
) (old new
)
345 (cas (symbol-value '*foo
*) old new
))
347 (with-test (:name
(:cas
:defun
))
348 (assert (null (foo)))
349 (assert (null (cas (foo) nil t
)))
350 (assert (eq t
(foo)))
351 (assert (eq t
(cas (foo) nil
:oops
)))
352 (assert (eq t
(foo))))
354 (with-test (:name
(:cas
:flet
))
356 (flet (((cas x
) (old new
)
364 (assert (null (cas (x) nil t
)))
366 (assert (eq t
(cas (x) nil
:oops
)))
367 (assert (eq t
(x))))))
369 (defgeneric (cas thing
) (old new thing
))
371 (defmethod (cas thing
) (old new
(thing cons
))
372 (cas (car thing
) old new
))
374 (defmethod (cas thing
) (old new
(thing symbol
))
375 (cas (symbol-value thing
) old new
))
377 (defgeneric thing
(thing)
380 (:method
((x symbol
))
383 (with-test (:name
(:cas
:defgeneric
))
387 (assert (null (thing a
)))
388 (assert (null (thing b
)))
389 (assert (null (cas (thing a
) nil t
)))
390 (assert (null (cas (thing b
) nil t
)))
391 (assert (eq t
(thing a
)))
392 (assert (eq t
(thing b
)))
393 (assert (eq t
(cas (thing a
) nil
:oops
)))
394 (assert (eq t
(cas (thing b
) nil
:oops
)))
395 (assert (eq t
(thing a
)))
396 (assert (eq t
(thing b
)))))