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))))))