diff options
Diffstat (limited to 'lib/kernel')
| -rw-r--r-- | lib/kernel/EphemeralRelation.ml | 73 | ||||
| -rw-r--r-- | lib/kernel/EphemeralRelation.mli | 36 | ||||
| -rw-r--r-- | lib/kernel/Generator.ml | 19 | ||||
| -rw-r--r-- | lib/kernel/Lifecycle.ml | 15 | ||||
| -rw-r--r-- | lib/kernel/Lifecycle.mli | 10 | ||||
| -rw-r--r-- | lib/kernel/Storage.ml | 7 | ||||
| -rw-r--r-- | lib/kernel/Storage.mli | 1 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.ml | 59 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.mli | 8 |
9 files changed, 183 insertions, 45 deletions
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml new file mode 100644 index 0000000..b403e13 --- /dev/null +++ b/lib/kernel/EphemeralRelation.ml @@ -0,0 +1,73 @@ +module type DERIVATION = sig + type plan + + val identity : plan -> Concepts.Hash.hash + + val describe : + plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result + + val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result + + val generate : + plan -> + Protocols.Generative.binding -> + (Protocols.Handle.t, Concepts.Condition.condition) result +end + +module Make (D : DERIVATION) = struct + let pinned_tag = "rnt/pinned/1" + + let identity ?pinned plan = + let derivation = D.identity plan in + match pinned with + | None -> derivation + | Some branch -> + pinned_tag ^ Concepts.Hash.to_raw_string derivation ^ Concepts.Hash.to_raw_string branch + |> Bytes.of_string + |> Concepts.Hash.hash_of_bytes + + class ephemeral (plan : D.plan) address declaration description edges = + object (self) + inherit Lifecycle.counted + inherit Protocols.Generative.membership + val heading = Concepts.Mode.attributes_of_map description + method destroy = List.iter Protocols.Handle.release edges + method predicate = Ok None + method local_constraints = Ok None + method modes = Ok declaration + + (* A cursor holds a reference to its relation, so the edges it reads + outlive a release of the relation that produced it. *) + method generate binding = + D.generate plan binding + |> Result.map (fun cursor -> + new Lifecycle.retaining cursor (self :> Lifecycle.lifecycle) |> Protocols.Handle.make ) + + method enumerate = self#generate Protocols.Generative.nothing + method describe () = Ok (Protocols.Schematics.Relation description) + + method protocols : Protocols.Handle.protocol list = + let carried = + [ Protocols.Relation.make self; + Protocols.Schematics.make self; + Protocols.Generative.make self ] + in + if Concepts.Mode.exhaustible declaration BatSet.String.empty then + Protocols.Enumerable.make self :: carried + else carried + + method hash : Concepts.Hash.hash = address + end + + let derive ?pinned ?(edges = []) plan = + let open Utilities.Result in + let derived = + let* declaration = D.modes plan in + let* description = D.describe plan in + Ok + ( new ephemeral plan (identity ?pinned plan) declaration description edges + |> Protocols.Handle.make ) + in + Result.iter_error (fun _ -> List.iter Protocols.Handle.release edges) derived; + derived +end diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli new file mode 100644 index 0000000..d082394 --- /dev/null +++ b/lib/kernel/EphemeralRelation.mli @@ -0,0 +1,36 @@ +module type DERIVATION = sig + type plan + + (** the hash of the plan, taken over the branch-local names of its + inputs rather than over their content addresses. The idea is to + have the same expression denote one object on every branch and + at every point in time. *) + val identity : plan -> Concepts.Hash.hash + + val describe : + plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result + + val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result + + val generate : + plan -> + Protocols.Generative.binding -> + (Protocols.Handle.t, Concepts.Condition.condition) result +end + +module Make (D : DERIVATION) : sig + (** unpinned, the identity of the derivation itself; pinned to a + branch commit, the identity of that derivation against one + reconstructible state, which is the only form for which equal + identity implies equal extension. *) + val identity : ?pinned:Concepts.Hash.hash -> D.plan -> Concepts.Hash.hash + + (** edges are the handles the derivation reads, which are released + when the relation is also. Rejection of a derivation surfaces + here instead of when a cursor is being drained. *) + val derive : + ?pinned:Concepts.Hash.hash -> + ?edges:Protocols.Handle.t list -> + D.plan -> + (Protocols.Handle.t, Concepts.Condition.condition) result +end diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml index 10f6865..204699f 100644 --- a/lib/kernel/Generator.ml +++ b/lib/kernel/Generator.ml @@ -10,7 +10,7 @@ let start produce = let resume k = Effect.Deep.continue k () -class producer_cursor produce on_release = +class producer_cursor produce finally = object (self) inherit Lifecycle.null inherit Identity.of_id @@ -19,13 +19,18 @@ class producer_cursor produce on_release = val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self] + + method private finish = + state <- `Done; + Option.iter (fun f -> f ()) finally + method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result = let settle = function | Element (tuple, k) -> state <- `Live k; Ok (Some tuple) | Finished r -> - state <- `Done; + self#finish; Result.map (fun () -> None) r in match state with @@ -47,12 +52,8 @@ class producer_cursor produce on_release = Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)} else fill 0 BatFingerTree.empty - method! release = - (match state with - | `Live _ -> Option.iter (fun f -> f ()) on_release - | `Fresh | `Done -> ()); - state <- `Done + method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> () end -let cursor_of ?on_release produce = - new producer_cursor produce on_release |> Protocols.Handle.make +let cursor_of ?finally produce = + new producer_cursor produce finally |> Protocols.Handle.make diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml index ff67ecf..772cb6e 100644 --- a/lib/kernel/Lifecycle.ml +++ b/lib/kernel/Lifecycle.ml @@ -23,7 +23,18 @@ class virtual counted = object (self) true method release = - Atomic.decr references; - if Atomic.get references <= 0 then + if Atomic.fetch_and_add references (-1) = 1 then self#destroy end + +class retaining inner (owner : lifecycle) = object + inherit counted + initializer ignore owner#reference + + method destroy = + Protocols.Handle.release inner; + owner#release + + method hash = Protocols.Handle.hash inner + method protocols = Protocols.Handle.protocols inner +end diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli index f110768..fa3abee 100644 --- a/lib/kernel/Lifecycle.mli +++ b/lib/kernel/Lifecycle.mli @@ -10,3 +10,13 @@ end class null : lifecycle class virtual counted : controlled_lifecycle + +(** stands for [inner], carrying what it carries, while holding a + reference to [owner], so what [inner] reads outlives a release of + the object that produced it. *) +class retaining : Protocols.Handle.t -> lifecycle -> object + inherit lifecycle + method destroy : unit + method hash : Concepts.Hash.hash + method protocols : Protocols.Handle.protocol list +end diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml index 665b1a7..d50735c 100644 --- a/lib/kernel/Storage.ml +++ b/lib/kernel/Storage.ml @@ -36,11 +36,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct let _ = S.abort tx in Error condition - let with_transaction connection body = + let within start connection body = let open Utilities.Result in - let* tx = S.start connection in + let* tx = start connection in body tx |> finish tx + let with_transaction connection = within S.start connection + let with_read connection = within S.start_read connection + let store_blob tx blob = let open Utilities.Result in let address = Concepts.Hash.hash_of_blob blob in diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli index 3c036ca..53bb666 100644 --- a/lib/kernel/Storage.mli +++ b/lib/kernel/Storage.mli @@ -12,6 +12,7 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result + val with_read : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result val get_req: S.transaction -> S.address -> (Concepts.Blob.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index 136c146..52ce83c 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -120,30 +120,34 @@ module Make (S : Abstract.Storage.STORAGE) = struct kvs |> List.map (fun (name, domain) -> Concepts.Encoding.Bencode.as_string domain - |> Result.map (fun domain -> (name, domain))) + |> Result.map (fun domain -> + (name, {Protocols.Schematics.domain; provenance= []}) ) ) |> Utilities.List.sequence - |> Result.map (fun kvs -> - List.fold_left - (fun acc (name, domain) -> BatMap.String.add name domain acc) - BatMap.String.empty kvs) + |> Result.map BatMap.String.of_list - let enumerate storage relation = + let generate storage relation binding = let open Utilities.Result in - let* tx = S.start storage in - let* node = tuple_node tx relation in - let closed = ref false in - let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in + let* tx = S.start_read storage in + let close () = ignore (S.abort tx) in + let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in (* The fold is suspended by [yield], so the tree is walked one node and one tuple at a time rather than materialized before the first tuple is produced. *) let produce ~yield = - let walked = TupleSet.iter tx (fun _ tuple -> yield tuple) node in - close (); - walked + TupleSet.iter tx + (fun _ tuple -> if Protocols.Generative.satisfies binding tuple then yield tuple) + node in - Ok (Generator.cursor_of ~on_release:close produce) + Ok (Generator.cursor_of ~finally:close produce) + + let enumerate storage relation = generate storage relation Protocols.Generative.nothing + + let modes_of description = + Concepts.Mode.of_list + [ Concepts.Mode.enumerable Concepts.Cardinality.Finite; + {Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ] - class relation storage value = + class relation storage value description = object (self) inherit Lifecycle.null @@ -151,18 +155,16 @@ module Make (S : Abstract.Storage.STORAGE) = struct val storage : S.connection = storage val relation : t = value + val declaration = modes_of description method predicate = Ok relation.predicate method local_constraints = Ok relation.local_constraints (* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller that had to produce the exact stored bytes would have to know this encoding to do it. *) method contains (tuple : Concepts.Tuple.t) = - SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple) + SI.with_read storage (fun tx -> contains_tuple tx relation tuple) - method describe () = - let open Utilities.Result in - let* description = SI.with_transaction storage (fun tx -> schema_of tx relation) in - Ok (Protocols.Schematics.Relation description) + method describe () = Ok (Protocols.Schematics.Relation description) (* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as [Relation]. A procedural relation would carry only the latter, which is how an evaluator @@ -171,30 +173,39 @@ module Make (S : Abstract.Storage.STORAGE) = struct no name resolution, but cancellation should eventually be checked between tuples. *) method enumerate = enumerate storage relation + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = Ok declaration + method generate binding = generate storage relation binding + method protocols : Protocols.Handle.protocol list = [ Protocols.Relation.make self ; Protocols.Enumerable.make self + ; Protocols.Generative.make self ; Protocols.Schematics.make self ] method hash = hash relation end + (* A relation never changes its schema, so it is read once here and + the description and modes are served from it on every request. *) + let instantiate tx conn relation = + schema_of tx relation + |> Result.map (fun description -> new relation conn relation description |> Protocols.Handle.make) + let make conn ~schematics ?predicate ?local_constraints ?indexes () = let open Utilities.Result in SI.with_transaction conn (fun tx -> let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in let* _ = store tx relation in - Ok (new relation conn relation |> Protocols.Handle.make) ) + instantiate tx conn relation ) let load_value tx addr = let open Utilities.Result in let* data = SI.get_req tx (S.Hash addr) in Representation.of_blob data - let wrap conn relation = - new relation conn relation |> Protocols.Handle.make |> Result.ok + let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation) let load tx conn addr = - load_value tx addr |> Utilities.Result.fmap (wrap conn) + load_value tx addr |> Utilities.Result.fmap (instantiate tx conn) let assert_tuple tx relation tuple = let open Utilities.Result in diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli index 5061e5d..a36c802 100644 --- a/lib/kernel/SubstantialRelation.mli +++ b/lib/kernel/SubstantialRelation.mli @@ -47,18 +47,10 @@ module Make (S : Abstract.Storage.STORAGE) : sig val contains_tuple : S.transaction -> t -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result - (** decodes the schematics at [schematics relation] -- the body of - [Protocols.Schematics.describe] for this kind of relation. *) val schema_of : S.transaction -> t -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result - (** a handle carrying [Protocols.Cursor] over every tuple currently - asserted, decoded via [Concepts.Tuple.Representation.of_blob] -- - the body of [Protocols.Relation.enumerate] for this kind of - relation. Opens its own storage transaction, held for the - cursor's whole lifetime rather than just this call -- see - [Kernel.Generator] and docs/design/evaluator.md, "Shape". *) val enumerate : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result end |