1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / compare-and-swap.impure.lisp
1 ;;; Basics
2
3 (defstruct xxx yyy)
4
5 (macrolet ((test (init op)
6              `(let ((x ,init)
7                     (y (list 'foo))
8                     (z (list 'bar)))
9                 (assert (eql nil (compare-and-swap (,op x) nil y)))
10                 (assert (eql y (compare-and-swap (,op x) nil z)))
11                 (assert (eql y (,op x)))
12                 (let ((x "foo"))
13                   (multiple-value-bind (res err)
14                      (ignore-errors (compare-and-swap (,op x) nil nil))
15                     (assert (not res))
16                     (assert (typep err 'type-error)))))))
17   (test (cons nil :no) car)
18   (test (cons nil :no) first)
19   (test (cons :no nil) cdr)
20   (test (cons :no nil) rest)
21   (test '.foo. symbol-plist)
22   (test (progn (set '.bar. nil) '.bar.) symbol-value)
23   (test (make-xxx) xxx-yyy))
24
25 (defvar *foo*)
26
27 ;;; thread-local bindings
28
29 (let ((*foo* 42))
30   (let ((*foo* nil))
31     (assert (eql nil (compare-and-swap (symbol-value '*foo*) nil t)))
32     (assert (eql t (compare-and-swap (symbol-value '*foo*) nil :foo)))
33     (assert (eql t *foo*)))
34   (assert (eql 42 *foo*)))
35
36 ;;; unbound symbols + symbol-value
37
38 (assert (not (boundp '*foo*)))
39
40 (multiple-value-bind (res err)
41     (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
42   (assert (not res))
43   (assert (typep err 'unbound-variable)))
44
45 (defvar *bar* t)
46
47 (let ((*bar* nil))
48    (makunbound '*bar*)
49    (multiple-value-bind (res err)
50        (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
51      (assert (not res))
52      (assert (typep err 'unbound-variable))))
53
54 ;;; SVREF
55
56 (defvar *v* (vector 1))
57
58 ;; basics
59 (assert (eql 1 (compare-and-swap (svref *v* 0) 1 2)))
60 (assert (eql 2 (compare-and-swap (svref *v* 0) 1 3)))
61 (assert (eql 2 (svref *v* 0)))
62
63 ;; bounds
64 (multiple-value-bind (res err)
65     (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
66   (assert (not res))
67   (assert (typep err 'type-error)))
68 (multiple-value-bind (res err)
69     (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
70   (assert (not res))
71   (assert (typep err 'type-error)))
72
73 ;; type of the first argument
74 (multiple-value-bind (res err)
75     (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
76     (assert (not res))
77     (assert (typep err 'type-error)))
78
79 ;; Check that we don't modify constants
80 (defconstant +a-constant+ 42)
81 (assert
82  (eq :error
83      (handler-case
84          (sb-ext:compare-and-swap (symbol-value '+a-constant+) 42 13)
85        (error () :error))))
86 (let ((name '+a-constant+))
87   (assert
88    (eq :error
89        (handler-case
90            (sb-ext:compare-and-swap (symbol-value name) 42 13)
91          (error () :error)))))
92
93 ;; Check that we don't mess declaimed types
94 (declaim (boolean *a-boolean*))
95 (defparameter *a-boolean* t)
96 (assert
97  (eq :error
98      (handler-case
99          (sb-ext:compare-and-swap (symbol-value '*a-boolean*) t 42)
100        (error () :error))))
101 (let ((name '*a-boolean*))
102   (assert
103    (eq :error
104        (handler-case
105            (sb-ext:compare-and-swap (symbol-value name) t 42)
106          (error () :error)))))
107
108 ;;;; ATOMIC-INCF (we should probably rename this file atomic-ops...)
109
110 (defstruct box
111   (word 0 :type sb-vm:word))
112
113 (defun inc-box (box n)
114   (declare (fixnum n) (box box))
115   (loop repeat n
116         do (sb-ext:atomic-incf (box-word box))))
117
118 (defun dec-box (box n)
119   (declare (fixnum n) (box box))
120   (loop repeat n
121         do (sb-ext:atomic-incf (box-word box) -1)))
122
123 (let ((box (make-box)))
124   (inc-box box 10000)
125   (assert (= 10000 (box-word box)))
126   (dec-box box 10000)
127   (assert (= 0 (box-word box))))
128
129 #+sb-thread
130 (let* ((box (make-box))
131        (threads (loop repeat 64
132                       collect (sb-thread:make-thread (lambda ()
133                                                        (inc-box box 1000)
134                                                        (dec-box box 10000)
135                                                        (inc-box box 10000)
136                                                        (dec-box box 1000))
137                                                      :name "inc/dec thread"))))
138   (mapc #'sb-thread:join-thread threads)
139   (assert (= 0 (box-word box))))