Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / compare-and-swap.impure.lisp
1 ;;; Basics
2
3 (defstruct xxx yyy)
4
5 (macrolet ((test (init op)
6              `(with-test (:name (:cas :basics ,(intern (symbol-name op) "KEYWORD")))
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 ;; 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-")))
126
127 (defun inc-box (box n)
128   (declare (fixnum n) (box box))
129   (loop repeat n
130         do (sb-ext:atomic-incf (box-word box))))
131
132 (defun dec-box (box n)
133   (declare (fixnum n) (box box))
134   (loop repeat n
135         do (sb-ext:atomic-decf (box-word box))))
136
137 (with-test (:name :atomic-incf/decf)
138   (let ((box (make-box)))
139     (inc-box box 10000)
140     (assert (= 10000 (box-word box)))
141     (dec-box box 10000)
142     (assert (= 0 (box-word box)))))
143
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)))))
148
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)))))
153
154 #+sb-thread
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 ()
159                                                          (inc-box box 1000)
160                                                          (dec-box box 10000)
161                                                          (inc-box box 10000)
162                                                          (dec-box box 1000))
163                                                        :name "inc/dec thread"))))
164     (mapc #'sb-thread:join-thread threads)
165     (assert (= 0 (box-word box)))))
166
167 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
168
169 (defclass sia-cas-test ()
170   ((a :initarg :a)
171    (b :initarg :b)))
172
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)
183                                        'x 'oops)))
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)
186                                        'a 'a2)))
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))))))
191
192 (defclass fia-cas-test (sb-mop:funcallable-standard-object)
193   ((a :initarg :a)
194    (b :initarg :b))
195   (:metaclass sb-mop:funcallable-standard-class))
196
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)
210                       'x 'oops)))
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)
214                                        'a 'a2)))
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))))))
219
220 ;;; SLOT-VALUE
221
222 (defclass standard-thing ()
223   ((x :initform 42)
224    (y)))
225
226 (defmethod slot-unbound ((class standard-class) (obj standard-thing) slot)
227   (list :unbound slot))
228
229 (defmethod slot-missing ((class standard-class) (obj standard-thing) slot op &optional val)
230   (list :missing slot op val))
231
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)))))
239
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)))))
248
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)))))
254
255 (defclass non-standard-class (standard-class)
256   ())
257
258 (defmethod sb-mop:validate-superclass ((class non-standard-class) (superclass standard-class))
259   t)
260
261 (defclass non-standard-thing-0 ()
262   ((x :initform 13))
263   (:metaclass non-standard-class))
264
265 (defclass non-standard-thing-1 ()
266   ((x :initform 13))
267   (:metaclass non-standard-class))
268
269 (defclass non-standard-thing-2 ()
270   ((x :initform 13))
271   (:metaclass non-standard-class))
272
273 (defclass non-standard-thing-3 ()
274   ((x :initform 13))
275   (:metaclass non-standard-class))
276
277 (defvar *access-list* nil)
278
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*)
283     v))
284
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*)
289     v))
290
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*)
295     v))
296
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)))))
304
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*))
312     (assert (eq :error
313                 (handler-case
314                     (compare-and-swap (slot-value x 'x) 0 :bar)
315                   (error () :error))))
316     (assert (eql 13 (slot-value x 'x)))
317     (assert (equal '(:read :read) *access-list*))))
318
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*))
325     (assert (eq :error
326                 (handler-case
327                     (compare-and-swap (slot-value x 'x) 0 :bar)
328                   (error () :error))))
329     (assert (eql 13 (slot-value x 'x)))
330     (assert (equal '(:write) *access-list*))))
331
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)))
337     (assert (eq :error
338                 (handler-case
339                     (compare-and-swap (slot-value x 'x) 0 :bar)
340                   (error () :error))))
341     (assert (eql 13 (slot-value x 'x)))))
342
343 (defvar *foo* nil)
344
345 (defun foo ()
346   *foo*)
347
348 (defun (cas foo) (old new)
349   (cas (symbol-value '*foo*) old new))
350
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))))
357
358 (with-test (:name (:cas :flet))
359   (let (x)
360     (flet (((cas x) (old new)
361              (let ((tmp x))
362                (when (eq tmp old)
363                  (setf x new))
364                tmp))
365            (x ()
366              x))
367       (assert (null (x)))
368       (assert (null (cas (x) nil t)))
369       (assert (eq t (x)))
370       (assert (eq t (cas (x) nil :oops)))
371       (assert (eq t (x))))))
372
373 (defgeneric (cas thing) (old new thing))
374
375 (defmethod (cas thing) (old new (thing cons))
376   (cas (car thing) old new))
377
378 (defmethod (cas thing) (old new (thing symbol))
379   (cas (symbol-value thing) old new))
380
381 (defgeneric thing (thing)
382   (:method ((x cons))
383     (car x))
384   (:method ((x symbol))
385     (symbol-value x)))
386
387 (with-test (:name (:cas :defgeneric))
388   (let ((a (list nil))
389         (b (gensym "X")))
390     (set b nil)
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)))))
401
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))
406     (assert (not vars))
407     (assert (not vals))
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 *))
411     (let ((* :foo))
412       (assert (eq :foo
413                   (eval `(let (,@(mapcar 'list vars vals))
414                       ,read-form)))))
415     (let ((* :bar))
416       (assert (eq :bar
417                   (eval `(let (,@(mapcar 'list vars vals))
418                       ,read-form)))))))
419
420 (let ((foo (cons :foo nil)))
421   (defun cas-foo (old new)
422     (cas (cdr foo) old new)))
423
424 (defcas foo () cas-foo)
425
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)))))
433
434 (with-test (:name :atomic-push
435             :skipped-on '(not :sb-thread))
436   (let ((store (cons nil nil))
437         (n 100000))
438     (symbol-macrolet ((x (car store))
439                       (y (cdr store)))
440       (dotimes (i n)
441         (push i y))
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
445                            (lambda ()
446                              (loop for z = (atomic-pop y)
447                                    while z
448                                    do (atomic-push z x)
449                                       (sleep 0.00001))))))
450       (assert (not y))
451       (assert (eql n (length x))))))