Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv2/atomics.lisp

KindCoveredAll%
expression037 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
2
 ;;;; The above modeline is required for Genera. Do not change.
3
 
4
 (in-package :bordeaux-threads-2)
5
 
6
 (defmacro atomic-cas (place old new)
7
   (declare (ignorable place old new))
8
   #+allegro `(excl:atomic-conditional-setf ,place ,new ,old)
9
   #+ccl `(ccl::conditional-store ,place ,old ,new)
10
   #+clasp `(mp:cas ,place ,old ,new)
11
   #+cmu (with-gensyms (tmp-old tmp-new)
12
           `(let ((,tmp-old ,old)
13
                  (,tmp-new ,new))
14
              (mp:without-scheduling ()
15
                (if (eql ,tmp-old ,place)
16
                    (progn
17
                      (setf ,place ,tmp-new)
18
                      t)
19
                    nil))))
20
   #+ecl (with-gensyms (tmp)
21
           `(let ((,tmp ,old))
22
              (eql ,tmp (mp:compare-and-swap ,place ,tmp ,new))))
23
   #+genera `(sys:store-conditional (scl:locf ,place) ,old ,new)
24
   #+lispworks `(system:compare-and-swap ,place ,old ,new)
25
   #+sbcl (with-gensyms (tmp)
26
            `(let ((,tmp ,old))
27
               (eql ,tmp (sb-ext:compare-and-swap ,place ,old ,new))))
28
   #-(or allegro ccl clasp cmu ecl genera lispworks sbcl)
29
   (signal-not-implemented 'atomic-cas))
30
 
31
 (defmacro atomic-decf (place &optional (delta 1))
32
   (declare (ignorable place delta))
33
   #+allegro `(excl:decf-atomic ,place ,delta)
34
   #+ccl `(ccl::atomic-incf-decf ,place (- ,delta))
35
   #+clasp `(mp:atomic-decf ,place ,delta)
36
   #+cmu `(mp:atomic-decf ,place ,delta)
37
   #+ecl `(- (mp:atomic-decf ,place ,delta) ,delta)
38
   #+genera `(process:atomic-decf ,place ,delta)
39
   #+lispworks `(system:atomic-decf ,place ,delta)
40
   #+sbcl `(- (sb-ext:atomic-decf ,place ,delta) ,delta)
41
   #-(or allegro ccl clasp cmu ecl genera lispworks sbcl)
