Make namespaces take ownership of the handles it is given

4 files changed, 23 insertions, 7 deletions

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