forked from Shinmera/atomics
/
atomics.lisp
115 lines (104 loc) · 3.29 KB
/
atomics.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
#|
This file is a part of Atomics
(c) 2019 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(defpackage #:atomics
(:nicknames #:org.shirakumo.atomics)
(:use #:cl)
(:shadow #:defstruct)
(:export
#:implementation-not-supported
#:operation
#:cas
#:atomic-incf
#:atomic-decf
#:atomic-update
#:defstruct))
(in-package #:org.shirakumo.atomics)
(define-condition implementation-not-supported (error)
((operation :initarg :operation :initform NIL :reader operation))
(:report (lambda (c s) (format s "~
~:[~a is not supported by the Atomics library.~;
~:*The ~a operation is not supported by ~a in Atomics.~]
This is most likely due to lack of support by the implementation.
If you think this is in error, and the implementation does expose
the necessary operators, please file an issue at
https://github.com/shinmera/atomics/issues"
(operation c)
(lisp-implementation-type)))))
(defun no-support (&optional operation)
(error 'implementation-not-supported :operation operation))
#-(or allegro ccl clasp ecl lispworks sbcl)
(no-support)
(defmacro cas (place old new)
#+allegro
`(if (excl:atomic-conditional-setf ,place ,new ,old) T NIL)
#+ccl
`(ccl::conditional-store ,place ,old ,new)
#+clasp
(let ((tmp (gensym "OLD")))
`(let ((,tmp ,old)) (eq ,tmp (mp:cas ,place ,tmp ,new))))
#+ecl
(let ((tmp (gensym "OLD")))
`(let ((,tmp ,old)) (eq ,tmp (mp:compare-and-swap ,place ,tmp ,new))))
#+lispworks
`(system:compare-and-swap ,place ,old ,new)
#+sbcl
(let ((tmp (gensym "OLD")))
`(let ((,tmp ,old)) (eq ,tmp (sb-ext:cas ,place ,tmp ,new))))
#-(or allegro ccl clasp ecl lispworks sbcl)
(no-support 'CAS))
(defmacro atomic-incf (place &optional (delta 1))
#+allegro
`(excl:incf-atomic ,place ,delta)
#+ccl
`(ccl::atomic-incf-decf ,place ,delta)
#+clasp
`(mp:atomic-incf ,place ,delta)
#+ecl
`(+ (mp:atomic-incf ,place ,delta) ,delta)
#+lispworks
`(system:atomic-incf ,place ,delta)
#+sbcl
`(+ (sb-ext:atomic-incf ,place ,delta) ,delta)
#-(or allegro ccl clasp ecl lispworks sbcl)
(no-support 'atomic-incf))
(defmacro atomic-decf (place &optional (delta 1))
#+allegro
`(excl:decf-atomic ,place ,delta)
#+ccl
`(ccl::atomic-incf-decf ,place (- ,delta))
#+clasp
`(mp:atomic-decf ,place ,delta)
#+ecl
`(- (mp:atomic-decf ,place ,delta) ,delta)
#+lispworks
`(system:atomic-decf ,place ,delta)
#+sbcl
`(- (sb-ext:atomic-decf ,place ,delta) ,delta)
#-(or allegro ccl clasp ecl lispworks sbcl)
(no-support 'atomic-decf))
(defmacro atomic-update (place update-fn)
#+allegro
(let ((value (gensym "VALUE")))
`(excl:update-atomic (,value ,place) (funcall ,update-fn ,value)))
#+clasp
`(mp:atomic-update ,place ,update-fn)
#+ecl
`(mp:atomic-update ,place ,update-fn)
#+sbcl
`(sb-ext:atomic-update ,place ,update-fn)
#-(or allegro clasp ecl sbcl)
(let ((old (gensym "OLD"))
(new (gensym "NEW")))
`(loop for ,old = ,place
for ,new = (funcall ,update-fn ,old)
until (cas ,place ,old ,new))))
(defmacro defstruct (name &rest slots)
#+ecl
`(cl:defstruct (,@(if (listp name) name (list name))
:atomic-accessors)
,@slots)
#-ecl
`(cl:defstruct ,name ,@slots))