diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/backend/managers/Cursor.ml | 2 | ||||
| -rw-r--r-- | lib/backend/managers/Cursor.mli | 2 | ||||
| -rw-r--r-- | lib/backend/managers/Handle.ml | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Identity.ml | 5 | ||||
| -rw-r--r-- | lib/backend/managers/Identity.mli | 3 | ||||
| -rw-r--r-- | lib/backend/managers/Lifecycle.ml | 106 | ||||
| -rw-r--r-- | lib/backend/managers/Lifecycle.mli | 17 | ||||
| -rw-r--r-- | lib/backend/managers/Namespace.ml | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Namespace.mli | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Object.ml | 226 |
10 files changed, 371 insertions, 17 deletions
diff --git a/lib/backend/managers/Cursor.ml b/lib/backend/managers/Cursor.ml index 3295cae..474387a 100644 --- a/lib/backend/managers/Cursor.ml +++ b/lib/backend/managers/Cursor.ml @@ -1,6 +1,6 @@ type descriptor = | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: string BatFingerTree.t} + | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} module Make (Store : Abstract.Storage.STORAGE) = struct type cursor = unit diff --git a/lib/backend/managers/Cursor.mli b/lib/backend/managers/Cursor.mli index 71fb15d..a4dec44 100644 --- a/lib/backend/managers/Cursor.mli +++ b/lib/backend/managers/Cursor.mli @@ -1,6 +1,6 @@ type descriptor = | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: string BatFingerTree.t} + | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} module Make (Store : Abstract.Storage.STORAGE) : sig type cursor diff --git a/lib/backend/managers/Handle.ml b/lib/backend/managers/Handle.ml index ed2f220..872af43 100644 --- a/lib/backend/managers/Handle.ml +++ b/lib/backend/managers/Handle.ml @@ -18,6 +18,10 @@ let not_a_relation () : Concepts.Condition.condition = Concepts.Condition.condition "not-a-relation" "handle does not refer to a stored or ephemeral relation" Concepts.Condition.empty +let no_such_object () : Concepts.Condition.condition = + Concepts.Condition.condition "no-such-object" "no object registered at the given path" + Concepts.Condition.empty + module Make (Store : Abstract.Storage.STORAGE) = struct module Cur = Cursor.Make (Store) @@ -28,8 +32,9 @@ module Make (Store : Abstract.Storage.STORAGE) = struct let create objects txn = {objects; txn} let open_ t ~path = - let object_ = Object.find path t.objects in - Ok {object_; txn= t.txn} + match Object.find path t.objects with + | Some object_ -> Ok {object_; txn= t.txn} + | None -> Error (no_such_object ()) let relation_descriptor (object_ : Object.registry) : (Cursor.descriptor, Concepts.Condition.condition) result = diff --git a/lib/backend/managers/Identity.ml b/lib/backend/managers/Identity.ml new file mode 100644 index 0000000..3510e3a --- /dev/null +++ b/lib/backend/managers/Identity.ml @@ -0,0 +1,5 @@ +let permits (object_ : Object.registry) (method_ : Object.rnt_method) : bool = + BatSet.mem method_ object_.Object.entry.Object.methods + +let can_open (object_ : Object.registry) : bool = permits object_ Object.OPEN +let can_close (object_ : Object.registry) : bool = permits object_ Object.CLOSE diff --git a/lib/backend/managers/Identity.mli b/lib/backend/managers/Identity.mli new file mode 100644 index 0000000..589002e --- /dev/null +++ b/lib/backend/managers/Identity.mli @@ -0,0 +1,3 @@ +val permits : Object.registry -> Object.rnt_method -> bool +val can_open : Object.registry -> bool +val can_close : Object.registry -> bool diff --git a/lib/backend/managers/Lifecycle.ml b/lib/backend/managers/Lifecycle.ml new file mode 100644 index 0000000..7aa3836 --- /dev/null +++ b/lib/backend/managers/Lifecycle.ml @@ -0,0 +1,106 @@ +(* The lifecycle manager decides when a registered object may leave memory. + It works purely on the object tree and never touches storage: collection + here means dropping the in-memory registry entry, not deleting anything on + disk. Durable-backed objects (relations, multigroups, branch trees) can be + rebuilt from their encoded form on the next access, so evicting them is + safe and keeps memory bounded. Runtime-only objects (sessions, and later + transactions) have no durable form, so their collection is a real teardown; + the manager surfaces those to the caller as disposals rather than acting on + storage itself. *) + +type tree = Object.rnt_object_tree + +(* A runtime object that was collected and now needs an external teardown the + lifecycle manager cannot perform on its own: closing a session, and later + rolling back a transaction. The caller drains these after a collect. *) +type disposal = {path: Concepts.Path.t; kind: Object.rnt_object_kind} + +let monitor (tree : tree) (path : Concepts.Path.t) : tree = + Object.update path (fun r -> {r with Object.handle_count= r.Object.handle_count + 1}) tree + +(* Pin is an explicit keep-alive that bypasses collection. It does not touch + reference_count: pinning is a decision, reference counting is bookkeeping of + real edges. Keeping them separate is what stops the two from being mistaken + for each other. *) +let pin (tree : tree) (path : Concepts.Path.t) : tree = + Object.update path (fun r -> {r with Object.pinned= true}) tree + +let unpin (tree : tree) (path : Concepts.Path.t) : tree = + Object.update path (fun r -> {r with Object.pinned= false}) tree + +(* An object may be collected only when nothing holds it open, nothing depends + on it, it has not been pinned, and its kind is not exempt (a branch). This + works on the registry record directly so callers that already hold it (the + cascade) need not walk the tree a second time. *) +let registry_eligible (r : Object.registry) : bool = + r.Object.handle_count = 0 + && r.Object.reference_count = 0 + && (not r.Object.pinned) + && not (Object.is_gc_exempt r.Object.entry.Object.kind) + +let is_eligible_for_gc (tree : tree) (path : Concepts.Path.t) : bool = + match Object.find path tree with Some r -> registry_eligible r | None -> false + +(* Contention reports whether a mutation must wait. An exclusive object with an + open handle, such as a branch head being read, cannot be modified until the + handle closes. This gates writers; it is not part of collection. *) +let contention (tree : tree) (path : Concepts.Path.t) : bool = + match Object.find path tree with + | Some r -> r.Object.entry.Object.exclusive && r.Object.handle_count > 0 + | None -> false + +(* Cascade the collection at path, threading the pruned tree and the disposals + gathered so far. Disposals are appended (snoc) as each object is torn down, + so the finger tree hands them back parent-first, left-to-right without any + reversal pass. + + Order of teardown falls out of the counts. Collecting an object drops the + reference_count of every input it depended on (Object.unregister undoes the + edges), which can make those inputs eligible in turn, so we recurse into + them. A populated namespace is kept, not collected and not an error: it is + scaffolding for the objects still living under it. *) +let rec cascade (tree : tree) (disposals : disposal BatFingerTree.t) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + match Object.find path tree with + | None -> Ok (tree, disposals) + | Some r when not (registry_eligible r) -> Ok (tree, disposals) + | Some r -> + let kind = r.Object.entry.Object.kind in + begin match kind with + | Object.Namespace _ when Object.has_children path tree -> Ok (tree, disposals) + | _ -> + let edges = Object.reference_edges kind in + let disposals = + if Object.is_runtime kind then BatFingerTree.snoc disposals {path; kind} else disposals + in + Result.bind (Object.unregister path tree) (fun tree -> + BatFingerTree.fold_left + (fun acc dep -> Result.bind acc (fun (tree, disposals) -> cascade tree disposals dep)) + (Ok (tree, disposals)) + edges ) + end + +let try_collect (tree : tree) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + cascade tree BatFingerTree.empty path + +(* Close a handle, then see whether the object can now go. *) +let unmonitor (tree : tree) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + let tree = + Object.update path + (fun r -> + if r.Object.handle_count = 0 then r + else {r with Object.handle_count= r.Object.handle_count - 1} ) + tree + in + try_collect tree path + +(* Public entry point for an explicit collection request. *) +let collect (tree : tree) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + try_collect tree path + +(* Session reaping is not built here yet. A lost connection is detected by a + per-session inactivity timer whose expiry drives collect on the session. + Design and tasks are tracked in issue #24. *) diff --git a/lib/backend/managers/Lifecycle.mli b/lib/backend/managers/Lifecycle.mli new file mode 100644 index 0000000..f8cec1a --- /dev/null +++ b/lib/backend/managers/Lifecycle.mli @@ -0,0 +1,17 @@ +type tree = Object.rnt_object_tree + +(* A collected runtime object that still needs an external teardown: a session + to close, and later a transaction to roll back. The caller drains these. *) +type disposal = {path: Concepts.Path.t; kind: Object.rnt_object_kind} + +val monitor : tree -> Concepts.Path.t -> tree +val pin : tree -> Concepts.Path.t -> tree +val unpin : tree -> Concepts.Path.t -> tree +val is_eligible_for_gc : tree -> Concepts.Path.t -> bool +val contention : tree -> Concepts.Path.t -> bool + +val unmonitor : + tree -> Concepts.Path.t -> (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result + +val collect : + tree -> Concepts.Path.t -> (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result diff --git a/lib/backend/managers/Namespace.ml b/lib/backend/managers/Namespace.ml new file mode 100644 index 0000000..61b1eff --- /dev/null +++ b/lib/backend/managers/Namespace.ml @@ -0,0 +1,9 @@ +module Make (Store : Abstract.Storage.STORAGE) = struct + type tree = Object.rnt_object_tree + + let resolve (_txn : Store.transaction) (_tree : tree) (_path : Concepts.Path.t) : + (Concepts.Path.t, Concepts.Condition.condition) result = + failwith + "NOT IMPLEMENTED: reparse loop with cycle guard; /system/branches/<n>/<sub> -> \ + /system/snapshots/<target_hash>/<sub> via Branch.target_hash" +end diff --git a/lib/backend/managers/Namespace.mli b/lib/backend/managers/Namespace.mli new file mode 100644 index 0000000..1ee9651 --- /dev/null +++ b/lib/backend/managers/Namespace.mli @@ -0,0 +1,9 @@ +module Make (Store : Abstract.Storage.STORAGE) : sig + type tree = Object.rnt_object_tree + + val resolve : + Store.transaction -> + tree -> + Concepts.Path.t -> + (Concepts.Path.t, Concepts.Condition.condition) result +end diff --git a/lib/backend/managers/Object.ml b/lib/backend/managers/Object.ml index b107b4e..981420b 100644 --- a/lib/backend/managers/Object.ml +++ b/lib/backend/managers/Object.ml @@ -1,6 +1,13 @@ type multigroup = {merkle_root: string} type relation = {merkle_root: string} -type ephemeral_relation = {merkle_root: string; dependencies: string BatFingerTree.t} + +(* An ephemeral relation is a stored plan that reads other relations. Its + dependencies are the inputs that plan replays over. They are branch-local + symlink paths, not version-pinned paths: as the branch head advances the + inputs move with it, and Namespace.resolve turns the symlink into whatever + object is current on this branch hash. Keeping them as paths (not hashes) + is what lets an ephemeral relation behave like a view. *) +type ephemeral_relation = {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} type transaction = unit type session = {connection_context: unit; branch_overrides: string BatMap.String.t} type branch = {name: string; target_hash: string} @@ -13,25 +20,218 @@ type rnt_object_kind = | Session of session | Branch of branch | BranchTree of branch_tree + | Namespace of namespace + +and namespace = {label: string; predicate: rnt_object_kind -> bool} type rnt_method = OPEN | CLOSE type rnt_object = - {kind: rnt_object_kind; disposable: bool; methods: rnt_method BatSet.t; exclsive: bool} + {kind: rnt_object_kind; disposable: bool; methods: rnt_method BatSet.t; exclusive: bool} + +(* Three independent facts about a registered object, kept apart on purpose: + + - handle_count: how many handles are open on it right now (open/close). + - reference_count: how many other objects depend on it staying resident. + This is bookkeeping of real edges, nothing more. It goes up because a + dependency exists, not because someone asked to keep the object alive. + - pinned: an explicit override that bypasses collection regardless of the + counts. Used when something must not be evicted even though nothing + currently points at it or holds it open. This is deliberately separate + from reference_count so the two reasons never get confused. *) +type registry = {reference_count: int; handle_count: int; pinned: bool; entry: rnt_object} + +(* + /system/branch/branch1/multigrop/multigroup1/relation/relation1 + /system/branch1/multigrop/multigroup1/relation/relation2 + /system/branch1/multigrop/multigroup1/ephemeral_relation/ephemeral_relation1 + /system/transaction/xyz_txn + *) -type registry = {reference_count: int; handle_count: int; entry: rnt_object} +type rnt_object_tree = {data: registry; subsequent: rnt_object_tree BatMap.String.t} -type rnt_object_tree = - | Intermediary of {label: string; data: registry; subsequent: rnt_object_tree BatFingerTree.t} - | Final of {label: string; data: registry} +module Error = struct + open Concepts.Condition -let register (_object_path : string BatFingerTree.t) (_registry : rnt_object_tree) - (_rnt_object : rnt_object) : rnt_object_tree = - failwith "NOT IMPLEMENTED" + let registry_object_already_registered path = + let msg = "An object is already registered in the path" in + condition "registry-object-already-registered" msg + ("path" |=| Concepts.Value.String (Concepts.Path.to_string path)) -let find (_object_path : string BatFingerTree.t) (_registry : rnt_object_tree) : registry = - failwith "NOT IMPLEMENTED" + let registry_path_not_found path = + let msg = "The provided path was not found" in + condition "registry-path-not-found" msg + ("path" |=| Concepts.Value.String (Concepts.Path.to_string path)) +end -let unregister (_object_path : string BatFingerTree.t) (_registry : rnt_object_tree) : +let make_object ?(disposable = false) ?(exclusive = false) ?(methods = BatSet.empty) + (kind : rnt_object_kind) : rnt_object = + {kind; disposable; methods; exclusive} + +(* The empty registry. The root node is the system namespace itself, and every + other object is registered under it. Path separators are only a string + rendering concern, so there is no distinct "/" node above system: system is + the root. It is exempt from collection for the same reason a branch is, it + is the way in to everything else. *) +let root : rnt_object_tree = + { data= + { reference_count= 0; + handle_count= 0; + pinned= false; + entry= make_object (Namespace {label= "system"; predicate= (fun _ -> true)}) }; + subsequent= BatMap.String.empty } + +let find (path : Concepts.Path.t) (tree : rnt_object_tree) : registry option = + let rec walk components node = + match BatFingerTree.front components with + | None -> Some node.data + | Some (tail, head) -> Option.bind (BatMap.String.find_opt head node.subsequent) (walk tail) + in + walk path tree + +let update (path : Concepts.Path.t) (f : registry -> registry) (tree : rnt_object_tree) : rnt_object_tree = - failwith "NOT IMPLEMENTED" + let rec walk components node = + match BatFingerTree.front components with + | None -> {node with data= f node.data} + | Some (tail, head) -> + begin match BatMap.String.find_opt head node.subsequent with + | None -> node + | Some child -> + {node with subsequent= BatMap.String.add head (walk tail child) node.subsequent} + end + in + walk path tree + +(* The objects that must stay resident for this object to remain replayable. + Registering an object bumps the reference_count of each edge target and + unregistering drops it, so reference counts stay in step with the real + dependency graph. Only ephemeral relations carry edges today. Which kinds + grow edges is a per-kind decision, which is why this lives next to the + registry and not in the lifecycle manager: the object knows its own shape. *) +let reference_edges (kind : rnt_object_kind) : Concepts.Path.t BatFingerTree.t = + match kind with + | EphemeralRelation {dependencies; _} -> dependencies + | Multigroup _ | Relation _ | Session _ | Branch _ | BranchTree _ | Namespace _ -> + BatFingerTree.empty + +(* Adjust the reference_count of every edge target by delta. A target that is + not present is skipped: update leaves the tree untouched when the path is + missing. That is fine for a skeleton, but it hides a dangling dependency, + so registration will eventually want to fail loudly on a missing input. *) +let adjust_references (delta : int) (paths : Concepts.Path.t BatFingerTree.t) + (tree : rnt_object_tree) : rnt_object_tree = + BatFingerTree.fold_left + (fun tree path -> + update path (fun r -> {r with reference_count= r.reference_count + delta}) tree ) + tree paths + +(* A branch is exempt from collection because everything is reachable through + it: collecting a branch would orphan its whole subtree. Every other kind is + collectable, including sessions. A session is runtime-only state with no + durable encoding, so collecting one is a real teardown rather than an + eviction, but it still happens (see Lifecycle for how a dead session is + detected). *) +let is_gc_exempt (kind : rnt_object_kind) : bool = match kind with Branch _ -> true | _ -> false + +(* Runtime-only kinds have no durable encoding, so collecting them cannot be + undone by rehydrating from disk. The lifecycle manager surfaces these to + its caller as disposals to run (a session close, and later a transaction + rollback once transactions become objects in their own right). *) +let is_runtime (kind : rnt_object_kind) : bool = match kind with Session _ -> true | _ -> false + +let has_children (path : Concepts.Path.t) (tree : rnt_object_tree) : bool = + let rec walk components node = + match BatFingerTree.front components with + | None -> not (BatMap.String.is_empty node.subsequent) + | Some (tail, head) -> + begin match BatMap.String.find_opt head node.subsequent with + | None -> false + | Some child -> walk tail child + end + in + walk path tree + +(* TODO: This function is not tail call optimized. We ventured with + the idea of using CPS, but that's not going to solve anything here, + so the probable best course of action is relying on the growing map + to carry on the state. This is not a big deal as the structure is + expected to be small enough to live in memory and these operations + are relatively uncommon. *) +let register (path : Concepts.Path.t) (object' : rnt_object) (tree : rnt_object_tree) : + (rnt_object_tree, Concepts.Condition.condition) result = + let rec insert components node = + match BatFingerTree.front components with + | None -> Error (Error.registry_object_already_registered path) + | Some (tail, head) when BatFingerTree.is_empty tail -> + if BatMap.String.mem head node.subsequent then + Error (Error.registry_object_already_registered path) + else + let child = + { data= {reference_count= 0; handle_count= 0; pinned= false; entry= object'}; + subsequent= BatMap.String.empty } + in + Ok {node with subsequent= BatMap.String.add head child node.subsequent} + | Some (tail, head) -> + begin match BatMap.String.find_opt head node.subsequent with + | None -> Error (Error.registry_path_not_found path) + | Some child -> + Result.map (fun child' -> + {node with subsequent= BatMap.String.add head child' node.subsequent} ) + @@ insert tail child + end + in + (* On success, record the new object's dependency edges by bumping the + reference_count of each input it reads. This is the polymorphic part of + registration: the edge set comes from the object's own kind. *) + Result.map + (fun tree -> adjust_references 1 (reference_edges object'.kind) tree) + (insert path tree) + +let with_namespace (parent : Concepts.Path.t) (namespace_label : string) + (predicate : rnt_object_kind -> bool) (name : string) (object' : rnt_object) + (tree : rnt_object_tree) : (rnt_object_tree, Concepts.Condition.condition) result = + let namespace_path = Concepts.Path.snoc parent namespace_label in + let tree_with_namespace = + match find namespace_path tree with + | None -> + register namespace_path (make_object (Namespace {label= namespace_label; predicate})) tree + | Some _ -> Ok tree + in + Result.bind tree_with_namespace (fun tree -> + register (Concepts.Path.snoc namespace_path name) object' tree ) + +let construct_multigroup parent name (mg : multigroup) tree = + with_namespace parent "multigroup" + (function Multigroup _ -> true | _ -> false) + name (make_object (Multigroup mg)) tree + +let construct_relation parent name (rel : relation) tree = + with_namespace parent "relation" + (function Relation _ -> true | _ -> false) + name (make_object (Relation rel)) tree + +let unregister (path : Concepts.Path.t) (tree : rnt_object_tree) : + (rnt_object_tree, Concepts.Condition.condition) result = + (* Read the edges before removing the node so we can undo what register did: + dropping an object releases its hold on the inputs it depended on. *) + let edges = + match find path tree with Some r -> reference_edges r.entry.kind | None -> BatFingerTree.empty + in + let rec remove components node = + match BatFingerTree.front components with + | None -> Error (Error.registry_path_not_found path) + | Some (tail, head) when BatFingerTree.is_empty tail -> + if BatMap.String.mem head node.subsequent then + Ok {node with subsequent= BatMap.String.remove head node.subsequent} + else Error (Error.registry_path_not_found path) + | Some (tail, head) -> + begin match BatMap.String.find_opt head node.subsequent with + | None -> Error (Error.registry_path_not_found path) + | Some child -> + Result.map (fun child' -> + {node with subsequent= BatMap.String.add head child' node.subsequent} ) + @@ remove tail child + end + in + Result.map (fun tree -> adjust_references (-1) edges tree) (remove path tree) |