diff options
Diffstat (limited to 'lib/backend/managers/Object.ml')
| -rw-r--r-- | lib/backend/managers/Object.ml | 241 |
1 files changed, 0 insertions, 241 deletions
diff --git a/lib/backend/managers/Object.ml b/lib/backend/managers/Object.ml deleted file mode 100644 index ae5f5c1..0000000 --- a/lib/backend/managers/Object.ml +++ /dev/null @@ -1,241 +0,0 @@ -(* @uses Path -- snoc, to_string when building registry paths *) -(* @uses Condition -- builds registry-object/path errors *) -(* @needs Value *) - -type multigroup = {merkle_root: string} -type relation = {merkle_root: string} - -(* 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} -type branch_tree = {merkle_root: string} - -type rnt_object_kind = - | Multigroup of multigroup - | Relation of relation - | EphemeralRelation of ephemeral_relation - | 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; 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 rnt_object_tree = {data: registry; subsequent: rnt_object_tree BatMap.String.t} - -module Error = struct - open Concepts.Condition - - 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 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 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 = - 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) |