-
Notifications
You must be signed in to change notification settings - Fork 0
/
thread.lisp
86 lines (65 loc) · 2.37 KB
/
thread.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
(in-package :nunumo)
(defclass cas-lock-mixin ()
((cas-lock :initform nil)))
(defmacro with-cas-lock ((cas-lock-mixin) &body body)
`(sb-thread::with-cas-lock ((slot-value ,cas-lock-mixin 'cas-lock))
,@body))
(defun make-spinlock ()
(cons nil nil))
(defun lock-spinlock (spinlock)
(loop while (sb-ext:compare-and-swap (car spinlock) nil t)))
(defun unlock-spinlock (spinlock)
(setf (car spinlock) nil))
(defmacro with-spinlock ((spinlock) &body body)
(alexandria:once-only (spinlock)
`(progn
(lock-spinlock ,spinlock)
(unwind-protect
(progn ,@body)
(unlock-spinlock ,spinlock)))))
(defun make-recursive-spinlock ()
(cons nil 0))
(defun lock-recursive-spinlock (recursive-spinlock)
(loop for ret = (sb-ext:compare-and-swap (car recursive-spinlock) nil sb-thread:*current-thread*)
until (or (null ret) (eq ret sb-thread:*current-thread*))
finally (incf (cdr recursive-spinlock))))
(defun unlock-recursive-spinlock (recursive-spinlock)
(when (zerop (decf (cdr recursive-spinlock)))
(setf (car recursive-spinlock) nil)))
(defmacro with-recursive-spinlock ((recursive-spinlock) &body body)
(alexandria:once-only (recursive-spinlock)
`(progn
(lock-recursive-spinlock ,recursive-spinlock)
(unwind-protect
(progn ,@body)
(unlock-recursive-spinlock ,recursive-spinlock)))))
(defstruct rw-lock
(mutex (bordeaux-threads:make-lock))
(read-count 0)
(write-lock nil))
(defun read-lock (rw-lock)
(loop
(bordeaux-threads:with-lock-held ((rw-lock-mutex rw-lock))
(unless (rw-lock-write-lock rw-lock)
(incf (rw-lock-read-count rw-lock))
(return-from read-lock)))
(bordeaux-threads:thread-yield)))
(defun write-lock (rw-lock)
(loop
(bordeaux-threads:with-lock-held ((rw-lock-mutex rw-lock))
(unless (and (zerop (rw-lock-read-count rw-lock))
(null (rw-lock-write-lock rw-lock)))
(setf (rw-lock-write-lock rw-lock) t)
(return)))
(bordeaux-threads:thread-yield)))
(defun rw-unlock (rw-lock)
(bordeaux-threads:with-lock-held ((rw-lock-mutex rw-lock))
(aif (rw-lock-write-lock rw-lock)
(setf it nil)
(decf (rw-lock-read-count rw-lock)))))
(defun make-lock ()
(sb-thread:make-mutex))
(defun lock (lock)
(sb-thread:grab-mutex lock :waitp t))
(defun unlock (lock)
(sb-thread:release-mutex lock))