diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/backend/execution/FOL.ml | 110 | ||||
| -rw-r--r-- | lib/backend/managers/Cursor.ml | 24 | ||||
| -rw-r--r-- | lib/backend/managers/Cursor.mli | 16 | ||||
| -rw-r--r-- | lib/backend/managers/Handle.ml | 64 | ||||
| -rw-r--r-- | lib/backend/managers/Handle.mli | 22 | ||||
| -rw-r--r-- | lib/backend/managers/Identity.ml | 7 | ||||
| -rw-r--r-- | lib/backend/managers/Identity.mli | 3 | ||||
| -rw-r--r-- | lib/backend/managers/Lifecycle.ml | 110 | ||||
| -rw-r--r-- | lib/backend/managers/Lifecycle.mli | 17 | ||||
| -rw-r--r-- | lib/backend/managers/Namespace.ml | 14 | ||||
| -rw-r--r-- | lib/backend/managers/Namespace.mli | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Object.ml | 343 | ||||
| -rw-r--r-- | lib/backend/storage/LMDB.ml | 6 |
13 files changed, 3 insertions, 742 deletions
diff --git a/lib/backend/execution/FOL.ml b/lib/backend/execution/FOL.ml deleted file mode 100644 index 7da890d..0000000 --- a/lib/backend/execution/FOL.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* @uses Tuple -- project, rename, merge over result streams *) -(* @needs Value *) -(* @needs Path *) -(* @needs Condition *) - -module Plan = struct - type path_arg = Var of string | Const of Concepts.Value.value - - type t = - | Scan of {path: Concepts.Path.t; args: path_arg BatFingerTree.t} - | Natural of {left: t; right: t} - | Take of {limit: int; from: t} - | Project of {attrs: BatSet.String.t; from: t} - | Materialize of t - | Rename of {attrs: string BatMap.String.t; from: t} - | Union of t BatFingerTree.t -end - -type stream = (Concepts.Tuple.t, Concepts.Condition.condition) result BatSeq.t - -let singleton (x : ('a, 'e) result) : ('a, 'e) result BatSeq.t = - fun () -> BatSeq.Cons (x, BatSeq.empty) - -module Error = struct - open Concepts.Condition - - let unbound_variable name = - condition "unbound-variable" - (Printf.sprintf "path variable %S is not bound in the enclosing tuple" name) - ("variable" |=| Concepts.Value.String name) -end - -let resolve (args : Plan.path_arg BatFingerTree.t) (bindings : Concepts.Tuple.t) : - (Concepts.Value.value BatFingerTree.t, Concepts.Condition.condition) result = - let open Utilities.Result in - BatFingerTree.fold_left - (fun acc arg -> - let* acc = acc in - let* value = - match arg with - | Plan.Const value -> Ok value - | Plan.Var name -> - Option.to_result ~none:(Error.unbound_variable name) - (Concepts.Tuple.access name bindings) - in - Ok (BatFingerTree.snoc acc value) ) - (Ok BatFingerTree.empty) args - -module Make (Handler : Managers.Handle.HANDLER) = struct - let scan handler ~path ~args : stream = - let opened = - let open Utilities.Result in - let* handle = Handler.open_ handler ~path in - Handler.open_cursor handle ~args - in - match opened with - | Error condition -> singleton (Error condition) - | Ok cursor -> - let rec pull () = - match Handler.next cursor with - | Error condition -> BatSeq.Cons (Error condition, BatSeq.empty) - | Ok None -> BatSeq.Nil - | Ok (Some tuple) -> BatSeq.Cons (Ok tuple, pull) - in - pull - - let rec compile handler : Plan.t -> Concepts.Tuple.t -> stream = function - | Scan {path; args} -> ( - fun bindings -> - match resolve args bindings with - | Ok args -> scan handler ~path ~args - | Error condition -> singleton (Error condition) ) - | Project {attrs; from} -> - let from = compile handler from in - fun bindings -> BatSeq.map (Result.map (Concepts.Tuple.project attrs)) (from bindings) - | Rename {attrs; from} -> - let from = compile handler from in - fun bindings -> BatSeq.map (Result.map (Concepts.Tuple.rename attrs)) (from bindings) - | Take {limit; from} -> - let from = compile handler from in - fun bindings -> BatSeq.take limit (from bindings) - | Union plans -> - let compiled = BatFingerTree.map (compile handler) plans in - fun bindings -> - BatFingerTree.fold_right - (fun rest c -> BatSeq.append (c bindings) rest) - BatSeq.empty compiled - | Natural {left; right} -> - let left = compile handler left and right = compile handler right in - let matches l r = - BatMap.String.for_all - (fun name value -> - match Concepts.Tuple.access name r with Some value' -> value = value' | None -> true ) - l - in - fun bindings -> - left bindings - |> BatSeq.concat_map (function - | Error _ as error -> singleton error - | Ok l -> - right l - |> BatSeq.filter (function Ok r -> matches l r | Error _ -> true) - |> BatSeq.map (Result.map (Concepts.Tuple.merge l)) ) - | Materialize from -> - let cached = lazy (BatSeq.memoize (compile handler from Concepts.Tuple.empty)) in - fun _ -> Lazy.force cached - - (* TODO: This should produce ephemeral relations with support of the sublanguage to manage it. *) - let run handler plan : stream = compile handler plan Concepts.Tuple.empty -end diff --git a/lib/backend/managers/Cursor.ml b/lib/backend/managers/Cursor.ml deleted file mode 100644 index 7fdbb6f..0000000 --- a/lib/backend/managers/Cursor.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* @composes Storage -- functor parameter *) -(* @needs Path *) -(* @needs Tuple *) -(* @needs Value *) -(* @needs Condition *) - -type descriptor = - | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} - -module Make (Store : Abstract.Storage.STORAGE) = struct - type cursor = unit - - let open_ (_txn : Store.transaction) (descriptor : descriptor) - ~(args : Concepts.Value.value BatFingerTree.t) : (cursor, Concepts.Condition.condition) result - = - ignore (descriptor, args); - failwith "NOT IMPLEMENTED: open a cursor by paging the relation's Merkle tree over Store.get" - - let next (_cursor : cursor) : (Concepts.Tuple.t option, Concepts.Condition.condition) result = - failwith "NOT IMPLEMENTED: page the next tuple over Store.get" - - let close (_cursor : cursor) : unit = () -end diff --git a/lib/backend/managers/Cursor.mli b/lib/backend/managers/Cursor.mli deleted file mode 100644 index a4dec44..0000000 --- a/lib/backend/managers/Cursor.mli +++ /dev/null @@ -1,16 +0,0 @@ -type descriptor = - | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} - -module Make (Store : Abstract.Storage.STORAGE) : sig - type cursor - - val open_ : - Store.transaction -> - descriptor -> - args:Concepts.Value.value BatFingerTree.t -> - (cursor, Concepts.Condition.condition) result - - val next : cursor -> (Concepts.Tuple.t option, Concepts.Condition.condition) result - val close : cursor -> unit -end diff --git a/lib/backend/managers/Handle.ml b/lib/backend/managers/Handle.ml deleted file mode 100644 index be84972..0000000 --- a/lib/backend/managers/Handle.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* @composes Storage -- functor parameter *) -(* @composes Cursor -- applies Cursor.Make (Store) *) -(* @uses Object -- find, registry/kind inspection *) -(* @uses Condition -- builds not-a-relation / no-such-object errors *) -(* @needs Path *) -(* @needs Tuple *) -(* @needs Value *) - -module type HANDLER = sig - type t - type handle - type cursor - - val open_ : t -> path:Concepts.Path.t -> (handle, Concepts.Condition.condition) result - - val open_cursor : - handle -> - args:Concepts.Value.value BatFingerTree.t -> - (cursor, Concepts.Condition.condition) result - - val next : cursor -> (Concepts.Tuple.t option, Concepts.Condition.condition) result - val close : cursor -> unit -end - -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) - - type t = {objects: Object.rnt_object_tree; txn: Store.transaction} - type handle = {object_: Object.registry; txn: Store.transaction} - type cursor = Cur.cursor - - let create objects txn = {objects; txn} - - let open_ t ~path = - 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 = - let {Object.entry; _} = object_ in - match entry.Object.kind with - | Object.Relation {merkle_root} -> Ok (Cursor.Stored {merkle_root}) - | Object.EphemeralRelation {merkle_root; dependencies} -> - Ok (Cursor.Ephemeral {merkle_root; dependencies}) - | _ -> Error (not_a_relation ()) - - let open_cursor handle ~args = - let open Utilities.Result in - let* descriptor = relation_descriptor handle.object_ in - Cur.open_ handle.txn descriptor ~args - - let next = Cur.next - let close = Cur.close - let object_ (handle : handle) = handle.object_ -end diff --git a/lib/backend/managers/Handle.mli b/lib/backend/managers/Handle.mli deleted file mode 100644 index 5fc82b8..0000000 --- a/lib/backend/managers/Handle.mli +++ /dev/null @@ -1,22 +0,0 @@ -module type HANDLER = sig - type t - type handle - type cursor - - val open_ : t -> path:Concepts.Path.t -> (handle, Concepts.Condition.condition) result - - val open_cursor : - handle -> - args:Concepts.Value.value BatFingerTree.t -> - (cursor, Concepts.Condition.condition) result - - val next : cursor -> (Concepts.Tuple.t option, Concepts.Condition.condition) result - val close : cursor -> unit -end - -module Make (Store : Abstract.Storage.STORAGE) : sig - include HANDLER - - val create : Object.rnt_object_tree -> Store.transaction -> t - val object_ : handle -> Object.registry -end diff --git a/lib/backend/managers/Identity.ml b/lib/backend/managers/Identity.ml deleted file mode 100644 index bfde226..0000000 --- a/lib/backend/managers/Identity.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* @needs Object *) - -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 deleted file mode 100644 index 589002e..0000000 --- a/lib/backend/managers/Identity.mli +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 index d104249..0000000 --- a/lib/backend/managers/Lifecycle.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* 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. *) - -(* @uses Object -- find/update, unregister, reference_edges, has_children *) -(* @needs Path *) -(* @needs Condition *) - -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 deleted file mode 100644 index f8cec1a..0000000 --- a/lib/backend/managers/Lifecycle.mli +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 index a48fef9..0000000 --- a/lib/backend/managers/Namespace.ml +++ /dev/null @@ -1,14 +0,0 @@ -(* @composes Storage -- functor parameter *) -(* @needs Object *) -(* @needs Path *) -(* @needs Condition *) - -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 deleted file mode 100644 index 1ee9651..0000000 --- a/lib/backend/managers/Namespace.mli +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index d54c89d..0000000 --- a/lib/backend/managers/Object.ml +++ /dev/null @@ -1,343 +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 type RUNTIME_STRATEGY = sig - type 'a state - - (* The exact snapshot observed on acquire *) - type 'a token - - val create : 'a -> 'a state - val acquire : 'a state -> 'a * 'a token - val publish : 'a state -> 'a token -> 'a -> (unit, Concepts.Condition.condition) result -end - -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) - -module type MANAGER = sig - type t - - val create : branch_index_root:Concepts.Hash.hash -> registry:rnt_object_tree -> t - val branch_index_root : t -> Concepts.Hash.hash - val find : t -> Concepts.Path.t -> registry option - - val update : - t -> Concepts.Path.t -> (registry -> registry) -> (unit, Concepts.Condition.condition) result - - val register : t -> Concepts.Path.t -> rnt_object -> (unit, Concepts.Condition.condition) result - val unregister : t -> Concepts.Path.t -> (unit, Concepts.Condition.condition) result - - val with_namespace : - t -> - Concepts.Path.t -> - string -> - (rnt_object_kind -> bool) -> - string -> - rnt_object -> - (unit, Concepts.Condition.condition) result - - val construct_multigroup : - t -> Concepts.Path.t -> string -> multigroup -> (unit, Concepts.Condition.condition) result - - val construct_relation : - t -> Concepts.Path.t -> string -> relation -> (unit, Concepts.Condition.condition) result -end - -(* Keep the immutable tree operations above as the implementation core, while - this functor owns publication of the current photograph. Runtime bootstraps - the first photograph and exposes this opaque manager to its consumers. *) -module Make (Strategy : RUNTIME_STRATEGY) : MANAGER = struct - type photograph = {branch_index_root: Concepts.Hash.hash; registry: rnt_object_tree} - type t = {state: photograph Strategy.state} - - let create ~branch_index_root ~registry = {state= Strategy.create {branch_index_root; registry}} - - let branch_index_root manager = - let photograph, _ = Strategy.acquire manager.state in - photograph.branch_index_root - - let find manager path = - let photograph, _ = Strategy.acquire manager.state in - find path photograph.registry - - let modify manager transformation = - let open Utilities.Result in - let photograph, token = Strategy.acquire manager.state in - let* next, result = transformation photograph in - let* () = Strategy.publish manager.state token next in - Ok result - - let update manager path f = - modify manager (fun photograph -> - let registry = update path f photograph.registry in - Ok ({photograph with registry}, ()) ) - - let register manager path object_ = - modify manager (fun photograph -> - let open Utilities.Result in - let* registry = register path object_ photograph.registry in - Ok ({photograph with registry}, ()) ) - - let unregister manager path = - modify manager (fun photograph -> - let open Utilities.Result in - let* registry = unregister path photograph.registry in - Ok ({photograph with registry}, ()) ) - - let with_namespace manager parent namespace_label predicate name object_ = - modify manager (fun photograph -> - let open Utilities.Result in - let* registry = - with_namespace parent namespace_label predicate name object_ photograph.registry - in - Ok ({photograph with registry}, ()) ) - - let construct_multigroup manager parent name multigroup = - modify manager (fun photograph -> - let open Utilities.Result in - let* registry = construct_multigroup parent name multigroup photograph.registry in - Ok ({photograph with registry}, ()) ) - - let construct_relation manager parent name relation = - modify manager (fun photograph -> - let open Utilities.Result in - let* registry = construct_relation parent name relation photograph.registry in - Ok ({photograph with registry}, ()) ) -end diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index dc7f510..0f65aaf 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -178,14 +178,14 @@ let bytes_of_address = function let get ({tx; dbi} : transaction) (addr : address) = begin match C.mdb_get' tx dbi (bytes_of_address addr) with - | Ok x -> Ok (Some (Concepts.Representation.blob_of_bytes x)) + | Ok x -> Ok (Some (Concepts.Blob.blob_of_bytes x)) | Error e when e = C.Errors.mdb_notfound -> Ok None | Error e -> Error e end |> Result.map_error Error.lmdb_error -let put ({tx; dbi} : transaction) (addr : address) (b : Concepts.Representation.blob) = +let put ({tx; dbi} : transaction) (addr : address) (b : Concepts.Blob.t) = C.mdb_put' tx dbi (bytes_of_address addr) - (Concepts.Representation.bytes_of_blob b) + (Concepts.Blob.bytes_of_blob b) Unsigned.UInt.zero |> Result.map_error Error.lmdb_error |