From e3d42d5074be054c2f6a2e9f02805ab047f07db9 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Thu, 10 Sep 2026 00:20:27 -0300 Subject: ephemeral relation and generator at the kernel --- lib/kernel/EphemeralRelation.ml | 87 ++++++++++++++++++++++++++++++++++++++++ lib/kernel/EphemeralRelation.mli | 26 ++++++++++++ lib/kernel/Generator.ml | 56 ++++++++++++++++++++++++++ lib/kernel/Generator.mli | 4 ++ 4 files changed, 173 insertions(+) create mode 100644 lib/kernel/EphemeralRelation.ml create mode 100644 lib/kernel/EphemeralRelation.mli create mode 100644 lib/kernel/Generator.ml create mode 100644 lib/kernel/Generator.mli diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml new file mode 100644 index 0000000..7682c80 --- /dev/null +++ b/lib/kernel/EphemeralRelation.ml @@ -0,0 +1,87 @@ +module Make (S : Abstract.Storage.STORAGE) = struct + module SI = Storage.Make (S) + + type t = { + heading: Concepts.Hash.hash; + evaluator: string; + source: string; + entry: string; + bindings: Concepts.Hash.hash; + inputs: string BatFingerTree.t + } + + module Error = struct + open Concepts.Condition + + let malformed () = + condition "malformed-ephemeral-relation" + "The on-disk representation of an ephemeral relation did not conform to what was expected" + empty + + let replay_not_implemented () = + condition "ephemeral-relation-replay-not-implemented" + "Replaying an ephemeral relation's stored plan is not implemented in this slice -- \ + see lib/kernel/EphemeralRelation.mli" + empty + end + + let heading {heading; _} = heading + let evaluator {evaluator; _} = evaluator + let inputs {inputs; _} = inputs + + let make ~heading ~evaluator ~source ~entry ~bindings ~inputs () = + Ok {heading; evaluator; source; entry; bindings; inputs} + + module rec Representation : (Concepts.Encoding.Record.S with type t = t) = + Concepts.Encoding.Record.Make (Body) + + and Body : Concepts.Encoding.Record.BODY = struct + type nonrec t = t + + let tag = 'E' + let malformed = Error.malformed + + let fields {heading; evaluator; source; entry; bindings; inputs} = + let open Concepts.Encoding in + [ "heading", Value.bencode_of_hash heading; + "evaluator", Field.string evaluator; + "source", Field.string source; + "entry", Field.string entry; + "bindings", Value.bencode_of_hash bindings; + "inputs", Bencode.List (BatFingerTree.to_list inputs |> List.map Field.string) ] + + (* TODO: symmetric to `fields` above -- decode each field back with + Concepts.Encoding.Bencode.{field,as_string,as_list} and + Concepts.Encoding.Value.hash_of_bencode, then rebuild the + BatFingerTree for `inputs` with BatFingerTree.of_list. Left + unimplemented because nothing in this slice ever calls `load` + on a real address (see `load` below); the algorithm is exactly + SubstantialRelation.Body.of_fields's shape, one field wider. *) + let of_fields _fields = Error (malformed ()) [@@warning "-27"] + end + + let store tx relation = SI.store_blob tx (Representation.to_blob relation) + + (* TODO: `enumerate`/`contains` on the Relation object this should + return must, on every call: + 1. resolve `evaluator` via the *current* Runtime.Context's root, + not the one live when `make` ran (lifecycle.org: "not + version-pinned paths" -- the whole point of storing a path + instead of a hash for `evaluator` and `inputs`); + 2. `Protocols.Evaluator.admit source` against it; + 3. `Protocols.Program.invoke ~entry ~bindings:(decode bindings)`; + 4. drain the resulting Cursor into this call's answer. + None of that belongs in this module (see the module comment on + layering) -- it belongs in whatever session/host module builds + Runtime.Context.t values, since only that code is already + S-aware AND Protocols-aware. `load` therefore returns a handle + whose Relation methods all fail with `Error.replay_not_implemented` + rather than wiring a half-generic version of that four-step + replay here. *) + let load tx conn addr = + let open Utilities.Result in + let* data = SI.get_req tx (S.Hash addr) in + let* (_relation : t) = Representation.of_blob data in + let _ = conn in + Error (Error.replay_not_implemented ()) +end diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli new file mode 100644 index 0000000..e579abd --- /dev/null +++ b/lib/kernel/EphemeralRelation.mli @@ -0,0 +1,26 @@ +module Make (S : Abstract.Storage.STORAGE) : sig + type t + + val make : + heading:Concepts.Hash.hash -> + evaluator:string -> + source:string -> + entry:string -> + bindings:Concepts.Hash.hash -> + inputs:string BatFingerTree.t -> + unit -> + (t, Concepts.Condition.condition) result + + val store : S.transaction -> t -> (Concepts.Hash.hash, Concepts.Condition.condition) result + val load : S.transaction -> S.connection -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result + val heading : t -> Concepts.Hash.hash + val evaluator : t -> string + val inputs : t -> string BatFingerTree.t + + module Error : sig + val malformed : unit -> Concepts.Condition.condition + val replay_not_implemented : unit -> Concepts.Condition.condition + end + + module Representation : Concepts.Encoding.Record.S with type t = t +end diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml new file mode 100644 index 0000000..e4a15f8 --- /dev/null +++ b/lib/kernel/Generator.ml @@ -0,0 +1,56 @@ +type _ Effect.t += Yield : Concepts.Tuple.t -> unit Effect.t + +type step = + | Element of Concepts.Tuple.t * (unit, step) Effect.Deep.continuation + | Finished of (unit, Concepts.Condition.condition) result + +let start produce = + try Finished (produce ~yield:(fun tuple -> Effect.perform (Yield tuple))) with + | effect (Yield tuple), k -> Element (tuple, k) + +let resume k = Effect.Deep.continue k () + +class producer_cursor produce on_release = + object (self) + inherit Lifecycle.null + inherit Identity.of_id + + 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 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; + Result.map (fun () -> None) r + in + match state with + | `Done -> Ok None + | `Fresh -> settle (start produce) + | `Live k -> settle (resume k) + + method fetch limit = + let open Utilities.Result in + let rec fill taken tuples = + if taken >= limit then Ok Protocols.Cursor.{tuples; exhausted= false} + else + let* stepped = self#step in + match stepped with + | None -> Ok Protocols.Cursor.{tuples; exhausted= true} + | Some tuple -> fill (taken + 1) (BatFingerTree.snoc tuples tuple) + in + if limit <= 0 then + 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 + end + +let cursor_of ?on_release produce = + new producer_cursor produce on_release |> Protocols.Handle.make diff --git a/lib/kernel/Generator.mli b/lib/kernel/Generator.mli new file mode 100644 index 0000000..f30f8ef --- /dev/null +++ b/lib/kernel/Generator.mli @@ -0,0 +1,4 @@ +val cursor_of : + ?on_release:(unit -> unit) -> + (yield:(Concepts.Tuple.t -> unit) -> (unit, Concepts.Condition.condition) result) -> + Protocols.Handle.t -- cgit v1.2.3