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/kernel/Lifecycle.ml | 4 ++++ lib/kernel/Lifecycle.mli | 1 + 2 files changed, 5 insertions(+) (limited to 'lib/kernel') diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml index ac6bb20..4fb12b9 100644 --- a/lib/kernel/Lifecycle.ml +++ b/lib/kernel/Lifecycle.ml @@ -1,6 +1,7 @@ class type lifecycle = object method reference : bool method release : unit + method is_managed : bool end class type virtual controlled_lifecycle = object @@ -12,6 +13,7 @@ class null = object method reference = true method release = () + method is_managed = false end class exclusive = @@ -19,6 +21,7 @@ class exclusive = val taken = Atomic.make false method reference = Atomic.compare_and_set taken false true method release = Atomic.set taken false + method is_managed = true end class virtual counted = @@ -27,6 +30,7 @@ class virtual counted = method virtual destroy : unit method reference = Atomic.incr references; true method release = if Atomic.fetch_and_add references (-1) = 1 then self#destroy + method is_managed = true end class retaining inner (owner : lifecycle) = diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli index d4ef178..a323197 100644 --- a/lib/kernel/Lifecycle.mli +++ b/lib/kernel/Lifecycle.mli @@ -1,6 +1,7 @@ class type lifecycle = object method reference : bool method release : unit + method is_managed : bool end class type virtual controlled_lifecycle = object -- cgit v1.2.3 From ce31009e697830314591ffa4760da9705fc7982a Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 8 Oct 2026 01:15:43 +0000 Subject: Objects with a null lifecycle should not have a destructor --- lib/kernel/Generator.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml index 272bb86..b83de3b 100644 --- a/lib/kernel/Generator.ml +++ b/lib/kernel/Generator.ml @@ -12,7 +12,7 @@ let resume k = Effect.Deep.continue k () class producer_cursor produce finally = object (self) - inherit Lifecycle.null + inherit Lifecycle.counted inherit Identity.of_id method to_string = "producer-cursor" val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh @@ -49,7 +49,7 @@ class producer_cursor produce finally = if limit <= 0 then Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= state = `Done} else fill 0 BatFingerTree.empty - method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> () + method destroy = match state with `Fresh | `Live _ -> self#finish | `Done -> () end let cursor_of ?finally produce = new producer_cursor produce finally |> Protocols.Handle.make -- 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/kernel/Namespace.ml | 15 ++++++++++----- lib/kernel/Namespace.mli | 2 ++ 2 files changed, 12 insertions(+), 5 deletions(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml index 340e813..c7cc627 100644 --- a/lib/kernel/Namespace.ml +++ b/lib/kernel/Namespace.ml @@ -1,18 +1,23 @@ class namespace = object (self) - inherit Lifecycle.null + inherit Lifecycle.counted inherit Identity.of_id method to_string = "namespace" val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = Atomic.make BatMap.empty method protocols = Protocols.[Directory.make self; Registry.make self] + method destroy = Atomic.get entries |> BatMap.values |> BatEnum.iter Protocols.Handle.release + method update key reference value = match Utilities.Atomic.mswap entries (fun e -> - if BatMap.find_opt key e = reference then - match value with - | Some v -> Ok (BatMap.add key v e) - | None -> Ok (BatMap.remove key e) + let existing = BatMap.find_opt key e in + if existing = reference then begin + Option.map Protocols.Handle.release existing |> ignore; + match value with + | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e) + | None -> Ok (BatMap.remove key e) + end else Error () ) with | Ok _ -> Ok true diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli index ec77724..9d4f343 100644 --- a/lib/kernel/Namespace.mli +++ b/lib/kernel/Namespace.mli @@ -2,6 +2,8 @@ class namespace : object inherit Protocols.Handle.obj inherit Protocols.Directory.implementation inherit Protocols.Registry.implementation + + method destroy : unit end val make : unit -> Protocols.Handle.t -- cgit v1.2.3 From 2f786a514b54cf4f72eacb6578a11b20a5069aac Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 01:09:42 +0000 Subject: Make sessions counted, rather than exclusive --- lib/kernel/Session.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml index 1abd278..0f5f353 100644 --- a/lib/kernel/Session.ml +++ b/lib/kernel/Session.ml @@ -4,7 +4,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct class session storage state = object (self) - inherit Lifecycle.exclusive + inherit Lifecycle.counted inherit Identity.of_id method to_string = "session" val storage : S.connection = storage @@ -14,6 +14,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct method protocols = Protocols.[Directory.make self; Session.make self] method list = Ok (BatFingerTree.singleton "branch") + method destroy = () + method find = function | "branch" -> -- cgit v1.2.3 From c19a5169c5fcbfba5546f49d6d4d0b0e29d40e3a Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 10 Oct 2026 01:56:59 +0000 Subject: Use an autorelease pool when walking down a path --- lib/kernel/Path.ml | 33 ++++++++++++++------------------- 1 file changed, 14 insertions(+), 19 deletions(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index eeef396..8822d44 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -20,11 +20,13 @@ module Error = struct end let walking f g handle path = + let open Protocols in let rec walk handle = function - | [] -> g handle + | [] -> + Handle.keep handle; + g handle | x :: xs -> ( let open Utilities.Result in - let open Protocols in let* dir = Handle.require Directory.from handle |> Result.map_error @@ -35,26 +37,20 @@ let walking f g handle path = | None -> Error (Error.path_not_found path) | Some elem -> f x handle (fun () -> walk elem xs) ) in - walk handle path - |> Result.map_error - Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) - -(* Handles we find in the middle of a walk get released once we're - done with them, but never the caller's root. If you leak one and - its refcount never drops, nothing under that path gets collected, - and an exclusive object, like a session, stays locked forever. *) -let releasing root handle f = - Fun.protect ~finally:(fun () -> if handle != root then Protocols.Handle.release handle) f + Handle.with_autorelease + (fun () -> + walk handle path + |> Result.map_error + Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))) -let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path +let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path let update handle path key reference value = let open Utilities.Result in let open Protocols in let* target = lookup handle path in - releasing handle target (fun () -> - let* registry = Handle.require Registry.from target in - Registry.update registry key reference value ) + let* registry = Handle.require Registry.from target in + Registry.update registry key reference value let assoc handle path key value = let open Utilities.Result in @@ -66,7 +62,6 @@ let assoc handle path key value = Ok (Handle.from a') in walking - (fun key dir f -> - releasing handle dir (fun () -> f () |> fmap (assoc_on dir key |.| Option.some)) ) - (fun h -> releasing handle h (fun () -> assoc_on h key value)) + (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some)) + (fun h -> assoc_on h key value) handle path -- 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/kernel/Path.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index 8822d44..a2e270e 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -21,18 +21,17 @@ end let walking f g handle path = let open Protocols in + let open Utilities.Result in let rec walk handle = function | [] -> - Handle.keep handle; - g handle + g (Handle.keep handle) | x :: xs -> ( - let open Utilities.Result in let* dir = Handle.require Directory.from handle |> Result.map_error Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x)) in - let* elem = Directory.find dir x in + let* elem = Directory.find dir x |> Result.map (Option.map Handle.autorelease) in match elem with | None -> Error (Error.path_not_found path) | Some elem -> f x handle (fun () -> walk elem xs) ) -- 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/kernel/Namespace.ml | 11 +++++------ lib/kernel/Namespace.mli | 1 - lib/kernel/Path.ml | 8 +++----- lib/kernel/Session.ml | 1 - 4 files changed, 8 insertions(+), 13 deletions(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml index c7cc627..c7c0767 100644 --- a/lib/kernel/Namespace.ml +++ b/lib/kernel/Namespace.ml @@ -5,7 +5,6 @@ class namespace = method to_string = "namespace" val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = Atomic.make BatMap.empty method protocols = Protocols.[Directory.make self; Registry.make self] - method destroy = Atomic.get entries |> BatMap.values |> BatEnum.iter Protocols.Handle.release method update key reference value = @@ -13,11 +12,11 @@ class namespace = Utilities.Atomic.mswap entries (fun e -> let existing = BatMap.find_opt key e in if existing = reference then begin - Option.map Protocols.Handle.release existing |> ignore; - match value with - | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e) - | None -> Ok (BatMap.remove key e) - end + Option.map Protocols.Handle.release existing |> ignore; + match value with + | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e) + | None -> Ok (BatMap.remove key e) + end else Error () ) with | Ok _ -> Ok true diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli index 9d4f343..394e44a 100644 --- a/lib/kernel/Namespace.mli +++ b/lib/kernel/Namespace.mli @@ -2,7 +2,6 @@ class namespace : object inherit Protocols.Handle.obj inherit Protocols.Directory.implementation inherit Protocols.Registry.implementation - method destroy : unit end diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index a2e270e..2e712cc 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -23,8 +23,7 @@ let walking f g handle path = let open Protocols in let open Utilities.Result in let rec walk handle = function - | [] -> - g (Handle.keep handle) + | [] -> g (Handle.keep handle) | x :: xs -> ( let* dir = Handle.require Directory.from handle @@ -36,11 +35,10 @@ let walking f g handle path = | None -> Error (Error.path_not_found path) | Some elem -> f x handle (fun () -> walk elem xs) ) in - Handle.with_autorelease - (fun () -> + Handle.with_autorelease (fun () -> walk handle path |> Result.map_error - Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))) + Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) ) let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml index 0f5f353..231f518 100644 --- a/lib/kernel/Session.ml +++ b/lib/kernel/Session.ml @@ -13,7 +13,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct method pin state' = Atomic.set state state' method protocols = Protocols.[Directory.make self; Session.make self] method list = Ok (BatFingerTree.singleton "branch") - method destroy = () method find = -- cgit v1.2.3