blob: b8dd6910a6e54652cf2061441daa35b3c7c51ed5 (
plain) (
blame)
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
|
type protocol = ..
module Error = struct
open Concepts.Condition
let unimplemented_protocol obj_name =
condition "unimplemented-protocol"
"A required protocol was not implemented by the specified object"
("object" |=| Concepts.Value.String obj_name)
end
class type obj = object
method reference : bool
method release : unit
method is_managed : bool
method hash : Concepts.Hash.hash
method to_string : string
method protocols : protocol list
end
type t = {valid: bool Atomic.t; refers_to: obj; allocated_at: Printexc.raw_backtrace}
type 'a interface = {handle: t; interface: 'a}
let object_of {valid; refers_to; _} =
if (Atomic.get valid) then refers_to else failwith "Attempt to dereference an invalid handle!"
let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">"
let invalidate {valid; _} = Atomic.compare_and_set valid true false
let release handle =
let o = object_of handle in
if invalidate handle then
o#release
let on_gc ({valid; refers_to; allocated_at} as h) =
(* TODO: get rid of this on release builds *)
if refers_to#is_managed && (Atomic.get valid) then begin
Logger.(log Warn ("Leaking handle to managed object " ^ (to_string h)));
Logger.(log Warn (BatString.nreplace
(* bleh *)
~str:(Printexc.raw_backtrace_to_string allocated_at)
~sub:"Raised by primitive operation"
~by:"Allocated"));
release h
end
type _ Effect.t += Autorelease: t -> unit Effect.t | Keep: t -> unit Effect.t
let with_autorelease f =
let hs = Atomic.make BatSet.empty in
Fun.protect
~finally:(fun () -> Atomic.get hs |> BatSet.iter release)
(fun () ->
try f ()
with
| effect (Autorelease h), k ->
Utilities.Atomic.swap hs (fun ft -> BatSet.add h ft)
|> ignore;
Effect.Deep.continue k ()
| effect (Keep h), k ->
Utilities.Atomic.swap hs (fun ft -> BatSet.remove h ft)
|> ignore;
Effect.Deep.continue k ())
let without_autorelease f =
try f ()
with
| effect (Autorelease _), k -> Effect.Deep.continue k ()
| effect (Keep _), k -> Effect.Deep.continue k ()
let keep h =
try Effect.perform (Keep h)
with Effect.Unhandled _ -> ()
let autorelease h =
try Effect.perform (Autorelease h)
with Effect.Unhandled _ -> ()
let interface_of handle interface = {handle; interface}
let make o =
let h = {valid= Atomic.make true; refers_to= (o :> obj); allocated_at= Printexc.get_callstack 256} in
Gc.finalise on_gc h;
if o#is_managed then autorelease h;
h
let into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle)
let invoke {handle; interface} f =
let _ = object_of handle in
f interface
let from {handle; _} = handle
let copy handle =
let o = object_of handle in
if o#reference then Some (make o) else None
let move handle =
let o = object_of handle in
invalidate handle |> ignore;
make o
let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash
let hash h = (object_of h)#hash
let protocols h = (object_of h)#protocols
let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
|
