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 sb-ext:most-positive-word)))
 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 (with-test (:name :atomic-push
 506             :skipped-on (not :sb-thread))
 507   (let ((store (cons nil nil))
 508         (n 100000))
 509     (symbol-macrolet ((x (car store))
 510                       (y (cdr store)))
 511       (dotimes (i n)
 512         (push i y))
 513       (mapc #'sb-thread:join-thread
 514             (loop repeat (ecase sb-vm:n-word-bits (32 100) (64 1000))
 515                   collect (sb-thread:make-thread
 516                            (lambda ()
 517                              (loop for z = (atomic-pop y)
 518                                    while z
 519                                    do (atomic-push z x)
 520                                       (sleep 0.00001))))))
 521       (assert (not y))
 522       (assert (eql n (length x))))))
 523
 524 (with-test (:name :local-special-symbol-value)
 525   (assert
 526    (= (funcall (compile nil
 527                         `(lambda ()
 528                            (let ((x 10))
 529                              (declare (special x))
 530                              (cas (symbol-value 'x) 10 12)
 531                              x))))
 532       12))
 533   (assert
 534    (= (funcall
 535        (compile nil
 536                 `(lambda ()
 537                    (let ((x (list 1)))
 538                      (declare (special x))
 539                      (atomic-pop (symbol-value 'x))))))
 540       1)))
 541
 542 (in-package "SB-VM")
 543
 544 ;;; This file defines a structure, so is an 'impure' test
 545 (defstruct my-struct
 546   ;; The slots under test have to be naturally aligned for a double-Lispword,
 547   ;; at least on x86-64, so add a random slot if there is no layout slot.
 548   #+compact-instance-header fluff
 549   one two three four)
 550
 551 (locally
 552   (declare (muffle-conditions style-warning)) ; functions don't exist for non-x86
 553   (defun test-a-cons (acons oldcar oldcdr newcar newcdr)
 554     (%cons-cas-pair acons oldcar oldcdr newcar newcdr))
 555   (defun test-a-vect (avect ind old1 old2 new1 new2)
 556     (%vector-cas-pair avect ind old1 old2 new1 new2))
 557   (defun test-a-struct (inst ind old1 old2 new1 new2)
 558     (%instance-cas-pair inst ind old1 old2 new1 new2))
 559
 560   (defun test-wide-cmpxchg ()
 561     (let ((x (cons 'a 'b)))
 562       (multiple-value-bind (old1 old2) (test-a-cons x 'a 'b 'foo 'bar)
 563         (assert (and (eq old1 'a) (eq old2 'b) (equal x '(foo . bar)))))
 564       (multiple-value-bind (old1 old2) (test-a-cons x 0 0 1 2)
 565         (assert (and (eq old1 'foo) (eq old2 'bar) (equal x '(foo . bar))))))
 566
 567     ;; This is just testing that the offsets are correct.
 568     ;; Correct working of the instruction is tested by the CONS example.
 569     (let ((x (make-array 6 :initial-element nil)))
 570       (multiple-value-bind (old1 old2) (test-a-vect x 2 nil nil 'foo 'bar)
 571         (assert (and (null old1) (null old2) (equalp x #(nil nil foo bar nil nil))))))
 572
 573     ;; Same remark applies - just check that the offset to the slot is right.
 574     (let ((s (make-my-struct :three 'the :four 'floor)))
 575       ;; in slots 3 and 4 put your bootee (a baby shoe, i.e.) on the floor
 576       (multiple-value-bind (old1 old2) (test-a-struct s 3 'the 'floor 'your 'bootee)
 577         (assert (and (eq old1 'the) (eq old2 'floor)
 578                      (eq (my-struct-three s) 'your)
 579                      (eq (my-struct-four s) 'bootee)))))
 580     t))
 581
 582 (test-util:with-test (:name :wide-compare-and-exchange
 583                       :skipped-on (not (or :x86 :x86-64)))
 584   (multiple-value-bind (a b c d) (%cpu-identification 0 0)
 585     (declare (ignore b c d))
 586     ;; paranoidly check for whether we can execute function ID 1
 587     (or (and (>= a 1) ; the highest function ID
 588              (multiple-value-bind (a b c d) (%cpu-identification 1 0)
 589                (declare (ignore a b) (ignorable c d))
 590                ;; paranoidly check for CMPXCHGxB presence
 591                ;; constants from Table 3-20 and 3-21 of Intel manual
 592                (and #+x86(logbitp 8 d) #+x86-64(logbitp 13 c)
 593                     (test-wide-cmpxchg))))
 594         (format t "Double-width compare-and-swap NOT TESTED~%"))))
 595
 596 (test-util:with-test (:name :cas-sap-ref-smoke-test
 597                             :skipped-on (not (and :sb-thread (or :ppc64 :x86-64))))
 598   (let ((data (make-array 1 :element-type 'sb-vm:word)))
 599     (sb-sys:with-pinned-objects (data)
 600       (let ((sap (sb-sys:vector-sap data)))
 601         ;; It's important to exercise an initial value that has lots of bits on,
 602         ;; because I made at least two mistakes in the x86-64 lispword-sized vop:
 603         ;;  1. it was using a :dword move where it should have used a :qword
 604         ;;  2. it was emitting constants as bignums instead of inline raw constants
 605         (macrolet ((test (signedp nbits newval
 606                           &aux (ref (symbolicate (if signedp "SIGNED-" "")
 607                                                  "SAP-REF-" nbits))
 608                                (init (if signedp -1
 609                                          (ldb (byte nbits 0) most-positive-word))))
 610                      `(progn
 611                         ;; (format t "Testing ~a with initial bits ~x~%" ',ref ,init)
 612                         (setf (,ref sap 0) ,init)
 613                         (let ((old (cas (,ref sap 0) 0 5)))
 614                           (assert (eql old ,init)) ; actual old
 615                           (assert (eql (,ref sap 0) ,init))) ; memory should not have changed
 616                         (let ((old (cas (,ref sap 0) ,init ,newval)))
 617                           (assert (eql old ,init)) ; actual old
 618                           (assert (eql (,ref sap 0) ,newval)))))) ; should have changed
 619           (test nil 64 #xdeadc0fefe00)
 620           (test t   64 most-negative-fixnum)
 621           (test nil 32 #xbabab00e)
 622           #-ppc64 (test nil 16 #xfafa) ; gets "illegal instruction" if unimplemented
 623           #-ppc64 (test nil 8 #xbb)
 624           )
 625         ;; SAP-REF-SAP
 626         (setf (aref data 0) 0)
 627         (let ((old (cas (sap-ref-sap sap 0) (int-sap 1) (int-sap #xffff))))
 628           (assert (sb-sys:sap= old (int-sap 0))) ; actual old
 629           (assert (sb-sys:sap= (sap-ref-sap sap 0) (int-sap 0)))) ; memory should not have changed
 630         (let ((old (cas (sap-ref-sap sap 0) (int-sap 0) (int-sap sb-ext:most-positive-word))))
 631           (assert (sb-sys:sap= old (int-sap 0)))
 632           (assert (sb-sys:sap= (sap-ref-sap sap 0) (int-sap sb-ext:most-positive-word))))
 633         ;; SAP-REF-LISPOBJ
 634         (setf (aref data 0) sb-vm:nil-value)
 635         (let ((old (cas (sap-ref-lispobj sap 0) t '*print-base*)))
 636           (assert (eq old nil)) ; actual old
 637           (assert (eq (sap-ref-lispobj sap 0) nil))) ; memory should not have changed
 638         (let ((old (cas (sap-ref-lispobj sap 0) nil t)))
 639           (assert (eq old nil))
 640           (assert (eq (sap-ref-lispobj sap 0) t)))))))
 641
 642 (test-util:with-test (:name :cas-sap-ref-stress-test
 643                             :skipped-on (not (and :sb-thread (or :ppc64 :x86-64))))
 644   (let ((data (make-array 1 :element-type 'sb-vm:word
 645                              :initial-element 0)))
 646     (sb-sys:with-pinned-objects (data)
 647       (let ((sap (sb-sys:vector-sap data))
 648             (n-threads 3)
 649             (n-increments 100000)
 650             (threads))
 651         (flet ((increment ()
 652                  (let ((fails 0))
 653                    (dotimes (i n-increments fails)
 654                      (let ((old (sap-ref-32 sap 0)))
 655                        (loop
 656                           (let ((actual (cas (sap-ref-32 sap 0) old (1+ old))))
 657                             (if (eq actual old) (return))
 658                             (incf fails)
 659                             (setq old actual))))))))
 660           (dotimes (i n-threads)
 661             (push (sb-thread:make-thread #'increment) threads))
 662           (mapc 'sb-thread:join-thread threads)
 663           (assert (= (sap-ref-32 sap 0) (* n-threads n-increments))))))))
 664
 665 (define-alien-variable "small_generation_limit" (signed 8))
 666 ;; PPC64 shouldn't fail, but depending on the CPU revision it might not
 667 ;; have the needed instruction, and I don't know how to test for it.
 668 ;; And surely it doesn't really depend on endian-ness, but the machine
 669 ;; that I'm testing on which is little-endian passes the test.
 670 #+(and sb-thread (or x86-64 (and ppc64 little-endian)))
 671 (progn
 672 (defun cas-an-alien-byte (x y) (cas small-generation-limit x y))
 673 (compile 'cas-an-alien-byte)
 674 (test-util:with-test (:name :cas-alien)
 675   (assert (= small-generation-limit 1))
 676   (assert (= (cas-an-alien-byte 0 5) 1))
 677   (assert (= (cas-an-alien-byte 1 6) 1))
 678   (assert (= small-generation-limit 6))
 679   (setf small-generation-limit 1)))