compare-and-swap.impure.lisp

   1 ;;; Basics
   2
   3 (defstruct xxx yyy)
   4
   5 (macrolet ((test (init op)
   6              `(with-test (:name (:cas :basics ,op))
   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 (defun inc-box (box n)
 124   (declare (fixnum n) (box box))
 125   (loop repeat n
 126         do (sb-ext:atomic-incf (box-word box))))
 127
 128 (defun dec-box (box n)
 129   (declare (fixnum n) (box box))
 130   (loop repeat n
 131         do (sb-ext:atomic-decf (box-word box))))
 132
 133 (with-test (:name :atomic-incf/decf)
 134   (let ((box (make-box)))
 135     (inc-box box 10000)
 136     (assert (= 10000 (box-word box)))
 137     (dec-box box 10000)
 138     (assert (= 0 (box-word box)))))
 139
 140 (with-test (:name :atomic-incf-wraparound)
 141   (let ((box (make-box :word (1- (ash 1 sb-vm:n-word-bits)))))
 142     (sb-ext:atomic-incf (box-word box) 2)
 143     (assert (= 1 (box-word box)))))
 144
 145 (with-test (:name :atomic-decf-wraparound)
 146   (let ((box (make-box :word 0)))
 147     (sb-ext:atomic-decf (box-word box) 2)
 148     (assert (= (- (ash 1 sb-vm:n-word-bits) 2) (box-word box)))))
 149
 150 #+sb-thread
 151 (with-test (:name (:atomic-incf/decf :threads))
 152   (let* ((box (make-box))
 153          (threads (loop repeat 64
 154                         collect (sb-thread:make-thread (lambda ()
 155                                                          (inc-box box 1000)
 156                                                          (dec-box box 10000)
 157                                                          (inc-box box 10000)
 158                                                          (dec-box box 1000))
 159                                                        :name "inc/dec thread"))))
 160     (mapc #'sb-thread:join-thread threads)
 161     (assert (= 0 (box-word box)))))
 162
 163 ;;; STANDARD-INSTANCE-ACCESS, FUNCALLABLE-STANDARD-INSTANCE-ACCESS
 164
 165 (defclass sia-cas-test ()
 166   ((a :initarg :a)
 167    (b :initarg :b)))
 168
 169 (with-test (:name (:cas :standard-instance-access))
 170   (flet ((slot-loc (slot class)
 171            (sb-mop:slot-definition-location
 172             (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
 173     (let* ((class (find-class 'sia-cas-test))
 174            (instance (make-instance class :a 'a :b 'b))
 175            (a-loc (slot-loc 'a class))
 176            (b-loc (slot-loc 'b class)))
 177       (assert (eq 'a (slot-value instance 'a)))
 178       (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
 179                                        'x 'oops)))
 180       (assert (eq 'a (sb-mop:standard-instance-access instance a-loc)))
 181       (assert (eq 'a (compare-and-swap (sb-mop:standard-instance-access instance a-loc)
 182                                        'a 'a2)))
 183       (assert (eq 'a2 (sb-mop:standard-instance-access instance a-loc)))
 184       (assert (eq 'a2 (slot-value instance 'a)))
 185       (assert (eq 'b (slot-value instance 'b)))
 186       (assert (eq 'b (sb-mop:standard-instance-access instance b-loc))))))
 187
 188 (defclass fia-cas-test (sb-mop:funcallable-standard-object)
 189   ((a :initarg :a)
 190    (b :initarg :b))
 191   (:metaclass sb-mop:funcallable-standard-class))
 192
 193 (with-test (:name (:cas :standard-instance-access))
 194   (flet ((slot-loc (slot class)
 195            (sb-mop:slot-definition-location
 196             (find slot (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))))
 197     (let* ((class (find-class 'fia-cas-test))
 198            (instance (make-instance class :a 'a :b 'b))
 199            (a-loc (slot-loc 'a class))
 200            (b-loc (slot-loc 'b class)))
 201       (sb-mop:set-funcallable-instance-function instance (lambda () :ok))
 202       (eq :ok (funcall instance))
 203       (assert (eq 'a (slot-value instance 'a)))
 204       (assert (eq 'a (compare-and-swap
 205                       (sb-mop:funcallable-standard-instance-access instance a-loc)
 206                       'x 'oops)))
 207       (assert (eq 'a (sb-mop:funcallable-standard-instance-access instance a-loc)))
 208       (assert (eq 'a (compare-and-swap
 209                       (sb-mop:funcallable-standard-instance-access instance a-loc)
 210                                        'a 'a2)))
 211       (assert (eq 'a2 (sb-mop:funcallable-standard-instance-access instance a-loc)))
 212       (assert (eq 'a2 (slot-value instance 'a)))
 213       (assert (eq 'b (slot-value instance 'b)))
 214       (assert (eq 'b (sb-mop:funcallable-standard-instance-access instance b-loc))))))
 215
 216 ;;; SLOT-VALUE
 217
 218 (defclass standard-thing ()
 219   ((x :initform 42)
 220    (y)))
 221
 222 (defmethod slot-unbound ((class standard-class) (obj standard-thing) slot)
 223   (list :unbound slot))
 224
 225 (defmethod slot-missing ((class standard-class) (obj standard-thing) slot op &optional val)
 226   (list :missing slot op val))
 227
 228 (with-test (:name (:cas :slot-value :standard-object))
 229   (let ((x (make-instance 'standard-thing)))
 230     (assert (eql 42 (slot-value x 'x)))
 231     (assert (eql 42 (compare-and-swap (slot-value x 'x) 0 :foo)))
 232     (assert (eql 42 (slot-value x 'x)))
 233     (assert (eql 42 (compare-and-swap (slot-value x 'x) 42 :foo)))
 234     (assert (eql :foo (slot-value x 'x)))))
 235
 236 (with-test (:name (:cas :slot-value :slot-unbound))
 237   (let ((x (make-instance 'standard-thing)))
 238     (assert (equal '(:unbound y) (slot-value x 'y)))
 239     (assert (equal '(:unbound y) (compare-and-swap (slot-value x 'y) 0 :foo)))
 240     (assert (equal '(:unbound y) (slot-value x 'y)))
 241     (assert (eq sb-pcl:+slot-unbound+
 242                 (compare-and-swap (slot-value x 'y) sb-pcl:+slot-unbound+ :foo)))
 243     (assert (eq :foo (slot-value x 'y)))))
 244
 245 (with-test (:name (:cas :slot-value :slot-missing))
 246   (let ((x (make-instance 'standard-thing)))
 247     (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))
 248     (assert (equal '(:missing z sb-ext:cas (0 :foo)) (compare-and-swap (slot-value x 'z) 0 :foo)))
 249     (assert (equal '(:missing z slot-value nil) (slot-value x 'z)))))
 250
 251 (defclass non-standard-class (standard-class)
 252   ())
 253
 254 (defmethod sb-mop:validate-superclass ((class non-standard-class) (superclass standard-class))
 255   t)
 256
 257 (defclass non-standard-thing-0 ()
 258   ((x :initform 13))
 259   (:metaclass non-standard-class))
 260
 261 (defclass non-standard-thing-1 ()
 262   ((x :initform 13))
 263   (:metaclass non-standard-class))
 264
 265 (defclass non-standard-thing-2 ()
 266   ((x :initform 13))
 267   (:metaclass non-standard-class))
 268
 269 (defclass non-standard-thing-3 ()
 270   ((x :initform 13))
 271   (:metaclass non-standard-class))
 272
 273 (defvar *access-list* nil)
 274
 275 (defmethod sb-mop:slot-value-using-class
 276     ((class non-standard-class) (obj non-standard-thing-1) slotd)
 277   (let ((v (call-next-method)))
 278     (push :read *access-list*)
 279     v))
 280
 281 (defmethod (setf sb-mop:slot-value-using-class)
 282     (value (class non-standard-class) (obj non-standard-thing-2) slotd)
 283   (let ((v (call-next-method)))
 284     (push :write *access-list*)
 285     v))
 286
 287 (defmethod sb-mop:slot-boundp-using-class
 288     ((class non-standard-class) (obj non-standard-thing-3) slotd)
 289   (let ((v (call-next-method)))
 290     (push :boundp *access-list*)
 291     v))
 292
 293 (with-test (:name (:cas :slot-value :non-standard-object :standard-access))
 294   (let ((x (make-instance 'non-standard-thing-0)))
 295     (assert (eql 13 (slot-value x 'x)))
 296     (assert (eql 13 (compare-and-swap (slot-value x 'x) 0 :bar)))
 297     (assert (eql 13 (slot-value x 'x)))
 298     (assert (eql 13 (compare-and-swap (slot-value x 'x) 13 :bar)))
 299     (assert (eql :bar (slot-value x 'x)))))
 300
 301 (with-test (:name (:cas :slot-value :non-standard-object :slot-value-using-class))
 302   (setf *access-list* nil)
 303   (let ((x (make-instance 'non-standard-thing-1)))
 304     (declare (notinline slot-value))
 305     (assert (null *access-list*))
 306     (assert (eql 13 (slot-value x 'x)))
 307     (assert (equal '(:read) *access-list*))
 308     (assert (eq :error
 309                 (handler-case
 310                     (compare-and-swap (slot-value x 'x) 0 :bar)
 311                   (error () :error))))
 312     (assert (eql 13 (slot-value x 'x)))
 313     (assert (equal '(:read :read) *access-list*))))
 314
 315 (with-test (:name (:cas :slot-value :non-standard-object :setf-slot-value-using-class))
 316   (setf *access-list* nil)
 317   (let ((x (make-instance 'non-standard-thing-2)))
 318     (assert (equal '(:write) *access-list*))
 319     (assert (eql 13 (slot-value x 'x)))
 320     (assert (equal '(:write) *access-list*))
 321     (assert (eq :error
 322                 (handler-case
 323                     (compare-and-swap (slot-value x 'x) 0 :bar)
 324                   (error () :error))))
 325     (assert (eql 13 (slot-value x 'x)))
 326     (assert (equal '(:write) *access-list*))))
 327
 328 (with-test (:name (:cas :slot-value :non-standard-object :slot-boundp-using-class))
 329   (setf *access-list* nil)
 330   (let ((x (make-instance 'non-standard-thing-3)))
 331     (assert (equal '(:boundp) *access-list*))
 332     (assert (eql 13 (slot-value x 'x)))
 333     (assert (eq :error
 334                 (handler-case
 335                     (compare-and-swap (slot-value x 'x) 0 :bar)
 336                   (error () :error))))
 337     (assert (eql 13 (slot-value x 'x)))))
 338
 339 (defvar *foo* nil)
 340
 341 (defun foo ()
 342   *foo*)
 343
 344 (defun (cas foo) (old new)
 345   (cas (symbol-value '*foo*) old new))
 346
 347 (with-test (:name (:cas :defun))
 348   (assert (null (foo)))
 349   (assert (null (cas (foo) nil t)))
 350   (assert (eq t (foo)))
 351   (assert (eq t (cas (foo) nil :oops)))
 352   (assert (eq t (foo))))
 353
 354 (with-test (:name (:cas :flet))
 355   (let (x)
 356     (flet (((cas x) (old new)
 357              (let ((tmp x))
 358                (when (eq tmp old)
 359                  (setf x new))
 360                tmp))
 361            (x ()
 362              x))
 363       (assert (null (x)))
 364       (assert (null (cas (x) nil t)))
 365       (assert (eq t (x)))
 366       (assert (eq t (cas (x) nil :oops)))
 367       (assert (eq t (x))))))
 368
 369 (defgeneric (cas thing) (old new thing))
 370
 371 (defmethod (cas thing) (old new (thing cons))
 372   (cas (car thing) old new))
 373
 374 (defmethod (cas thing) (old new (thing symbol))
 375   (cas (symbol-value thing) old new))
 376
 377 (defgeneric thing (thing)
 378   (:method ((x cons))
 379     (car x))
 380   (:method ((x symbol))
 381     (symbol-value x)))
 382
 383 (with-test (:name (:cas :defgeneric))
 384   (let ((a (list nil))
 385         (b (gensym "X")))
 386     (set b nil)
 387     (assert (null (thing a)))
 388     (assert (null (thing b)))
 389     (assert (null (cas (thing a) nil t)))
 390     (assert (null (cas (thing b) nil t)))
 391     (assert (eq t (thing a)))
 392     (assert (eq t (thing b)))
 393     (assert (eq t (cas (thing a) nil :oops)))
 394     (assert (eq t (cas (thing b) nil :oops)))
 395     (assert (eq t (thing a)))
 396     (assert (eq t (thing b)))))
 397
 398 ;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
 399 (with-test (:name :symbol-value-cas-expansion)
 400   (multiple-value-bind (vars vals old new cas-form read-form)
 401       (get-cas-expansion `(symbol-value t))
 402     (assert (not vars))
 403     (assert (not vals))
 404     (assert (eq t (eval read-form))))
 405   (multiple-value-bind (vars vals old new cas-form read-form)
 406       (get-cas-expansion `(symbol-value *))
 407     (let ((* :foo))
 408       (assert (eq :foo
 409                   (eval `(let (,@(mapcar 'list vars vals))
 410                       ,read-form)))))
 411     (let ((* :bar))
 412       (assert (eq :bar
 413                   (eval `(let (,@(mapcar 'list vars vals))
 414                       ,read-form)))))))
 415
 416 (let ((foo (cons :foo nil)))
 417   (defun cas-foo (old new)
 418     (cas (cdr foo) old new)))
 419
 420 (defcas foo () cas-foo)
 421
 422 (with-test (:name :cas-and-macroexpansion)
 423   (assert (not (cas (foo) nil t)))
 424   (assert (eq t (cas (foo) t nil)))
 425   (symbol-macrolet ((bar (foo)))
 426     (assert (not (cas bar nil :ok)))
 427     (assert (eq :ok (cas bar :ok nil)))
 428     (assert (not (cas bar nil t)))))
 429
 430 (with-test (:name atomic-push
 431             :skipped-on '(not :sb-thread))
 432   (let ((store (cons nil nil))
 433         (n 100000))
 434     (symbol-macrolet ((x (car store))
 435                       (y (cdr store)))
 436       (dotimes (i n)
 437         (push i y))
 438       (mapc #'sb-thread:join-thread
 439             (loop repeat 1000
 440                   collect (sb-thread:make-thread
 441                            (lambda ()
 442                              (loop for z = (atomic-pop y)
 443                                    while z
 444                                    do (atomic-push z x)
 445                                       (sleep 0.00001))))))
 446       (assert (not y))
 447       (assert (eql n (length x))))))