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