diff options
Diffstat (limited to 'subsystem')
| -rw-r--r-- | subsystem/karuta/Beam.ml | 122 |
1 files changed, 83 insertions, 39 deletions
diff --git a/subsystem/karuta/Beam.ml b/subsystem/karuta/Beam.ml index 82ae827..e0def90 100644 --- a/subsystem/karuta/Beam.ml +++ b/subsystem/karuta/Beam.ml @@ -8,12 +8,14 @@ module Error = struct let malformed () = condition "malformed-beam-program" - "A beam program is not {Module, Function, Beam, #{Name => Domain}} of binaries" empty + "A beam program is not {Module, Beam, #{Name => Domain}} of binaries" empty let not_a_program () = condition "not-a-beam-program" "The evaluator was given a program of another kind" empty - let inputs () = condition "beam-program-inputs" "A beam program takes no inputs" empty + let inputs () = + condition "beam-program-inputs" + "A beam program takes at most one input, of at most one tuple: what its caller knows" empty let failed message = condition "beam-failed" "The BEAM node failed to answer a call" @@ -79,7 +81,6 @@ let name = "karuta" type program = { module_: string; - function_: string; beam: string; heading: Protocols.Schematics.relation_description } @@ -90,12 +91,11 @@ let decode source = | Concepts.Value.String domain -> Some {Protocols.Schematics.domain; provenance= []} | Concepts.Value.Integer _ -> None in - match Translator.read 4 source with - | Some ([module_; function_; beam], attributes) - when String.length module_ <= 0xffff && String.length function_ <= 0xffff -> + match Translator.read 3 source with + | Some ([module_; beam], attributes) when String.length module_ <= 0xffff -> let heading = BatMap.String.filter_map domain attributes in if BatMap.String.cardinal heading = BatMap.String.cardinal attributes then - Ok (Beam {module_; function_; beam; heading}) + Ok (Beam {module_; beam; heading}) else Error (Error.malformed ()) | _ -> Error (Error.malformed ()) @@ -104,19 +104,22 @@ let decode source = can call back into RNT, and so on, as deep as the calls nest. RNT asks the node: - - h run every loaded rnt_init/0 -> o | e - - i Id:64 M:16 Module F:16 Function B:32 Beam - start Module:Function() from Beam + - h run every loaded rnt-init -> o | e + - i Id:64 M:16 Module B:32 Beam [Bound] + start Module's query from Beam - f Id:64 Limit:32 the next batch of it -> b | e - c Id:64 forget it The node asks RNT: - D Path Evaluator:16 Source define a program at Path -> o | e - - X Path invoke the program at Path -> r Id:64 | e + - X Path [Bound] invoke what is at Path -> r Id:64 | e - E Evaluator:16 Source invoke a program of no path -> r Id:64 | e - N Id:64 Limit:32 the next batch of its result -> b | e - C Id:64 release that result A Path is Count:16 then each segment as Length:16 Segment, and a - batch b is Exhausted:8 then each tuple as Size:32 term_to_binary. *) + batch b is Exhausted:8 then each tuple as Size:32 term_to_binary. + Bound, when present, is the tuple of the attributes the caller + already knows as term_to_binary, which is how a procedural program, + one that can only check what it is given, gets called. *) module Make (T : TRANSPORT) = struct (* [root] is borrowed, not held: the evaluator lives under it, so holding it would keep both alive forever. [cursors] are the @@ -132,7 +135,7 @@ module Make (T : TRANSPORT) = struct module Request = struct type t = | Define of string list * string * string - | Invoke of string list + | Invoke of string list * Concepts.Tuple.t option | Evaluate of string * string | Next of int * int | Close of int @@ -165,7 +168,13 @@ module Make (T : TRANSPORT) = struct | 'E' -> let evaluator = sized () in Some (Evaluate (evaluator, String.sub message !at (length - !at))) - | 'X' -> finished (Invoke (path ())) + | 'X' -> ( + let path = path () in + if !at = length then Some (Invoke (path, None)) + else + match Translator.decode (String.sub message !at (length - !at)) with + | Ok bound -> Some (Invoke (path, Some bound)) + | Error _ -> None ) | 'N' -> let id = u64 () in finished (Next (id, u32 ())) @@ -216,14 +225,17 @@ module Make (T : TRANSPORT) = struct Error (Error.program_taken (Kernel.Path.of_list path)) | Error c -> Protocols.Handle.release program; Error c ) - (* Runs [program], which it releases, keeping a cursor on the result - for the node to read. *) - let invoke node program = + (* Runs [target], which it releases, keeping a cursor on the result + for the node to read: a program's result given [inputs], or the + relation itself when [target] is not a program. *) + let invoke node ?(inputs = []) target = let open Utilities.Result in let* relation = - Protocols.Handle.releasing program (fun () -> - let* executable = Protocols.Executable.require program in - Protocols.Executable.invoke executable [] ~within:node.root ) + match Protocols.Executable.from target with + | None -> Ok target + | Some executable -> + Protocols.Handle.releasing target (fun () -> + Protocols.Executable.invoke executable inputs ~within:node.root ) in match Protocols.Enumerable.cursor relation with | Error c -> Protocols.Handle.release relation; Error c @@ -243,6 +255,19 @@ module Make (T : TRANSPORT) = struct if batch.exhausted then forget node id; Ok (batch_message batch) + (* What a caller already knows, as the one-tuple relation a program + is invoked with. *) + let literal ({Concepts.Tuple.attributes; _} as tuple) = + let domain = function + | Concepts.Value.String _ -> "string" + | Concepts.Value.Integer _ -> "integer" + in + Kernel.EphemeralRelation.literal + (BatMap.String.map + (fun value -> {Protocols.Schematics.domain= domain value; provenance= []}) + attributes ) + [tuple] + let serve node request = let answer = function | Ok message -> T.send node.transport message @@ -250,8 +275,15 @@ module Make (T : TRANSPORT) = struct in match request with | Request.Define (path, evaluator, source) -> answer (define node path evaluator source) - | Request.Invoke path -> - answer (Result.bind (Kernel.Path.lookup node.root (Kernel.Path.of_list path)) (invoke node)) + | Request.Invoke (path, bound) -> + let inputs = Option.to_list (Option.map literal bound) in + let result = + Result.bind + (Kernel.Path.lookup node.root (Kernel.Path.of_list path)) + (invoke node ~inputs) + in + List.iter Protocols.Handle.release inputs; + answer result | Request.Evaluate (evaluator, source) -> answer (Result.bind (Kernel.Program.load node.root ~evaluator ~source) (invoke node)) | Request.Next (id, limit) -> answer (fetch node id limit) @@ -291,7 +323,7 @@ module Make (T : TRANSPORT) = struct let* () = serve node request in await node ) - (* Lets the node's rnt_init/0 functions define their programs. *) + (* Lets the node's rnt-init closures define their programs. *) let handshake node = let open Utilities.Result in let* () = T.send node.transport "h" in @@ -299,17 +331,15 @@ module Make (T : TRANSPORT) = struct match reply with `Done -> Ok () | `Batch _ -> Error (Error.unexpected ()) module Poll = struct - let invoke_message id {module_; function_; beam; _} = + let invoke_message id {module_; beam; _} bound = let buffer = Buffer.create (64 + String.length beam) in Buffer.add_char buffer 'i'; Buffer.add_int64_be buffer (Int64.of_int id); - List.iter - (fun name -> - Buffer.add_uint16_be buffer (String.length name); - Buffer.add_string buffer name ) - [module_; function_]; + Buffer.add_uint16_be buffer (String.length module_); + Buffer.add_string buffer module_; Buffer.add_int32_be buffer (Int32.of_int (String.length beam)); Buffer.add_string buffer beam; + Option.iter (fun tuple -> Buffer.add_string buffer (Translator.encode tuple)) bound; Buffer.contents buffer let fetch_message id limit = @@ -341,12 +371,25 @@ module Make (T : TRANSPORT) = struct method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self] end - let start node program = + let start node program bound = let poll = new t node in - T.send node.transport (invoke_message (Oo.id poll) program) + T.send node.transport (invoke_message (Oo.id poll) program bound) |> Result.map (fun () -> Protocols.Handle.make poll) end + (* The tuple a program is invoked with, if any: what its caller + already knows. It is read now, so the input is only borrowed. *) + let bound = function + | [] -> Ok None + | [input] -> ( + let open Utilities.Result in + let* _, tuples = Protocols.Relation.read input in + match tuples with + | [] -> Ok None + | [tuple] -> Ok (Some tuple) + | _ -> Error (Error.inputs ()) ) + | _ -> Error (Error.inputs ()) + class evaluator node = object (self) inherit Kernel.Lifecycle.counted @@ -365,14 +408,15 @@ module Make (T : TRANSPORT) = struct within:Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result = fun kind inputs ~within:_ -> - match kind, inputs with - | Beam program, [] -> - Ok - (Kernel.EphemeralRelation.instantiate program.heading - ~modes:(fun () -> Ok [Concepts.Mode.mode [] Concepts.Cardinality.Countable]) - (Kernel.EphemeralRelation.temporary program.heading) - (fun () -> Poll.start node program) ) - | Beam _, _ -> Error (Error.inputs ()) + match kind with + | Beam program -> + Result.map + (fun bound -> + Kernel.EphemeralRelation.instantiate program.heading + ~modes:(fun () -> Ok [Concepts.Mode.mode [] Concepts.Cardinality.Countable]) + (Kernel.EphemeralRelation.temporary program.heading) + (fun () -> Poll.start node program bound) ) + (bound inputs) | _ -> Error (Error.not_a_program ()) method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self] |