tests/compare-and-swap.impure.lisp

   1 ;;; Basics
   2
   3 (defstruct xxx yyy)
   4
   5 (macrolet ((test (init op)
   6              `(let ((x ,init)
   7                     (y (list 'foo))
   8                     (z (list 'bar)))
   9                 (assert (eql nil (compare-and-swap (,op x) nil y)))
  10                 (assert (eql y (compare-and-swap (,op x) nil z)))
  11                 (assert (eql y (,op x)))
  12                 (let ((x "foo"))
  13                   (multiple-value-bind (res err)
  14                      (ignore-errors (compare-and-swap (,op x) nil nil))
  15                     (assert (not res))
  16                     (assert (typep err 'type-error)))))))
  17   (test (cons nil :no) car)
  18   (test (cons nil :no) first)
  19   (test (cons :no nil) cdr)
  20   (test (cons :no nil) rest)
  21   (test '.foo. symbol-plist)
  22   (test (progn (set '.bar. nil) '.bar.) symbol-value)
  23   (test (make-xxx) xxx-yyy))
  24
  25 (defvar *foo*)
  26
  27 ;;; thread-local bindings
  28
  29 (let ((*foo* 42))
  30   (let ((*foo* nil))
  31     (assert (eql nil (compare-and-swap (symbol-value '*foo*) nil t)))
  32     (assert (eql t (compare-and-swap (symbol-value '*foo*) nil :foo)))
  33     (assert (eql t *foo*)))
  34   (assert (eql 42 *foo*)))
  35
  36 ;;; unbound symbols + symbol-value
  37
  38 (assert (not (boundp '*foo*)))
  39
  40 (multiple-value-bind (res err)
  41     (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
  42   (assert (not res))
  43   (assert (typep err 'unbound-variable)))
  44
  45 (defvar *bar* t)
  46
  47 (let ((*bar* nil))
  48    (makunbound '*bar*)
  49    (multiple-value-bind (res err)
  50        (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
  51      (assert (not res))
  52      (assert (typep err 'unbound-variable))))
  53
  54 ;;; SVREF
  55
  56 (defvar *v* (vector 1))
  57
  58 ;; basics
  59 (assert (eql 1 (compare-and-swap (svref *v* 0) 1 2)))
  60 (assert (eql 2 (compare-and-swap (svref *v* 0) 1 3)))
  61 (assert (eql 2 (svref *v* 0)))
  62
  63 ;; bounds
  64 (multiple-value-bind (res err)
  65     (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
  66   (assert (not res))
  67   (assert (typep err 'type-error)))
  68 (multiple-value-bind (res err)
  69     (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
  70   (assert (not res))
  71   (assert (typep err 'type-error)))
  72
  73 ;; type of the first argument
  74 (multiple-value-bind (res err)
  75     (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
  76     (assert (not res))
  77     (assert (typep err 'type-error)))
  78
  79 ;; Check that we don't modify constants
  80 (defconstant +a-constant+ 42)
  81 (assert
  82  (eq :error
  83      (handler-case
  84          (sb-ext:compare-and-swap (symbol-value '+a-constant+) 42 13)
  85        (error () :error))))
  86 (let ((name '+a-constant+))
  87   (assert
  88    (eq :error
  89        (handler-case
  90            (sb-ext:compare-and-swap (symbol-value name) 42 13)
  91          (error () :error)))))
  92
  93 ;; Check that we don't mess declaimed types
  94 (declaim (boolean *a-boolean*))
  95 (defparameter *a-boolean* t)
  96 (assert
  97  (eq :error
  98      (handler-case
  99          (sb-ext:compare-and-swap (symbol-value '*a-boolean*) t 42)
 100        (error () :error))))
 101 (let ((name '*a-boolean*))
 102   (assert
 103    (eq :error
 104        (handler-case
 105            (sb-ext:compare-and-swap (symbol-value name) t 42)
 106          (error () :error)))))
 107
 108 ;;;; ATOMIC-INCF and ATOMIC-DECF (we should probably rename this file atomic-ops...)
 109
 110 (defstruct box
 111   (word 0 :type sb-vm:word))
 112
 113 (defun inc-box (box n)
 114   (declare (fixnum n) (box box))
 115   (loop repeat n
 116         do (sb-ext:atomic-incf (box-word box))))
 117
 118 (defun dec-box (box n)
 119   (declare (fixnum n) (box box))
 120   (loop repeat n
 121         do (sb-ext:atomic-decf (box-word box))))
 122
 123 (let ((box (make-box)))
 124   (inc-box box 10000)
 125   (assert (= 10000 (box-word box)))
 126   (dec-box box 10000)
 127   (assert (= 0 (box-word box))))
 128
 129 (with-test (:name :atomic-incf-wraparound)
 130   (let ((box (make-box :word (1- (ash 1 sb-vm:n-word-bits)))))
 131     (sb-ext:atomic-incf (box-word box) 2)
 132     (assert (= 1 (box-word box)))))
 133
 134 (with-test (:name :atomic-decf-wraparound)
 135   (let ((box (make-box :word 0)))
 136     (sb-ext:atomic-decf (box-word box) 2)
 137     (assert (= (- (ash 1 sb-vm:n-word-bits) 2) (box-word box)))))
 138
 139 #+sb-thread
 140 (let* ((box (make-box))
 141        (threads (loop repeat 64
 142                       collect (sb-thread:make-thread (lambda ()
 143                                                        (inc-box box 1000)
 144                                                        (dec-box box 10000)
 145                                                        (inc-box box 10000)
 146                                                        (dec-box box 1000))
 147                                                      :name "inc/dec thread"))))
 148   (mapc #'sb-thread:join-thread threads)
 149   (assert (= 0 (box-word box))))