42
   (signal-not-implemented 'atomic-decf))
43
 
44
 (defmacro atomic-incf (place &optional (delta 1))
45
   (declare (ignorable place delta))
46
   #+allegro `(excl:incf-atomic ,place ,delta)
47
   #+ccl `(ccl::atomic-incf-decf ,place ,delta)
48
   #+clasp `(mp:atomic-incf ,place ,delta)
49
   #+cmu `(mp:atomic-incf ,place ,delta)
50
   #+ecl `(+ (mp:atomic-incf ,place ,delta) ,delta)
51
   #+genera `(process:atomic-incf ,place ,delta)
52
   #+lispworks `(system:atomic-incf ,place ,delta)
53
   #+sbcl `(+ (sb-ext:atomic-incf ,place ,delta) ,delta)
54
   #-(or allegro ccl clasp cmu ecl genera lispworks sbcl)
55
   (signal-not-implemented 'atomic-incf))
56
 
57
 (deftype %atomic-integer-value ()
58
   #+32-bit '(unsigned-byte 32)
59
   #+64-bit '(unsigned-byte 64))
60
 
61
 (defstruct (atomic-integer
62
              (:constructor %make-atomic-integer ())
63
              #+ecl (:atomic-accessors t))
64
   "Wrapper for an UNSIGNED-BYTE that allows atomic
65
 increment, decrement and swap.
66
 The counter is a machine word: 32/64 bits depending on CPU."
67
 
68
   #+(or allegro ccl clasp ecl genera lispworks)
69
   (cell (make-array 1 :element-type t))
70
   #+(or clisp cmu sbcl)
71
   (cell 0 :type %atomic-integer-value)
72
   #+clisp
73
   (%lock (%make-lock nil) :type native-lock))
74
 
75
 (defmethod print-object ((aint atomic-integer) stream)
76
   (print-unreadable-object (aint stream :type t :identity t)
77
     (format stream "~S" (atomic-integer-value aint))))
78
 
79
 #-(or allegro ccl clasp cmu clisp ecl genera lispworks sbcl)
80
 (mark-not-implemented 'make-atomic-integer)
81
 (defun make-atomic-integer (&key (value 0))
82
   "Create an `ATOMIC-INTEGER` with initial value `VALUE`"
83
   (check-type value %atomic-integer-value)
84
   #+(or allegro ccl clasp clisp cmu ecl genera lispworks sbcl)
85
   (let ((aint (%make-atomic-integer)))
86
     (setf (atomic-integer-value aint) value)
87
     aint)
88
   #-(or allegro ccl clasp clisp cmu ecl genera lispworks sbcl)
89
   (signal-not-implemented 'make-atomic-integer))
90
 
91
 (defun atomic-integer-compare-and-swap (atomic-integer old new)
92
   "If the current value of `ATOMIC-INTEGER` is equal to `OLD`, replace
93
 it with `NEW`.
94
 
95
 Returns T if the replacement was successful, otherwise NIL."
96
   (declare (type atomic-integer atomic-integer)
97
            (type %atomic-integer-value old new)
98
            (optimize (safety 0) (speed 3)))
99
   #-clisp
100
   (atomic-cas #-(or cmu sbcl) (svref (atomic-integer-cell atomic-integer) 0)
101
               #+(or cmu sbcl) (atomic-integer-cell atomic-integer)
102
               old new)
103
   #+clisp
104
   (%with-lock ((atomic-integer-%lock atomic-integer) nil)
105
     (cond
106
       ((= old (slot-value atomic-integer 'cell))
107
        (setf (slot-value atomic-integer 'cell) new)
108
        t)
109
       (t nil))))
110
 
111
 (defun atomic-integer-decf (atomic-integer &optional (delta 1))
112
   "Decrements the value of `ATOMIC-INTEGER` by `DELTA`.
113
 
114
 Returns the new value of `ATOMIC-INTEGER`."
115
   (declare (type atomic-integer atomic-integer)
116
            (type %atomic-integer-value delta)
117
            (optimize (safety 0) (speed 3)))
118
   #-clisp
119
   (atomic-decf #-(or cmu sbcl) (svref (atomic-integer-cell atomic-integer) 0)
120
                #+(or cmu sbcl) (atomic-integer-cell atomic-integer)
121
                delta)
122
   #+clisp
123
   (%with-lock ((atomic-integer-%lock atomic-integer) nil)
124
     (decf (atomic-integer-cell atomic-integer) delta)))
125
 
126
 (defun atomic-integer-incf (atomic-integer &optional (delta 1))
127
   "Increments the value of `ATOMIC-INTEGER` by `DELTA`.
128
 
129
 Returns the new value of `ATOMIC-INTEGER`."
130
   (declare (type atomic-integer atomic-integer)
131
            (type %atomic-integer-value delta)
132
            (optimize (safety 0) (speed 3)))
133
   #-clisp
134
   (atomic-incf #-(or cmu sbcl) (svref (atomic-integer-cell atomic-integer) 0)
135
                #+(or cmu sbcl) (atomic-integer-cell atomic-integer)
136
                delta)
137
   #+clisp
138
   (%with-lock ((atomic-integer-%lock atomic-integer) nil)
139
     (incf (atomic-integer-cell atomic-integer) delta)))
140
 
141
 (defun atomic-integer-value (atomic-integer)
142
   "Returns the current value of `ATOMIC-INTEGER`."
143
   (declare (type atomic-integer atomic-integer)
144
            (optimize (safety 0) (speed 3)))
145
   #-clisp
146
   (progn
147
     #-(or cmu sbcl) (svref (atomic-integer-cell atomic-integer) 0)
148
     #+(or cmu sbcl) (atomic-integer-cell atomic-integer))
149
   #+clisp
150
   (%with-lock ((atomic-integer-%lock atomic-integer) nil)
151
     (atomic-integer-cell atomic-integer)))
152
 
153
 (defun (setf atomic-integer-value) (newval atomic-integer)
154
   (declare (type atomic-integer atomic-integer)
155
            (type %atomic-integer-value newval)
156
            (optimize (safety 0) (speed 3)))
157
   #-clisp
158
   (setf #-(or cmu sbcl) (svref (atomic-integer-cell atomic-integer) 0)
159
         #+(or cmu sbcl) (atomic-integer-cell atomic-integer)
160
         newval)
161
   #+clisp
162
   (%with-lock ((atomic-integer-%lock atomic-integer) nil)
163
     (setf (atomic-integer-cell atomic-integer) newval)))