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
116
117
open Picos
let[@inline never] overflow () = raise (Sys_error "overflow")
let[@inline never] negative () = invalid_arg "negative initial count"
module Counting = struct
type t = Obj.t Atomic.t
let make ?padded count =
if count < 0 then negative ();
Atomic.make (Obj.repr count) |> Multicore_magic.copy_as ?padded
let rec release t backoff =
let before = Atomic.get t in
if Obj.is_int before then begin
let count = Obj.obj before in
if count < count + 1 then begin
let after = Obj.repr (count + 1) in
if not (Atomic.compare_and_set t before after) then
release t (Backoff.once backoff)
end
else overflow ()
end
else
let after = Q.tail (Obj.obj before) in
if Atomic.compare_and_set t before (Obj.repr after) then
let trigger = Q.head (Obj.obj before) in
Trigger.signal trigger
else release t (Backoff.once backoff)
let rec cleanup t trigger backoff =
let before = Atomic.get t in
if Obj.is_int before then release t Backoff.default
else
let before = Obj.obj before in
let after = Q.remove before trigger in
if before == after then release t Backoff.default
else if not (Atomic.compare_and_set t (Obj.repr before) (Obj.repr after))
then cleanup t trigger (Backoff.once backoff)
let rec acquire t backoff =
let before = Atomic.get t in
if Obj.is_int before then
let count = Obj.obj before in
if 0 < count then begin
let after = Obj.repr (count - 1) in
if not (Atomic.compare_and_set t before after) then
acquire t (Backoff.once backoff)
end
else
let trigger = Trigger.create () in
let after = Q.singleton trigger in
if Atomic.compare_and_set t before (Obj.repr after) then begin
match Trigger.await trigger with
| None -> ()
| Some (exn, bt) ->
cleanup t trigger Backoff.default;
Printexc.raise_with_backtrace exn bt
end
else acquire t (Backoff.once backoff)
else
let trigger = Trigger.create () in
let after = Q.snoc (Obj.obj before) trigger in
if Atomic.compare_and_set t before (Obj.repr after) then begin
match Trigger.await trigger with
| None -> ()
| Some (exn, bt) ->
cleanup t trigger Backoff.default;
Printexc.raise_with_backtrace exn bt
end
else acquire t (Backoff.once backoff)
let rec try_acquire t backoff =
let before = Atomic.get t in
Obj.is_int before
&&
let count = Obj.obj before in
0 < count
&&
let after = Obj.repr (count - 1) in
Atomic.compare_and_set t before after
|| try_acquire t (Backoff.once backoff)
let get_value t =
let state = Atomic.get t in
if Obj.is_int state then Obj.obj state else 0
let[@inline] release t = release t Backoff.default
let[@inline] acquire t = acquire t Backoff.default
let[@inline] try_acquire t = try_acquire t Backoff.default
end
module Binary = struct
type t = Counting.t
let make ?padded initial = Counting.make ?padded (Bool.to_int initial)
let rec release t backoff =
let before = Atomic.get t in
if Obj.is_int before then begin
let count = Obj.obj before in
if count = 0 then
let after = Obj.repr 1 in
if not (Atomic.compare_and_set t before after) then
release t (Backoff.once backoff)
end
else
let after = Q.tail (Obj.obj before) in
if Atomic.compare_and_set t before (Obj.repr after) then
let trigger = Q.head (Obj.obj before) in
Trigger.signal trigger
else release t (Backoff.once backoff)
let acquire = Counting.acquire
let try_acquire = Counting.try_acquire
let[@inline] release t = release t Backoff.default
end