From 33bc86c566b4e2418c17e063c7417beca30476ef Mon Sep 17 00:00:00 2001
From: Estevan Castilho <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
Date: Thu, 8 Oct 2026 00:54:55 +0000
Subject: Log whenever managed objects are garbage collected

---
 lib/Logger.ml            | 29 +++++++++++++++++++++++++++++
 lib/Logger.mli           |  3 +++
 lib/kernel/Lifecycle.ml  |  4 ++++
 lib/kernel/Lifecycle.mli |  1 +
 lib/protocols/Handle.ml  | 25 +++++++++++++++++++++----
 lib/protocols/Handle.mli |  1 +
 6 files changed, 59 insertions(+), 4 deletions(-)
 create mode 100644 lib/Logger.ml
 create mode 100644 lib/Logger.mli

(limited to 'lib')

diff --git a/lib/Logger.ml b/lib/Logger.ml
new file mode 100644
index 0000000..ebb6c97
--- /dev/null
+++ b/lib/Logger.ml
@@ -0,0 +1,29 @@
+type level = Debug | Info | Warn | Error | Fatal
+
+type colors = Foreground | Blue | Yellow | Red | Purple
+
+let reset = "\027[0m"
+let bold = "\027[1m"
+
+let color_for = function
+  | Foreground -> "\027[39m"
+  | Blue -> "\027[34m"
+  | Yellow -> "\027[33m"
+  | Red -> "\027[31m"
+  | Purple -> "\027[35m"
+
+let colored color text = Printf.sprintf "%s%s%s%s" (color_for color) bold text reset
+
+let channel_for = function
+  | Warn | Error | Fatal -> stderr
+  | _ -> stdout
+
+let prefix_for = function
+  | Debug -> colored Foreground "[DEBUG]"
+  | Info -> colored Blue "[INFO]"
+  | Warn -> colored Yellow "[WARN]"
+  | Error -> colored Red "[ERROR]"
+  | Fatal -> colored Purple "[FATAL]"
+
+let log level message =
+  Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
diff --git a/lib/Logger.mli b/lib/Logger.mli
new file mode 100644
index 0000000..21d5b73
--- /dev/null
+++ b/lib/Logger.mli
@@ -0,0 +1,3 @@
+type level = Debug | Info | Warn | Error | Fatal
+
+val log : level -> string -> unit
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
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 ce31009e697830314591ffa4760da9705fc7982a Mon Sep 17 00:00:00 2001
From: Estevan Castilho <tevo@riajuu.net>
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')

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 290be60cf34ef2550a8cb9aa447c232445cd1476 Mon Sep 17 00:00:00 2001
From: Estevan Castilho <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
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 ++
 lib/protocols/Handle.ml  | 11 +++++++++--
 lib/protocols/Handle.mli |  2 ++
 4 files changed, 23 insertions(+), 7 deletions(-)

(limited to 'lib')

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
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 2f786a514b54cf4f72eacb6578a11b20a5069aac Mon Sep 17 00:00:00 2001
From: Estevan Castilho <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
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')

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 <tevo@riajuu.net>
Date: Sat, 10 Oct 2026 02:14:55 +0000
Subject: Make the autorelease pool opt-in

---
 lib/kernel/Path.ml       |  7 +++----
 lib/protocols/Handle.ml  | 15 ++-------------
 lib/protocols/Handle.mli |  5 ++---
 3 files changed, 7 insertions(+), 20 deletions(-)

(limited to 'lib')

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) )
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 <tevo@riajuu.net>
Date: Sat, 10 Oct 2026 02:17:58 +0000
Subject: Style

---
 lib/Logger.ml            |  9 ++------
 lib/kernel/Namespace.ml  | 11 ++++-----
 lib/kernel/Namespace.mli |  1 -
 lib/kernel/Path.ml       |  8 +++----
 lib/kernel/Session.ml    |  1 -
 lib/protocols/Handle.ml  | 59 +++++++++++++++++++++++-------------------------
 6 files changed, 38 insertions(+), 51 deletions(-)

(limited to 'lib')

diff --git a/lib/Logger.ml b/lib/Logger.ml
index ebb6c97..3355e23 100644
--- a/lib/Logger.ml
+++ b/lib/Logger.ml
@@ -1,5 +1,4 @@
 type level = Debug | Info | Warn | Error | Fatal
-
 type colors = Foreground | Blue | Yellow | Red | Purple
 
 let reset = "\027[0m"
@@ -13,10 +12,7 @@ let color_for = function
   | Purple -> "\027[35m"
 
 let colored color text = Printf.sprintf "%s%s%s%s" (color_for color) bold text reset
-
-let channel_for = function
-  | Warn | Error | Fatal -> stderr
-  | _ -> stdout
+let channel_for = function Warn | Error | Fatal -> stderr | _ -> stdout
 
 let prefix_for = function
   | Debug -> colored Foreground "[DEBUG]"
@@ -25,5 +21,4 @@ let prefix_for = function
   | Error -> colored Red "[ERROR]"
   | Fatal -> colored Purple "[FATAL]"
 
-let log level message =
-  Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
+let log level message = Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
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 =
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