Add typed wire input and native executable builds
This commit is contained in:
11 files changed
+857
-8
No files matched your search
+215
-2
@@ -556,6 +556,208 @@ let emit_output_functions plan buffer =
|
||||
line buffer " let output_change_to_string (change : output_change) : string = Printf.sprintf \"%+d\" change");
|
||||
line buffer ""
|
||||
|
||||
let emit_wire_type_functions plan buffer info =
|
||||
let name = info.ti_name in
|
||||
let decode_failure what =
|
||||
Printf.sprintf
|
||||
" | other -> Delta_runtime.Failure (Printf.sprintf \"expected %s for a value of type %s but got %%s\" (Wire.to_string other))"
|
||||
what name
|
||||
in
|
||||
match Types.repr info.ti_ty with
|
||||
| Types.TInt ->
|
||||
line buffer (Printf.sprintf " let encode_%s (value : %s) : Wire.value = Wire.WInt value" name name);
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" let decode_%s (value : Wire.value) : %s Delta_runtime.outcome = match value with Wire.WInt number -> Delta_runtime.Success number%s"
|
||||
name name (decode_failure "an integer"))
|
||||
| Types.TBool ->
|
||||
line buffer (Printf.sprintf " let encode_%s (value : %s) : Wire.value = Wire.WBool value" name name);
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" let decode_%s (value : Wire.value) : %s Delta_runtime.outcome = match value with Wire.WBool truth -> Delta_runtime.Success truth%s"
|
||||
name name (decode_failure "a boolean"))
|
||||
| Types.TString ->
|
||||
line buffer (Printf.sprintf " let encode_%s (value : %s) : Wire.value = Wire.WString value" name name);
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" let decode_%s (value : Wire.value) : %s Delta_runtime.outcome = match value with Wire.WString text -> Delta_runtime.Success text%s"
|
||||
name name (decode_failure "a string"))
|
||||
| Types.TUnit ->
|
||||
line buffer (Printf.sprintf " let encode_%s (value : %s) : Wire.value = Wire.WUnit" name name);
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" let decode_%s (value : Wire.value) : %s Delta_runtime.outcome = match value with Wire.WUnit -> Delta_runtime.Success ()%s"
|
||||
name name (decode_failure "unit"))
|
||||
| Types.TTuple items -> (
|
||||
let count = List.length items in
|
||||
if count >= 2 then (
|
||||
let names = List.map type_name items in
|
||||
let pattern prefix =
|
||||
"[" ^ Util.join "; " (Util.list_init count (fun index -> indexed prefix (index + 1))) ^ "]"
|
||||
in
|
||||
line buffer (Printf.sprintf " let encode_%s (value : %s) : Wire.value =" name name);
|
||||
line buffer (Printf.sprintf " let %s = value in" ("(" ^ Util.join ", " (Util.list_init count (fun index -> indexed "v" (index + 1))) ^ ")"));
|
||||
line buffer
|
||||
(Printf.sprintf " Wire.WTuple [ %s ]"
|
||||
(Util.join "; "
|
||||
(Util.list_init count (fun index ->
|
||||
Printf.sprintf "encode_%s %s" (List.nth names index) (indexed "v" (index + 1))))));
|
||||
line buffer
|
||||
(Printf.sprintf " let decode_%s (value : Wire.value) : %s Delta_runtime.outcome =" name name);
|
||||
line buffer (Printf.sprintf " match value with");
|
||||
line buffer (Printf.sprintf " | Wire.WTuple %s ->" (pattern "v"));
|
||||
let rec chain index =
|
||||
if index > count then
|
||||
Printf.sprintf " Delta_runtime.Success (%s)"
|
||||
("(" ^ Util.join ", " (Util.list_init count (fun position -> indexed "x" (position + 1))) ^ ")")
|
||||
else
|
||||
Printf.sprintf " (match decode_%s %s with Delta_runtime.Failure message -> Delta_runtime.Failure message | Delta_runtime.Success %s ->\n%s)"
|
||||
(List.nth names (index - 1))
|
||||
(indexed "v" index)
|
||||
(indexed "x" index)
|
||||
(chain (index + 1))
|
||||
in
|
||||
line buffer (chain 1);
|
||||
line buffer (Printf.sprintf "%s" (decode_failure "a tuple of the right size"))))
|
||||
| Types.TRecord record_name -> (
|
||||
match Types.record_info plan.Graph.pl_records record_name with
|
||||
| None -> ()
|
||||
| Some record ->
|
||||
let fields = record.Types.ri_fields in
|
||||
line buffer (Printf.sprintf " let encode_%s (value : %s) : Wire.value =" name name);
|
||||
line buffer
|
||||
(Printf.sprintf " Wire.WRecord [ %s ]"
|
||||
(Util.join "; "
|
||||
(List.map
|
||||
(fun (label, ty) ->
|
||||
Printf.sprintf "(%S, encode_%s value.%s)" label (type_name ty) label)
|
||||
fields)));
|
||||
line buffer
|
||||
(Printf.sprintf " let decode_%s (value : Wire.value) : %s Delta_runtime.outcome =" name name);
|
||||
line buffer " match value with";
|
||||
line buffer " | Wire.WRecord fields ->";
|
||||
let rec chain remaining =
|
||||
match remaining with
|
||||
| [] ->
|
||||
Printf.sprintf " Delta_runtime.Success { %s }"
|
||||
(Util.join "; "
|
||||
(List.map (fun (label, _) -> Printf.sprintf "%s = %s" label label) fields))
|
||||
| (label, ty) :: rest ->
|
||||
Printf.sprintf
|
||||
" (match Wire.field_value %S fields with Delta_runtime.Failure message -> Delta_runtime.Failure message | Delta_runtime.Success raw ->\n (match decode_%s raw with Delta_runtime.Failure message -> Delta_runtime.Failure message | Delta_runtime.Success %s ->\n%s))"
|
||||
label (type_name ty) label (chain rest)
|
||||
in
|
||||
line buffer (chain fields);
|
||||
line buffer (decode_failure "a record"))
|
||||
| Types.TCollection _ | Types.TArrow _ | Types.TVar _ -> ()
|
||||
|
||||
let emit_wire_functions plan buffer =
|
||||
List.iter (fun info -> emit_wire_type_functions plan buffer info) (collect_types plan);
|
||||
line buffer "";
|
||||
let input = input_type plan in
|
||||
line buffer
|
||||
(Printf.sprintf " let decode_row (value : Wire.value) : %s Delta_runtime.outcome = decode_%s value"
|
||||
(ocaml_ty input) (type_name input));
|
||||
line buffer "";
|
||||
line buffer " let encode_output (value : output) : Wire.value =";
|
||||
(if is_collection_output plan then (
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" Wire.WCollection (List.rev (List.rev_map (fun (key, item) -> (key, encode_%s item)) (Delta_runtime.Pure_map.bindings value)))"
|
||||
(type_name (output_value_type plan))))
|
||||
else line buffer " Wire.WInt value");
|
||||
line buffer "";
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" let decode_batch_op (op : Wire.op) : batch_op Delta_runtime.outcome =\n match op with\n | Wire.WInsert (key, value) -> (match decode_%s value with Delta_runtime.Failure message -> Delta_runtime.Failure message | Delta_runtime.Success row -> Delta_runtime.Success (Insert (key, row)))\n | Wire.WRemove key -> Delta_runtime.Success (Remove key)\n | Wire.WReplace (key, value) -> (match decode_%s value with Delta_runtime.Failure message -> Delta_runtime.Failure message | Delta_runtime.Success row -> Delta_runtime.Success (Replace (key, row)))"
|
||||
(type_name input) (type_name input));
|
||||
line buffer ""
|
||||
|
||||
let emit_driver plan buffer =
|
||||
let input = ocaml_ty (input_type plan) in
|
||||
line buffer "";
|
||||
line buffer "let () =";
|
||||
line buffer " let input_file = ref None in";
|
||||
line buffer " let updates_file = ref None in";
|
||||
line buffer " let print_result = ref false in";
|
||||
line buffer " let stats = ref false in";
|
||||
line buffer " let trace = ref false in";
|
||||
line buffer " let fail message = prerr_endline (\"error: \" ^ message); exit 1 in";
|
||||
line buffer " let usage message = prerr_endline (\"usage: \" ^ message); exit 2 in";
|
||||
line buffer " let rec parse_arguments arguments =";
|
||||
line buffer " match arguments with";
|
||||
line buffer " | [] -> ()";
|
||||
line buffer " | \"--input\" :: file :: rest -> input_file := Some file; parse_arguments rest";
|
||||
line buffer " | \"--updates\" :: file :: rest -> updates_file := Some file; parse_arguments rest";
|
||||
line buffer " | \"--print-result\" :: rest -> print_result := true; parse_arguments rest";
|
||||
line buffer " | \"--stats\" :: rest -> stats := true; parse_arguments rest";
|
||||
line buffer " | \"--trace\" :: rest -> trace := true; parse_arguments rest";
|
||||
line buffer " | flag :: _ -> usage (\"unknown option \" ^ flag)";
|
||||
line buffer " in";
|
||||
line buffer " parse_arguments (List.tl (Array.to_list Sys.argv));";
|
||||
line buffer " let started = Sys.time () in";
|
||||
line buffer " let rows =";
|
||||
line buffer " match !input_file with";
|
||||
line buffer " | None -> usage \"the --input FILE option is required\"";
|
||||
line buffer " | Some file -> (";
|
||||
line buffer " match Wire.read_file file with";
|
||||
line buffer " | Delta_runtime.Failure message -> fail message";
|
||||
line buffer " | Delta_runtime.Success text -> (";
|
||||
line buffer " match Wire.parse_input text with";
|
||||
line buffer " | Delta_runtime.Failure message -> fail (file ^ \": \" ^ message)";
|
||||
line buffer
|
||||
(Printf.sprintf
|
||||
" | Delta_runtime.Success entries ->\n let rec decode acc pending =\n match pending with\n | [] -> List.rev acc\n | (key, value) :: rest ->\n (match Query.decode_row value with\n | Delta_runtime.Failure message ->\n fail (Printf.sprintf \"%%s: key %%d: %%s\" file key message)\n | Delta_runtime.Success row ->\n if Delta_runtime.Pure_map.mem key (List.fold_left (fun map (key, _) -> Delta_runtime.Pure_map.add key () map) Delta_runtime.Pure_map.empty acc) then\n fail (Printf.sprintf \"%%s: duplicate key %%d\" file key)\n else decode ((key, row) :: acc) rest)\n in\n decode [] entries));");
|
||||
line buffer " in";
|
||||
line buffer
|
||||
(Printf.sprintf " let state = ref (Query.init (rows : (int * %s) list)) in" input);
|
||||
line buffer " let init_seconds = Sys.time () -. started in";
|
||||
line buffer " let init_counters = Delta_runtime.copy_counters (Query.counters ()) in";
|
||||
line buffer " Query.reset_counters ();";
|
||||
line buffer " let minor_words_before = Gc.minor_words () in";
|
||||
line buffer " let update_seconds = ref 0.0 in";
|
||||
line buffer " (match !updates_file with";
|
||||
line buffer " | None -> ()";
|
||||
line buffer " | Some file -> (";
|
||||
line buffer " match Wire.read_file file with";
|
||||
line buffer " | Delta_runtime.Failure message -> fail message";
|
||||
line buffer " | Delta_runtime.Success text -> (";
|
||||
line buffer " match Wire.parse_updates text with";
|
||||
line buffer " | Delta_runtime.Failure message -> fail (file ^ \": \" ^ message)";
|
||||
line buffer " | Delta_runtime.Success batches ->";
|
||||
line buffer " List.iteri";
|
||||
line buffer " (fun index batch ->";
|
||||
line buffer " let rec decode acc pending =";
|
||||
line buffer " match pending with";
|
||||
line buffer " | [] -> List.rev acc";
|
||||
line buffer " | op :: rest -> (";
|
||||
line buffer " match Query.decode_batch_op op with";
|
||||
line buffer " | Delta_runtime.Failure message ->";
|
||||
line buffer
|
||||
" fail (Printf.sprintf \"%s: batch %d: %s\" file (index + 1) message)";
|
||||
line buffer " | Delta_runtime.Success operation -> decode (operation :: acc) rest)";
|
||||
line buffer " in";
|
||||
line buffer " let operations = decode [] batch in";
|
||||
line buffer " let before = Sys.time () in";
|
||||
line buffer " (match Query.apply_batch !state operations with";
|
||||
line buffer " | Delta_runtime.Failure message ->";
|
||||
line buffer
|
||||
" fail (Printf.sprintf \"%s: batch %d: %s\" file (index + 1) message)";
|
||||
line buffer " | Delta_runtime.Success (next, _) ->";
|
||||
line buffer " state := next;";
|
||||
line buffer " update_seconds := !update_seconds +. (Sys.time () -. before);";
|
||||
line buffer " if !trace then";
|
||||
line buffer
|
||||
" print_endline (Wire.to_string (Query.encode_output (Query.result next)))))";
|
||||
line buffer " batches)));";
|
||||
line buffer " let minor_words_after = Gc.minor_words () in";
|
||||
line buffer " if !print_result then";
|
||||
line buffer " print_endline (Wire.to_string (Query.encode_output (Query.result !state)));";
|
||||
line buffer " if !stats then";
|
||||
line buffer
|
||||
" Printf.eprintf \"init_counters: %s\\nupdate_counters: %s\\ninit_seconds: %.6f\\nupdate_seconds: %.6f\\nminor_words: %.0f\\n\" (Delta_runtime.counters_to_string init_counters) (Delta_runtime.counters_to_string (Query.counters ())) init_seconds !update_seconds (minor_words_after -. minor_words_before);";
|
||||
line buffer " exit 0"
|
||||
|
||||
let emit_signature plan buffer =
|
||||
line buffer " type state";
|
||||
line buffer " type output";
|
||||
@@ -570,6 +772,10 @@ let emit_signature plan buffer =
|
||||
line buffer " val apply_output_change : output -> output_change -> output";
|
||||
line buffer " val output_to_string : output -> string";
|
||||
line buffer " val output_change_to_string : output_change -> string";
|
||||
line buffer
|
||||
(Printf.sprintf " val decode_row : Wire.value -> %s Delta_runtime.outcome" (ocaml_ty (input_type plan)));
|
||||
line buffer " val encode_output : output -> Wire.value";
|
||||
line buffer " val decode_batch_op : Wire.op -> batch_op Delta_runtime.outcome";
|
||||
line buffer " val counters : unit -> Delta_runtime.counters";
|
||||
line buffer " val reset_counters : unit -> unit"
|
||||
|
||||
@@ -660,6 +866,7 @@ let emit_update_functions plan buffer =
|
||||
(Printf.sprintf
|
||||
" %s update_%d (state : state) (key : int) (up_old : %s option) (up_new : %s option) : state ="
|
||||
keyword node.Graph.n_id (ocaml_ty input_element) (ocaml_ty input_element));
|
||||
line buffer " Delta_runtime.count_changed_key query_counters;";
|
||||
match node.Graph.n_kind with
|
||||
| Graph.Source ->
|
||||
line buffer
|
||||
@@ -843,11 +1050,12 @@ let emit_structure plan buffer =
|
||||
emit_init plan buffer;
|
||||
emit_result plan buffer;
|
||||
emit_output_functions plan buffer;
|
||||
emit_wire_functions plan buffer;
|
||||
line buffer " let counters () = Delta_runtime.copy_counters query_counters";
|
||||
line buffer "";
|
||||
line buffer " let reset_counters () = Delta_runtime.reset_counters query_counters"
|
||||
|
||||
let program_to_string plan =
|
||||
let module_to_string plan =
|
||||
let buffer = Buffer.create 8192 in
|
||||
emit_declarations buffer plan;
|
||||
List.iter (fun info -> emit_type_functions buffer plan info) (collect_types plan);
|
||||
@@ -860,4 +1068,9 @@ let program_to_string plan =
|
||||
line buffer "end";
|
||||
Buffer.contents buffer
|
||||
|
||||
|
||||
let program_to_string plan =
|
||||
let module_source = module_to_string plan in
|
||||
let buffer = Buffer.create (String.length module_source + 4096) in
|
||||
Buffer.add_string buffer module_source;
|
||||
emit_driver plan buffer;
|
||||
Buffer.contents buffer
|
||||
Reference in new issue
Block a user