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
include Intf
let[@inline never] created () =
invalid_arg "resource already previously created"
let[@inline never] disposed () =
invalid_arg "resource already previously disposed"
let bt =
if Printexc.backtrace_status () then None else Some (Printexc.get_callstack 0)
let count_shift = 2
let count_1 = 1 lsl count_shift
let dispose_bit = 0b01
let closed_bit = 0b10
module Make (Resource : Resource) () : S with module Resource = Resource =
struct
module Resource = Resource
type entry = { count_and_bits : int; bt : Printexc.raw_backtrace }
let ht = Picos_htbl.create ~hashed_type:(module Resource) ()
type t = Resource.t
let create ?(dispose = true) t =
let bt =
match bt with Some bt -> bt | None -> Printexc.get_callstack 15
in
if
Picos_htbl.try_add ht t
(Atomic.make { count_and_bits = count_1 lor Bool.to_int dispose; bt })
then t
else begin
created ()
end
let unsafe_get = Fun.id
let rec incr t entry backoff =
let before = Atomic.get entry in
if
before.count_and_bits < count_1
|| before.count_and_bits land closed_bit <> 0
then disposed ()
else
let count_and_bits = before.count_and_bits + count_1 in
let after = { before with count_and_bits } in
if not (Atomic.compare_and_set entry before after) then
incr t entry (Backoff.once backoff)
let incr t =
match Picos_htbl.find_exn ht t with
| exception Not_found -> disposed ()
| entry -> incr t entry Backoff.default
let rec decr closed_bit t entry backoff =
let before = Atomic.get entry in
let count_and_bits = (before.count_and_bits - count_1) lor closed_bit in
if count_and_bits < 0 then disposed ()
else
let after = { before with count_and_bits } in
if not (Atomic.compare_and_set entry before after) then
decr closed_bit t entry (Backoff.once backoff)
else if count_and_bits < count_1 then begin
Picos_htbl.try_remove ht t |> ignore;
if after.count_and_bits land dispose_bit <> 0 then Resource.dispose t
end
let decr ?close t =
match Picos_htbl.find_exn ht t with
| exception Not_found -> disposed ()
| entry ->
decr
(match close with None | Some false -> 0 | Some true -> closed_bit)
t entry Backoff.default
type info = {
resource : Resource.t;
count : int;
closed : bool;
dispose : bool;
bt : Printexc.raw_backtrace;
}
let infos () =
Picos_htbl.to_seq ht
|> Seq.map @@ fun (resource, entry) ->
let { count_and_bits; bt } = Atomic.get entry in
let count = count_and_bits lsr count_shift in
let closed = count_and_bits land closed_bit <> 0 in
let dispose = count_and_bits land dispose_bit <> 0 in
{ resource; count; closed; dispose; bt }
end