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 (defglobal **my-atomic-counter* 0)
 168 (declaim (fixnum **my-atomic-counter*))
 169 ;; Assert that safe (atomic-incf car) type-checks the car.
 170 (with-test (:name :atomic-incf-car-safe)
 171   (let ((x (cons (1+ most-positive-fixnum) 0))) ; a bignum
 172     (assert (eq (handler-case (atomic-incf (car x))
 173                   (type-error () 'win)) 'win))))
 174
 175 ;; Basic correctness tests, not testing atomicity
 176 (macrolet
 177     ((test-place (place)
 178        `(progn
 179           ;; using a constant for the delta
 180           (assert (eq (atomic-incf ,place 2) 0))
 181           (assert (eq ,place 2))
 182           (assert (eq (atomic-incf ,place -1) 2))
 183           (assert (eq ,place 1))
 184           (assert (eq (atomic-decf ,place 1) 1))
 185           (assert (eq ,place 0))
 186           ;; using a non-constant for the delta
 187           (assert (eq (atomic-incf ,place (eval 2)) 0))
 188           (assert (eq ,place 2))
 189           (assert (eq (atomic-incf ,place (eval -1)) 2))
 190           (assert (eq ,place 1))
 191           (assert (eq (atomic-decf ,place (eval 1)) 1))
 192           (assert (eq ,place 0))
 193           (setf ,place most-positive-fixnum)
 194           (atomic-incf ,place)
 195           (assert (eq ,place most-negative-fixnum))
 196           (atomic-decf ,place)
 197           (assert (eq ,place most-positive-fixnum)))))
 198   (with-test (:name (:atomic-incf :global-var))
 199     (test-place **my-atomic-counter*))
 200   (with-test (:name (:atomic-incf :car))
 201     (let ((x (cons 0 'foo)))
 202       (test-place (car x))))
 203   (with-test (:name (:atomic-incf :cdr))
 204     (let ((x (cons 'foo 0)))
 205       (test-place (cdr x))))
 206   ;; Fast code for (atomic-{incf|decf} {car|cdr}) is decidedly unsafe
 207   ;; on x86-64. Ensure basic correctness when used correctly.
 208   (with-test (:name (:atomic-incf-fast :car))
 209     (let ((x (cons 0 'foo)))
 210       (declare (optimize (safety 0)))
 211       (test-place (car x))))
 212   (with-test (:name (:atomic-incf-fast :cdr))
 213     (let ((x (cons 'foo 0)))
 214       (declare (optimize (safety 0)))
 215       (test-place (cdr x)))))
 216
 217 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
 218
 219 (defclass sia-cas-test ()
 220   ((a :initarg :a)
 221    (b :initarg :b)))
 222
 223 (with-test (:name (:cas :standard-instance-access))
 224   (flet ((slot-loc (slot class)
 225            (sb-mop:slot-definition-location
 226             (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
 227     (let* ((class (find-class 'sia-cas-test))
 228            (instance (make-instance class :a 'a :b 'b))
 229            (a-loc (slot-loc 'a class))
 230            (b-loc (slot-loc 'b class)))
 231       (assert (eq 'a (slot-value instance 'a)))
 232       (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
 233                                        'x 'oops)))
 234       (assert (eq 'a (sb-mop:standard-instance-access instance a-loc)))
 235       (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
 236                                        'a 'a2)))
 237       (assert (eq 'a2 (sb-mop:standard-instance-access instance a-loc)))
 238       (assert (eq 'a2 (slot-value instance 'a)))
 239       (assert (eq 'b (slot-value instance 'b)))
 240       (assert (eq 'b (sb-mop:standard-instance-access instance b-loc))))))
 241
 242 (defclass fia-cas-test (sb-mop:funcallable-standard-object)
 243   ((a :initarg :a)
 244    (b :initarg :b))
 245   (:metaclass sb-mop:funcallable-standard-class))
 246
 247 (with-test (:name (:cas :standard-instance-access))
 248   (flet ((slot-loc (slot class)
 249            (sb-mop:slot-definition-location
 250             (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
 251     (let* ((class (find-class 'fia-cas-test))
 252            (instance (make-instance class :a 'a :b 'b))
 253            (a-loc (slot-loc 'a class))
 254            (b-loc (slot-loc 'b class)))
 255       (sb-mop:set-funcallable-instance-function instance (lambda () :ok))
 256       (eq :ok (funcall instance))
 257       (assert (eq 'a (slot-value instance 'a)))
 258       (assert (eq 'a (compare-and-swap
 259                       (sb-mop:funcallable-standard-instance-access instance a-loc)
 260                       'x 'oops)))
 261       (assert (eq 'a (sb-mop:funcallable-standard-instance-access instance a-loc)))
 262       (assert (eq 'a (compare-and-swap
 263                       (sb-mop:funcallable-standard-instance-access instance a-loc)
 264                                        'a 'a2)))
 265       (assert (eq 'a2 (sb-mop:funcallable-standard-instance-access instance a-loc)))
 266       (assert (eq 'a2 (slot-value instance 'a)))
 267       (assert (eq 'b (slot-value instance 'b)))
 268       (assert (eq 'b (sb-mop:funcallable-standard-instance-access instance b-loc))))))
 269
 270 ;;; SLOT-VALUE
 271
 272 (defclass standard-thing ()
 273   ((x :initform 42)
 274    (y)))
 275
 276 (defmethod slot-unbound ((class standard-class) (obj standard-thing) slot)
 277   (list :unbound slot))
 278
 279 (defmethod slot-missing ((class standard-class) (obj standard-thing) slot op &optional val)
 280   (list :missing slot op val))
 281
 282 (with-test (:name (:cas :slot-value :standard-object))
 283   (let ((x (make-instance 'standard-thing)))
 284     (assert (eql 42 (slot-value x 'x)))
 285     (assert (eql 42 (compare-and-swap (slot-value x 'x) 0 :foo)))
 286     (assert (eql 42 (slot-value x 'x)))
 287     (assert (eql 42 (compare-and-swap (slot-value x 'x) 42 :foo)))
 288     (assert (eql :foo (slot-value x 'x)))))
 289
 290 (with-test (:name (:cas :slot-value :slot-unbound))
 291   (let ((x (make-instance 'standard-thing)))
 292     (assert (equal '(:unbound y) (slot-value x 'y)))
 293     (assert (equal '(:unbound y) (compare-and-swap (slot-value x 'y) 0 :foo)))
 294     (assert (equal '(:unbound y) (slot-value x 'y)))
 295     (assert (eq sb-pcl:+slot-unbound+
 296                 (compare-and-swap (slot-value x 'y) sb-pcl:+slot-unbound+ :foo)))
 297     (assert (eq :foo (slot-value x 'y)))))
 298
 299 (with-test (:name (:cas :slot-value :slot-missing))
 300   (let ((x (make-instance 'standard-thing)))
 301     (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))
 302     (assert (equal '(:missing z sb-ext:cas (0 :foo)) (compare-and-swap (slot-value x 'z) 0 :foo)))
 303     (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))))
 304
 305 (defclass non-standard-class (standard-class)
 306   ())
 307
 308 (defmethod sb-mop:validate-superclass ((class non-standard-class) (superclass standard-class))
 309   t)
 310
 311 (defclass non-standard-thing-0 ()
 312   ((x :initform 13))
 313   (:metaclass non-standard-class))
 314
 315 (defclass non-standard-thing-1 ()
 316   ((x :initform 13))
 317   (:metaclass non-standard-class))
 318
 319 (defclass non-standard-thing-2 ()
 320   ((x :initform 13))
 321   (:metaclass non-standard-class))
 322
 323 (defclass non-standard-thing-3 ()
 324   ((x :initform 13))
 325   (:metaclass non-standard-class))
 326
 327 (defvar *access-list* nil)
 328
 329 (defmethod sb-mop:slot-value-using-class
 330     ((class non-standard-class) (obj non-standard-thing-1) slotd)
 331   (let ((v (call-next-method)))
 332     (push :read *access-list*)
 333     v))
 334
 335 (defmethod (setf sb-mop:slot-value-using-class)
 336     (value (class non-standard-class) (obj non-standard-thing-2) slotd)
 337   (let ((v (call-next-method)))
 338     (push :write *access-list*)
 339     v))
 340
 341 (defmethod sb-mop:slot-boundp-using-class
 342     ((class non-standard-class) (obj non-standard-thing-3) slotd)
 343   (let ((v (call-next-method)))
 344     (push :boundp *access-list*)
 345     v))
 346
 347 (with-test (:name (:cas :slot-value :non-standard-object :standard-access))
 348   (let ((x (make-instance 'non-standard-thing-0)))
 349     (assert (eql 13 (slot-value x 'x)))
 350     (assert (eql 13 (compare-and-swap (slot-value x 'x) 0 :bar)))
 351     (assert (eql 13 (slot-value x 'x)))
 352     (assert (eql 13 (compare-and-swap (slot-value x 'x) 13 :bar)))
 353     (assert (eql :bar (slot-value x 'x)))))
 354
 355 (with-test (:name (:cas :slot-value :non-standard-object :slot-value-using-class))
 356   (setf *access-list* nil)
 357   (let ((x (make-instance 'non-standard-thing-1)))
 358     (declare (notinline slot-value))
 359     (assert (null *access-list*))
 360     (assert (eql 13 (slot-value x 'x)))
 361     (assert (equal '(:read) *access-list*))
 362     (assert (eq :error
 363                 (handler-case
 364                     (compare-and-swap (slot-value x 'x) 0 :bar)
 365                   (error () :error))))
 366     (assert (eql 13 (slot-value x 'x)))
 367     (assert (equal '(:read :read) *access-list*))))
 368
 369 (with-test (:name (:cas :slot-value :non-standard-object :setf-slot-value-using-class))
 370   (setf *access-list* nil)
 371   (let ((x (make-instance 'non-standard-thing-2)))
 372     (assert (equal '(:write) *access-list*))
 373     (assert (eql 13 (slot-value x 'x)))
 374     (assert (equal '(:write) *access-list*))
 375     (assert (eq :error
 376                 (handler-case
 377                     (compare-and-swap (slot-value x 'x) 0 :bar)
 378                   (error () :error))))
 379     (assert (eql 13 (slot-value x 'x)))
 380     (assert (equal '(:write) *access-list*))))
 381
 382 (with-test (:name (:cas :slot-value :non-standard-object :slot-boundp-using-class))
 383   (setf *access-list* nil)
 384   (let ((x (make-instance 'non-standard-thing-3)))
 385     (assert (equal '(:boundp) *access-list*))
 386     (assert (eql 13 (slot-value x 'x)))
 387     (assert (eq :error
 388                 (handler-case
 389                     (compare-and-swap (slot-value x 'x) 0 :bar)
 390                   (error () :error))))
 391     (assert (eql 13 (slot-value x 'x)))))
 392
 393 (defvar *foo* nil)
 394
 395 (defun foo ()
 396   *foo*)
 397
 398 (defun (cas foo) (old new)
 399   (cas (symbol-value '*foo*) old new))
 400
 401 (with-test (:name (:cas :defun))
 402   (assert (null (foo)))
 403   (assert (null (cas (foo) nil t)))
 404   (assert (eq t (foo)))
 405   (assert (eq t (cas (foo) nil :oops)))
 406   (assert (eq t (foo))))
 407
 408 (with-test (:name (:cas :flet))
 409   (let (x)
 410     (flet (((cas x) (old new)
 411              (let ((tmp x))
 412                (when (eq tmp old)
 413                  (setf x new))
 414                tmp))
 415            (x ()
 416              x))
 417       (assert (null (x)))
 418       (assert (null (cas (x) nil t)))
 419       (assert (eq t (x)))
 420       (assert (eq t (cas (x) nil :oops)))
 421       (assert (eq t (x))))))
 422
 423 (defgeneric (cas thing) (old new thing))
 424
 425 (defmethod (cas thing) (old new (thing cons))
 426   (cas (car thing) old new))
 427
 428 (defmethod (cas thing) (old new (thing symbol))
 429   (cas (symbol-value thing) old new))
 430
 431 (defgeneric thing (thing)
 432   (:method ((x cons))
 433     (car x))
 434   (:method ((x symbol))
 435     (symbol-value x)))
 436
 437 (with-test (:name (:cas :defgeneric))
 438   (let ((a (list nil))
 439         (b (gensym "X")))
 440     (set b nil)
 441     (assert (null (thing a)))
 442     (assert (null (thing b)))
 443     (assert (null (cas (thing a) nil t)))
 444     (assert (null (cas (thing b) nil t)))
 445     (assert (eq t (thing a)))
 446     (assert (eq t (thing b)))
 447     (assert (eq t (cas (thing a) nil :oops)))
 448     (assert (eq t (cas (thing b) nil :oops)))
 449     (assert (eq t (thing a)))
 450     (assert (eq t (thing b)))))
 451
 452 ;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
 453 (with-test (:name :symbol-value-cas-expansion)
 454   (multiple-value-bind (vars vals old new cas-form read-form)
 455       (get-cas-expansion `(symbol-value t))
 456     (assert (not vars))
 457     (assert (not vals))
 458     (assert (eq t (eval read-form))))
 459   (multiple-value-bind (vars vals old new cas-form read-form)
 460       (get-cas-expansion `(symbol-value *))
 461     (let ((* :foo))
 462       (assert (eq :foo
 463                   (eval `(let (,@(mapcar 'list vars vals))
 464                       ,read-form)))))
 465     (let ((* :bar))
 466       (assert (eq :bar
 467                   (eval `(let (,@(mapcar 'list vars vals))
 468                       ,read-form)))))))
 469
 470 (let ((foo (cons :foo nil)))
 471   (defun cas-foo (old new)
 472     (cas (cdr foo) old new)))
 473
 474 (defcas foo () cas-foo)
 475
 476 (with-test (:name :cas-and-macroexpansion)
 477   (assert (not (cas (foo) nil t)))
 478   (assert (eq t (cas (foo) t nil)))
 479   (symbol-macrolet ((bar (foo)))
 480     (assert (not (cas bar nil :ok)))
 481     (assert (eq :ok (cas bar :ok nil)))
 482     (assert (not (cas bar nil t)))))
 483
 484 (with-test (:name :atomic-push
 485             :skipped-on '(not :sb-thread))
 486   (let ((store (cons nil nil))
 487         (n 100000))
 488     (symbol-macrolet ((x (car store))
 489                       (y (cdr store)))
 490       (dotimes (i n)
 491         (push i y))
 492       (mapc #'sb-thread:join-thread
 493             (loop repeat (ecase sb-vm:n-word-bits (32 100) (64 1000))
 494                   collect (sb-thread:make-thread
 495                            (lambda ()
 496                              (loop for z = (atomic-pop y)
 497                                    while z
 498                                    do (atomic-push z x)
 499                                       (sleep 0.00001))))))
 500       (assert (not y))
 501       (assert (eql n (length x))))))
 502
 503 (with-test (:name :local-special-symbol-value)
 504   (assert
 505    (= (funcall (compile nil
 506                         `(lambda ()
 507                            (let ((x 10))
 508                              (declare (special x))
 509                              (cas (symbol-value 'x) 10 12)
 510                              x))))
 511       12))
 512   (assert
 513    (= (funcall
 514        (compile nil
 515                 `(lambda ()
 516                    (let ((x (list 1)))
 517                      (declare (special x))
 518                      (atomic-pop (symbol-value 'x))))))
 519       1)))