1bbecf9d5b9709f196ab738f11a9bbbbba75e4c9
[sbcl.git] / compare-and-swap.impure.lisp
1 ;;; Basics
2
3 (defstruct xxx yyy)
4
5 (macrolet ((test (init op)
6              `(with-test (:name (:cas :basics ,op))
7                 (let ((x ,init)
8                       (y (list 'foo))
9                       (z (list 'bar)))
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)))
13                   (let ((x "foo"))
14                     (multiple-value-bind (res err)
15                         (ignore-errors (compare-and-swap (,op x) nil nil))
16                       (unless (not res)
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))
26
27 (defvar *foo*)
28
29 ;;; thread-local bindings
30
31 (with-test (:name (:cas :tls))
32   (let ((*foo* 42))
33     (let ((*foo* nil))
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*))))
38
39 ;;; unbound symbols + symbol-value
40
41 (assert (not (boundp '*foo*)))
42
43 (with-test (:name (:cas :unbound))
44   (multiple-value-bind (res err)
45       (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
46     (assert (not res))
47     (assert (typep err 'unbound-variable))))
48
49 (defvar *bar* t)
50
51 (with-test (:name (:cas :unbound 2))
52   (let ((*bar* nil))
53     (makunbound '*bar*)
54     (multiple-value-bind (res err)
55         (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
56       (assert (not res))
57       (assert (typep err 'unbound-variable)))))
58
59 ;;; SVREF
60
61 (defvar *v* (vector 1))
62
63 ;; basics
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))))
68
69 ;; bounds
70 (with-test (:name (:cas :svref :bounds))
71   (multiple-value-bind (res err)
72       (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
73     (assert (not res))
74     (assert (typep err 'type-error)))
75   (multiple-value-bind (res err)
76       (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
77     (assert (not res))
78     (assert (typep err 'type-error))))
79
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))
84     (assert (not res))
85     (assert (typep err 'type-error))))
86
87 ;; Check that we don't modify constants
88 (defconstant +a-constant+ 42)
89 (with-test (:name (:cas :symbol-value :constant-modification))
90   (assert
91    (eq :error
92        (handler-case
93            (sb-ext:compare-and-swap (symbol-value '+a-constant+) 42 13)
94          (error () :error))))
95   (let ((name '+a-constant+))
96     (assert
97      (eq :error
98          (handler-case
99              (sb-ext:compare-and-swap (symbol-value name) 42 13)
100            (error () :error))))))
101
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))
106   (assert
107    (eq :error
108        (handler-case
109            (sb-ext:compare-and-swap (symbol-value '*a-boolean*) t 42)
110          (error () :error))))
111   (let ((name '*a-boolean*))
112     (assert
113      (eq :error
114          (handler-case
115              (sb-ext:compare-and-swap (symbol-value name) t 42)
116            (error () :error))))))
117
118 ;;;; ATOMIC-INCF and ATOMIC-DECF (we should probably rename this file atomic-ops...)
119
120 (defstruct box
121   (word 0 :type sb-vm:word))
122
123 (defun inc-box (box n)
124   (declare (fixnum n) (box box))
125   (loop repeat n
126         do (sb-ext:atomic-incf (box-word box))))
127
128 (defun dec-box (box n)
129   (declare (fixnum n) (box box))
130   (loop repeat n
131         do (sb-ext:atomic-decf (box-word box))))
132
133 (with-test (:name :atomic-incf/decf)
134   (let ((box (make-box)))
135     (inc-box box 10000)
136     (assert (= 10000 (box-word box)))
137     (dec-box box 10000)
138     (assert (= 0 (box-word box)))))
139
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)))))
144
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)))))
149
150 #+sb-thread
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 ()
155                                                          (inc-box box 1000)
156                                                          (dec-box box 10000)
157                                                          (inc-box box 10000)
158                                                          (dec-box box 1000))
159                                                        :name "inc/dec thread"))))
160     (mapc #'sb-thread:join-thread threads)
161     (assert (= 0 (box-word box)))))
162
163 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
164
165 (defclass sia-cas-test ()
166   ((a :initarg :a)
167    (b :initarg :b)))
168
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)
179                                        'x 'oops)))
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)
182                                        'a 'a2)))
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))))))
187
188 (defclass fia-cas-test (sb-mop:funcallable-standard-object)
189   ((a :initarg :a)
190    (b :initarg :b))
191   (:metaclass sb-mop:funcallable-standard-class))
192
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)
206                       'x 'oops)))
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)
210                                        'a 'a2)))
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))))))
215
216 ;;; SLOT-VALUE
217
218 (defclass standard-thing ()
219   ((x :initform 42)
220    (y)))
221
222 (defmethod slot-unbound ((class standard-class) (obj standard-thing) slot)
223   (list :unbound slot))
224
225 (defmethod slot-missing ((class standard-class) (obj standard-thing) slot op &optional val)
226   (list :missing slot op val))
227
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)))))
235
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)))))
244
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)))))
250
251 (defclass non-standard-class (standard-class)
252   ())
253
254 (defmethod sb-mop:validate-superclass ((class non-standard-class) (superclass standard-class))
255   t)
256
257 (defclass non-standard-thing-0 ()
258   ((x :initform 13))
259   (:metaclass non-standard-class))
260
261 (defclass non-standard-thing-1 ()
262   ((x :initform 13))
263   (:metaclass non-standard-class))
264
265 (defclass non-standard-thing-2 ()
266   ((x :initform 13))
267   (:metaclass non-standard-class))
268
269 (defclass non-standard-thing-3 ()
270   ((x :initform 13))
271   (:metaclass non-standard-class))
272
273 (defvar *access-list* nil)
274
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*)
279     v))
280
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*)
285     v))
286
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*)
291     v))
292
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)))))
300
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*))
308     (assert (eq :error
309                 (handler-case
310                     (compare-and-swap (slot-value x 'x) 0 :bar)
311                   (error () :error))))
312     (assert (eql 13 (slot-value x 'x)))
313     (assert (equal '(:read :read) *access-list*))))
314
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*))
321     (assert (eq :error
322                 (handler-case
323                     (compare-and-swap (slot-value x 'x) 0 :bar)
324                   (error () :error))))
325     (assert (eql 13 (slot-value x 'x)))
326     (assert (equal '(:write) *access-list*))))
327
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)))
333     (assert (eq :error
334                 (handler-case
335                     (compare-and-swap (slot-value x 'x) 0 :bar)
336                   (error () :error))))
337     (assert (eql 13 (slot-value x 'x)))))
338
339 (defvar *foo* nil)
340
341 (defun foo ()
342   *foo*)
343
344 (defun (cas foo) (old new)
345   (cas (symbol-value '*foo*) old new))
346
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))))
353
354 (with-test (:name (:cas :flet))
355   (let (x)
356     (flet (((cas x) (old new)
357              (let ((tmp x))
358                (when (eq tmp old)
359                  (setf x new))
360                tmp))
361            (x ()
362              x))
363       (assert (null (x)))
364       (assert (null (cas (x) nil t)))
365       (assert (eq t (x)))
366       (assert (eq t (cas (x) nil :oops)))
367       (assert (eq t (x))))))
368
369 (defgeneric (cas thing) (old new thing))
370
371 (defmethod (cas thing) (old new (thing cons))
372   (cas (car thing) old new))
373
374 (defmethod (cas thing) (old new (thing symbol))
375   (cas (symbol-value thing) old new))
376
377 (defgeneric thing (thing)
378   (:method ((x cons))
379     (car x))
380   (:method ((x symbol))
381     (symbol-value x)))
382
383 (with-test (:name (:cas :defgeneric))
384   (let ((a (list nil))
385         (b (gensym "X")))
386     (set b nil)
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)))))
397
398 ;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
399 (with-test (:name :symbol-value-cas-expansion)
400   (multiple-value-bind (vars vals old new cas-form read-form)
401       (get-cas-expansion `(symbol-value t))
402     (assert (not vars))
403     (assert (not vals))
404     (assert (eq t (eval read-form))))
405   (multiple-value-bind (vars vals old new cas-form read-form)
406       (get-cas-expansion `(symbol-value *))
407     (let ((* :foo))
408       (assert (eq :foo
409                   (eval `(let (,@(mapcar 'list vars vals))
410                       ,read-form)))))
411     (let ((* :bar))
412       (assert (eq :bar
413                   (eval `(let (,@(mapcar 'list vars vals))
414                       ,read-form)))))))
415
416 (let ((foo (cons :foo nil)))
417   (defun cas-foo (old new)
418     (cas (cdr foo) old new)))
419
420 (defcas foo () cas-foo)
421
422 (with-test (:name :cas-and-macroexpansion)
423   (assert (not (cas (foo) nil t)))
424   (assert (eq t (cas (foo) t nil)))
425   (symbol-macrolet ((bar (foo)))
426     (assert (not (cas bar nil :ok)))
427     (assert (eq :ok (cas bar :ok nil)))
428     (assert (not (cas bar nil t)))))
429
430 (with-test (:name atomic-push
431             :skipped-on '(not :sb-thread))
432   (let ((store (cons nil nil))
433         (n 100000))
434     (symbol-macrolet ((x (car store))
435                       (y (cdr store)))
436       (dotimes (i n)
437         (push i y))
438       (mapc #'sb-thread:join-thread
439             (loop repeat 1000
440                   collect (sb-thread:make-thread
441                            (lambda ()
442                              (loop for z = (atomic-pop y)
443                                    while z
444                                    do (atomic-push z x)
445                                       (sleep 0.00001))))))
446       (assert (not y))
447       (assert (eql n (length x))))))