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