From 90e41279094c26e6fcc93966708374b8ceba80e4 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 02:17:58 +0000 Subject: Style --- lib/protocols/Handle.ml | 59 +++++++++++++++++++++++-------------------------- 1 file changed, 28 insertions(+), 31 deletions(-) (limited to 'lib/protocols/Handle.ml') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index eea7db2..dd923c6 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -22,56 +22,54 @@ type t = {valid: bool Atomic.t; refers_to: obj; allocated_at: Printexc.raw_backt 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!" + 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 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 + 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 + 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 ()) + 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 keep h = Effect.perform (Keep h); h - let autorelease h = Effect.perform (Autorelease h); h - 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; - h + let h = + {valid= Atomic.make true; refers_to= (o :> obj); allocated_at= Printexc.get_callstack 256} + in + Gc.finalise on_gc h; h let into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle) @@ -93,5 +91,4 @@ let move handle = 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) -- cgit v1.2.3