diff options
| -rw-r--r-- | lib/kernel/Namespace.ml | 15 | ||||
| -rw-r--r-- | lib/kernel/Namespace.mli | 2 | ||||
| -rw-r--r-- | lib/protocols/Handle.ml | 11 | ||||
| -rw-r--r-- | lib/protocols/Handle.mli | 2 | ||||
| -rw-r--r-- | test/unit/kernel/Session.ml | 2 |
5 files changed, 24 insertions, 8 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 diff --git a/test/unit/kernel/Session.ml b/test/unit/kernel/Session.ml index 2548629..73e7c49 100644 --- a/test/unit/kernel/Session.ml +++ b/test/unit/kernel/Session.ml @@ -25,7 +25,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* _ = update root ("branch" @/ this) "master" None (Some branch) in let* tip = address branch in let session = Session.make conn {Protocols.Session.snapshot= tip} in - let* _ = update root ("session" @/ this) "client" None (Some session) in + let* _ = update root ("session" @/ this) "client" None (Protocols.Handle.copy session) in let library = "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this in let before = finds root library in let* multigroup = M.make conn in |