From 33bc86c566b4e2418c17e063c7417beca30476ef Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 8 Oct 2026 00:09:45 +0000 Subject: A better print representation --- lib/protocols/Handle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index cdadd4a..2514a7f 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -40,7 +40,7 @@ let copy 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 to_string h = (object_of h)#to_string +let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">" let release ({valid; _} as handle) = let o = object_of handle in -- cgit v1.2.3 From b7b1c74b43dd5403d9d087845c8098b197ad0969 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 8 Oct 2026 00:09:56 +0000 Subject: Make `Handle.release` concurrency-safe --- lib/protocols/Handle.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index 2514a7f..add2e1c 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -17,14 +17,14 @@ class type obj = object method protocols : protocol list end -type t = {valid: bool ref; refers_to: obj} +type t = {valid: bool Atomic.t; refers_to: obj} type 'a interface = {handle: t; interface: 'a} let object_of {valid; refers_to} = - if !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 interface_of handle interface = {handle; interface} -let make o = {valid= ref true; refers_to= (o :> obj)} +let make o = {valid= Atomic.make true; refers_to= (o :> obj)} let into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle) let invoke {handle; interface} f = @@ -44,7 +44,7 @@ let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts. let release ({valid; _} as handle) = let o = object_of handle in - valid := false; - o#release + if Atomic.compare_and_set valid true false then + o#release let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h) -- cgit v1.2.3 From 0354a7c21cae08cda07864dcb70a76d37fe43375 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 8 Oct 2026 00:54:55 +0000 Subject: Log whenever managed objects are garbage collected --- lib/protocols/Handle.ml | 25 +++++++++++++++++++++---- lib/protocols/Handle.mli | 1 + 2 files changed, 22 insertions(+), 4 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index add2e1c..9ded873 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -12,19 +12,37 @@ 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} +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} = +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 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")) + end + let interface_of handle interface = {handle; interface} -let make o = {valid= Atomic.make true; refers_to= (o :> obj)} +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 into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle) let invoke {handle; interface} f = @@ -40,7 +58,6 @@ let copy 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 to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">" let release ({valid; _} as handle) = let o = object_of handle in diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index a354257..f413aac 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -5,6 +5,7 @@ type protocol = .. 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 -- cgit v1.2.3 From 290be60cf34ef2550a8cb9aa447c232445cd1476 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 8 Oct 2026 02:13:00 +0000 Subject: Autorelease pools --- lib/protocols/Handle.ml | 29 ++++++++++++++++++++++++----- lib/protocols/Handle.mli | 1 + 2 files changed, 25 insertions(+), 5 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index 9ded873..7f7fe95 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -37,10 +37,34 @@ let on_gc ({valid; refers_to; allocated_at} as h) = ~by:"Allocated")) end +let release ({valid; _} as handle) = + let o = object_of handle in + if Atomic.compare_and_set valid true false then + o#release + +type _ Effect.t += Autorelease: t -> unit Effect.t + +let with_autorelease f = + let hs = Atomic.make BatFingerTree.empty in + Fun.protect + ~finally:(fun () -> Atomic.get hs |> BatFingerTree.iter release) + (fun () -> + try f () + with + | effect (Autorelease h), k -> + Utilities.Atomic.swap hs (fun ft -> BatFingerTree.snoc ft h) + |> ignore; + Effect.Deep.continue k ()) + +let autorelease h = + try Effect.perform (Autorelease h) + with _ -> () + 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) @@ -59,9 +83,4 @@ let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#h let hash h = (object_of h)#hash let protocols h = (object_of h)#protocols -let release ({valid; _} as handle) = - let o = object_of handle in - if Atomic.compare_and_set valid true false then - o#release - let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h) diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index f413aac..7b0a996 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -22,3 +22,4 @@ val hash : t -> Concepts.Hash.hash val protocols : t -> protocol list val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result +val with_autorelease : (unit -> 'a) -> 'a -- cgit v1.2.3 From ecd778d5d92dc7cd0b57b9eb78b509ab851f3474 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 00:32:21 +0000 Subject: The finalizer should also release the handle --- lib/protocols/Handle.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index 7f7fe95..fc226c0 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -26,6 +26,11 @@ let object_of {valid; refers_to; _} = let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">" +let release ({valid; _} as handle) = + let o = object_of handle in + if Atomic.compare_and_set valid true false 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 @@ -34,14 +39,10 @@ let on_gc ({valid; refers_to; allocated_at} as h) = (* bleh *) ~str:(Printexc.raw_backtrace_to_string allocated_at) ~sub:"Raised by primitive operation" - ~by:"Allocated")) + ~by:"Allocated")); + release h end -let release ({valid; _} as handle) = - let o = object_of handle in - if Atomic.compare_and_set valid true false then - o#release - type _ Effect.t += Autorelease: t -> unit Effect.t let with_autorelease f = -- cgit v1.2.3 From bd152dc4311a117f125916e1f75cb5ce02752630 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 00:32:41 +0000 Subject: `without_autorelease`, `keep` --- lib/protocols/Handle.ml | 24 +++++++++++++++++++----- lib/protocols/Handle.mli | 2 ++ 2 files changed, 21 insertions(+), 5 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index fc226c0..6f7ca43 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -43,23 +43,37 @@ let on_gc ({valid; refers_to; allocated_at} as h) = release h end -type _ Effect.t += Autorelease: t -> unit Effect.t +type _ Effect.t += Autorelease: t -> unit Effect.t | Keep: t -> unit Effect.t let with_autorelease f = - let hs = Atomic.make BatFingerTree.empty in + let hs = Atomic.make BatSet.empty in Fun.protect - ~finally:(fun () -> Atomic.get hs |> BatFingerTree.iter release) + ~finally:(fun () -> Atomic.get hs |> BatSet.iter release) (fun () -> try f () with | effect (Autorelease h), k -> - Utilities.Atomic.swap hs (fun ft -> BatFingerTree.snoc ft h) + 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 _ -> () + with Effect.Unhandled _ -> () let interface_of handle interface = {handle; interface} let make o = diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index 7b0a996..f1a9609 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -23,3 +23,5 @@ val protocols : t -> protocol list val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result val with_autorelease : (unit -> 'a) -> 'a +val without_autorelease : (unit -> 'a) -> 'a +val keep : t -> unit -- cgit v1.2.3 From 9be5137143177492e82dc25e6dbd3b82e3aa7e5d Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 01:09:17 +0000 Subject: Make namespaces take ownership of the handles it is given --- lib/protocols/Handle.ml | 11 +++++++++-- lib/protocols/Handle.mli | 2 ++ 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index 6f7ca43..b8dd691 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -26,9 +26,11 @@ let object_of {valid; refers_to; _} = let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">" -let release ({valid; _} as handle) = +let invalidate {valid; _} = Atomic.compare_and_set valid true false + +let release handle = let o = object_of handle in - if Atomic.compare_and_set valid true false then + if invalidate handle then o#release let on_gc ({valid; refers_to; allocated_at} as h) = @@ -94,6 +96,11 @@ 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 diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index f1a9609..47cee38 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -16,6 +16,7 @@ val into : t -> (protocol -> 'a option) -> 'a interface option val from : 'a interface -> t val invoke : 'a interface -> ('a -> 'b) -> 'b val copy : t -> t option +val move : t -> t val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash @@ -24,4 +25,5 @@ val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result val with_autorelease : (unit -> 'a) -> 'a val without_autorelease : (unit -> 'a) -> 'a +val autorelease : t -> unit val keep : t -> unit -- cgit v1.2.3 From 6201bbc6e7171f037467bbfc2d0a6da084fb516c Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 02:14:55 +0000 Subject: Make the autorelease pool opt-in --- lib/protocols/Handle.ml | 15 ++------------- lib/protocols/Handle.mli | 5 ++--- 2 files changed, 4 insertions(+), 16 deletions(-) (limited to 'lib/protocols') diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index b8dd691..eea7db2 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -63,25 +63,14 @@ let with_autorelease f = |> 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 = Effect.perform (Keep h); h -let keep h = - try Effect.perform (Keep h) - with Effect.Unhandled _ -> () - -let autorelease h = - try Effect.perform (Autorelease h) - with Effect.Unhandled _ -> () +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; - 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) diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index 47cee38..1c3b9d4 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -24,6 +24,5 @@ val protocols : t -> protocol list val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result val with_autorelease : (unit -> 'a) -> 'a -val without_autorelease : (unit -> 'a) -> 'a -val autorelease : t -> unit -val keep : t -> unit +val autorelease : t -> t +val keep : t -> t -- cgit v1.2.3 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') 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