-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathstatus.lisp
95 lines (89 loc) · 3.85 KB
/
status.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
(defpackage "STATUS"
(:use "CL" "SB-EXT" "SB-THREAD")
(:export "SLOW-STATUS" "DEFINE-STATUS-TYPE"))
(in-package "STATUS")
(defstruct (slow-status
(:constructor nil))
(status nil :type t)
(lock (make-mutex) :type mutex
:read-only t)
(cvar (make-waitqueue) :type waitqueue
:read-only t))
(defmacro define-status-type (type-name
(&key (fast-type t)
(status-type t)
(default-status '(error "Status missing"))
(constructor
(intern
(format nil "MAKE-~A"
(symbol-name type-name))))
(final-states '()))
fast-accessor
status-function
wait-function
upgrade-function)
`(progn
(defstruct (,type-name
(:constructor ,constructor)
(:include slow-status
(status ,default-status :type ,status-type))))
(defun ,status-function (value)
(declare (type ,fast-type value))
(let ((%status (,fast-accessor value)))
(if (typep %status ',type-name)
(slow-status-status %status)
%status)))
(defun ,wait-function (value &rest stopping-conditions)
(declare (type ,fast-type value))
(declare (dynamic-extent stopping-conditions))
(let (slow
slow-status)
(loop
(let ((%status (,fast-accessor value)))
(when (typep %status ',type-name)
(setf slow-status %status)
(return))
(when (member %status stopping-conditions)
(return-from ,wait-function %status))
(if slow
(setf (slow-status-status slow) %status)
(setf slow (,constructor :status %status)))
(when (eql (cas (,fast-accessor value) %status slow)
%status)
(setf slow-status slow)
(return))))
(let* ((slow-status slow-status)
(lock (slow-status-lock slow-status))
(cvar (slow-status-cvar slow-status)))
(declare (type slow-status slow-status))
(return-from ,wait-function
(with-mutex (lock)
(loop
(let ((status (slow-status-status slow-status)))
(when (member status stopping-conditions)
(return status)))
(condition-wait cvar lock)))))))
(defun ,upgrade-function (value to &rest from)
(declare (type ,fast-type value))
(declare (dynamic-extent from))
(let (slow-status)
(loop
(let ((%status (,fast-accessor value)))
(when (typep %status ',type-name)
(setf slow-status %status)
(return))
(when (or (not (member %status from))
(eql (compare-and-swap (,fast-accessor value)
%status to)
%status))
(return-from ,upgrade-function %status))))
(with-mutex ((slow-status-lock slow-status))
(let ((status (slow-status-status slow-status)))
(when (member status from)
(setf (slow-status-status slow-status) to)
(when (or ,@(mapcar (lambda (x)
`(eql to ',x))
final-states))
(setf (,fast-accessor value) to))
(condition-broadcast (slow-status-cvar slow-status)))
status))))))