From 16370cdb0195305e80458bf0bce9441a8517f3d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ole=20Kr=C3=BCger?= Date: Fri, 29 Jul 2022 10:36:07 +0100 Subject: [PATCH] SCORU: WASM: Implement encoder/decoder for eval config --- src/lib_scoru_wasm/test/ast_generators.ml | 119 +++++++++++++- src/lib_scoru_wasm/test/ast_printer.ml | 113 +++++++++++++ src/lib_scoru_wasm/test/test_wasm_encoding.ml | 87 +++++++--- src/lib_scoru_wasm/wasm_encoding.ml | 153 ++++++++++++++++++ src/lib_scoru_wasm/wasm_encoding.mli | 15 ++ src/lib_tree_encoding/decoding.ml | 4 + src/lib_tree_encoding/decoding.mli | 5 + src/lib_tree_encoding/encoding.ml | 4 + src/lib_tree_encoding/encoding.mli | 5 + src/lib_tree_encoding/tree_encoding.ml | 16 ++ src/lib_tree_encoding/tree_encoding.mli | 5 + src/lib_webassembly/exec/eval.mli | 25 +++ src/lib_webassembly/runtime/input_buffer.mli | 34 ++-- 13 files changed, 548 insertions(+), 37 deletions(-) diff --git a/src/lib_scoru_wasm/test/ast_generators.ml b/src/lib_scoru_wasm/test/ast_generators.ml index b235f819eaf5..7b6580e17394 100644 --- a/src/lib_scoru_wasm/test/ast_generators.ml +++ b/src/lib_scoru_wasm/test/ast_generators.ml @@ -276,6 +276,16 @@ let vector_gen gen = Lwt.return @@ generate1 ~rand gen) (Int32.of_int len)) +let vector_z_gen gen = + let* len = int_range 0 10 in + let* seeds = small_list int in + return + (Lazy_vector.LwtZVector.create + ~produce_value:(fun ix -> + let rand = Random.State.make @@ Array.of_list (Z.to_int ix :: seeds) in + Lwt.return @@ generate1 ~rand gen) + (Z.of_int len)) + let result_type_gen = vector_gen value_type_gen let func_type_gen = @@ -350,15 +360,19 @@ let value_num_gen nt = | Types.I64Type -> map (fun x -> Values.I64 x) int64 | _ -> Stdlib.failwith "Float type not supported" -let global_value_gen ty = +let typed_value_gen ty = match ty with | Types.NumType nt -> map (fun n -> Values.Num n) (value_num_gen nt) | Types.RefType rt -> return @@ Values.Ref (Values.NullRef rt) | Types.VecType _ -> map (fun v -> Values.Vec v.Source.it) vec_gen +let value_gen = + let* value_type = value_type_gen in + typed_value_gen value_type + let global_gen = let* value_type = value_type_gen in - let* value = global_value_gen value_type in + let* value = typed_value_gen value_type in let* mt = oneofl [Types.Immutable; Types.Mutable] in let ty = Types.GlobalType (value_type, mt) in return @@ Global.alloc ty value @@ -398,7 +412,7 @@ let allocations_gen = let+ datas = datas_table_gen in Ast.{blocks; datas} -let module_gen ?module_reg () = +let module_ref_and_instance_gen ?module_reg () = let module_reg = match module_reg with | None -> Instance.ModuleMap.create () @@ -431,4 +445,101 @@ let module_gen ?module_reg () = } in Instance.update_module_ref module_ref module_ ; - return module_ + return (module_ref, module_) + +let module_gen ?module_reg () = + map snd (module_ref_and_instance_gen ?module_reg ()) + +let frame_gen ~module_reg = + let* inst, _ = module_ref_and_instance_gen ~module_reg () in + let+ locals = small_list (map ref value_gen) in + Eval.{inst; locals} + +let rec admin_instr'_gen ~module_reg depth = + let open Eval in + let from_block_gen = + let* block = block_label_gen in + let+ index = int32 in + From_block (block, index) + in + let plain_gen = + let+ instr = instr_gen in + Plain instr.it + in + let refer_gen = + let+ ref_ = ref_gen in + Refer ref_ + in + let invoke_gen = + let* inst, _ = module_ref_and_instance_gen ~module_reg () in + let+ func = func_gen inst in + Invoke func + in + let trapping_gen = + let+ msg = string_printable in + Trapping msg + in + let returning_gen = + let+ values = small_list value_gen in + Returning values + in + let breaking_gen = + let* index = int32 in + let+ values = small_list value_gen in + Breaking (index, values) + in + let label_gen = + let* index = int32 in + let* final_instrs = small_list instr_gen in + let* values = small_list value_gen in + let+ instrs = small_list (admin_instr_gen ~module_reg (depth - 1)) in + Label (index, final_instrs, (values, instrs)) + in + let frame_gen' = + let* index = int32 in + let* frame = frame_gen ~module_reg in + let* values = small_list value_gen in + let+ instrs = small_list (admin_instr_gen ~module_reg (depth - 1)) in + Frame (index, frame, (values, instrs)) + in + oneof + ([ + from_block_gen; + plain_gen; + refer_gen; + invoke_gen; + trapping_gen; + returning_gen; + breaking_gen; + ] + @ if depth > 0 then [label_gen; frame_gen'] else []) + +and admin_instr_gen ~module_reg depth = + map Source.(at no_region) (admin_instr'_gen ~module_reg depth) + +let admin_instr_gen ~module_reg = + let gen = admin_instr_gen ~module_reg in + sized_size (int_bound 3) gen + +let input_buffer_gen = + let gen_message = + let* rtype = int32 in + let* raw_level = int32 in + let* message_counter = map Z.of_int small_nat in + let+ payload = map Bytes.of_string (small_string ~gen:char) in + Input_buffer.{rtype; raw_level; message_counter; payload} + in + let* messages = vector_z_gen gen_message in + let+ num_elements = small_nat in + { + Input_buffer.content = Lazy_vector.Mutable.LwtZVector.of_immutable messages; + num_elements = Z.of_int num_elements; + } + +let config_gen ~host_funcs ~module_reg = + let* frame = frame_gen ~module_reg in + let* input = input_buffer_gen in + let* instrs = small_list (admin_instr_gen ~module_reg) in + let* values = small_list value_gen in + let+ budget = small_int in + Eval.{frame; input; code = (values, instrs); host_funcs; budget} diff --git a/src/lib_scoru_wasm/test/ast_printer.ml b/src/lib_scoru_wasm/test/ast_printer.ml index 3dfd8ec80fd6..0c8202dcd094 100644 --- a/src/lib_scoru_wasm/test/ast_printer.ml +++ b/src/lib_scoru_wasm/test/ast_printer.ml @@ -348,6 +348,11 @@ let pp_vector pp out v = let _ = Lwt_main.run @@ Lazy_vector.LwtInt32Vector.to_list v in Lazy_vector.LwtInt32Vector.pp pp out v +let pp_vector_z pp out v = + (* Force evaluation of the vector. *) + let _ = Lwt_main.run @@ Lazy_vector.LwtZVector.to_list v in + Lazy_vector.LwtZVector.pp pp out v + let pp_resul_type = pp_vector pp_value_type let pp_func_type out = function @@ -533,3 +538,111 @@ let pp_module out datas pp_allocations allocations + +let pp_frame out frame = + let open Eval in + let (Module_key key) = frame.inst.key in + Format.fprintf + out + "@[{module = %s;@;locals = %a;@;}@]" + key + (Format.pp_print_list pp_value) + (List.map ( ! ) frame.locals) + +let rec pp_admin_instr' out instr = + let open Eval in + match instr with + | From_block (block, index) -> + Format.fprintf + out + "From_block @[(%a,@; %li)@]" + pp_block_label + block + index + | Plain instr -> Format.fprintf out "Plain @[%a@]" pp_instr' instr + | Refer ref_ -> Format.fprintf out "Refer @[%a@]" pp_ref ref_ + | Invoke func -> Format.fprintf out "Invoke @[%a@]" pp_func func + | Trapping msg -> + Format.fprintf out "Trapping @[%a@]" Format.pp_print_string msg + | Returning values -> + Format.fprintf + out + "Returning @[%a@]" + (Format.pp_print_list pp_value) + values + | Breaking (index, values) -> + Format.fprintf + out + "Breaking @[(%li,@; %a)@]" + index + (Format.pp_print_list pp_value) + values + | Label (index, final_instrs, (values, instrs)) -> + Format.fprintf + out + "Label @[(%li,@; %a,@; %a,@; %a)@]" + index + (Format.pp_print_list pp_instr) + final_instrs + (Format.pp_print_list pp_value) + values + (Format.pp_print_list pp_admin_instr) + instrs + | Frame (index, frame, (values, instrs)) -> + Format.fprintf + out + "Frame @[(%li,@; %a,@; %a,@; %a)@]" + index + pp_frame + frame + (Format.pp_print_list pp_value) + values + (Format.pp_print_list pp_admin_instr) + instrs + +and pp_admin_instr out instr = pp_admin_instr' out instr.Source.it + +let pp_input_message out message = + let open Input_buffer in + Format.fprintf + out + "@[{rtype = %li;@;\ + raw_level = %li;@;\ + message_counter = %s;@;\ + payload = %a;@;\ + }@]" + message.rtype + message.raw_level + (Z.to_string message.message_counter) + Hex.pp + (Hex.of_bytes message.payload) + +let pp_input_buffer out input = + let open Input_buffer in + Format.fprintf + out + "@[{content = %a;@;num_elements = %s;@;}@]" + (pp_vector_z pp_input_message) + (Lazy_vector.Mutable.LwtZVector.snapshot input.content) + (Z.to_string input.num_elements) + +let pp_config out config = + let open Eval in + let values, instrs = config.code in + Format.fprintf + out + "@[{frame = %a;@;\ + input = %a;@;\ + instructions = %a;@;\ + values = %a;@;\ + budget = %i;@;\ + }@]" + pp_frame + config.frame + pp_input_buffer + config.input + (Format.pp_print_list pp_admin_instr) + instrs + (Format.pp_print_list pp_value) + values + config.budget diff --git a/src/lib_scoru_wasm/test/test_wasm_encoding.ml b/src/lib_scoru_wasm/test/test_wasm_encoding.ml index 7969172125c4..3ab3d4292ee4 100644 --- a/src/lib_scoru_wasm/test/test_wasm_encoding.ml +++ b/src/lib_scoru_wasm/test/test_wasm_encoding.ml @@ -121,9 +121,13 @@ let test_module_roundtrip () = let* () = assert_string_equal module1_str module2_str in assert_string_equal module2_str module3_str) -(** Test serialize/deserialize modules and compare trees. *) -let test_module_tree () = - let print = Format.asprintf "%a" Ast_printer.pp_module in +(** Test serialize/deserialize an encodable values and compare trees. + + More formally, test that for all values, encoding, decoding and + re-encoding yields the same tree. + *) +let test_generic_tree ~pp ~gen ~encoding = + let print = Format.asprintf "%a" pp in let open Lwt_result_syntax in let dummy_module_reg = (* It is ok to use a dummy here, because the module lookup (dereferenceing) @@ -131,41 +135,88 @@ let test_module_tree () = Instance.ModuleMap.create () in let lazy_dummy_module_reg = Lazy.from_val dummy_module_reg in - qcheck - ~print - (Ast_generators.module_gen ~module_reg:dummy_module_reg ()) - (fun module1 -> + let host_funcs = Host_funcs.empty () in + qcheck ~print (gen ~host_funcs ~module_reg:dummy_module_reg) (fun value1 -> let*! empty_tree = empty_tree () in (* We need to print here in order to force lazy bindings to be evaluated. *) - let _ = print module1 in + let _ = print value1 in let*! tree1 = Tree_encoding.encode - (Wasm_encoding.module_instance_encoding - ~module_reg:lazy_dummy_module_reg) - module1 + (encoding ~host_funcs ~module_reg:lazy_dummy_module_reg) + value1 empty_tree in - let*! module2 = + let*! value2 = Tree_encoding.decode - (Wasm_encoding.module_instance_encoding - ~module_reg:lazy_dummy_module_reg) + (encoding ~host_funcs ~module_reg:lazy_dummy_module_reg) tree1 in (* We need to print here in order to force lazy bindings to be evaluated. *) - let _ = print module2 in + let _ = print value2 in let*! tree2 = Tree_encoding.encode - (Wasm_encoding.module_instance_encoding - ~module_reg:lazy_dummy_module_reg) - module2 + (encoding ~host_funcs ~module_reg:lazy_dummy_module_reg) + value2 empty_tree in assert (Tree.equal tree1 tree2) ; return_unit) +(** Test serialize/deserialize modules and compare trees. *) +let test_module_tree () = + test_generic_tree + ~pp:Ast_printer.pp_module + ~gen:(fun ~host_funcs:_ ~module_reg -> + Ast_generators.module_gen ~module_reg ()) + ~encoding:(fun ~host_funcs:_ -> Wasm_encoding.module_instance_encoding) + +(** Test serialize/deserialize frames and compare trees. *) +let test_frame_tree () = + test_generic_tree + ~pp:Ast_printer.pp_frame + ~gen:(fun ~host_funcs:_ -> Ast_generators.frame_gen) + ~encoding:(fun ~host_funcs:_ -> Wasm_encoding.frame_encoding) + +(** Test serialize/deserialize input buffers and compare trees. *) +let test_input_buffer_tree () = + test_generic_tree + ~pp:Ast_printer.pp_input_buffer + ~gen:(fun ~host_funcs:_ ~module_reg:_ -> Ast_generators.input_buffer_gen) + ~encoding:(fun ~host_funcs:_ ~module_reg:_ -> + Wasm_encoding.input_buffer_encoding) + +(** Test serialize/deserialize values and compare trees. *) +let test_values_tree () = + test_generic_tree + ~pp:(Format.pp_print_list Ast_printer.pp_value) + ~gen:(fun ~host_funcs:_ ~module_reg:_ -> + QCheck2.Gen.list Ast_generators.value_gen) + ~encoding:(fun ~host_funcs:_ ~module_reg -> + Wasm_encoding.(values_encoding ~module_reg)) + +(** Test serialize/deserialize administrative instructions and compare trees. *) +let test_admin_instr_tree () = + test_generic_tree + ~pp:Ast_printer.pp_admin_instr + ~gen:(fun ~host_funcs:_ ~module_reg -> + Ast_generators.admin_instr_gen ~module_reg) + ~encoding:(fun ~host_funcs:_ -> Wasm_encoding.admin_instr_encoding) + +(** Test serialize/deserialize evaluation configuration and compare trees. *) +let test_config_tree () = + test_generic_tree + ~pp:Ast_printer.pp_config + ~gen:Ast_generators.config_gen + ~encoding:Wasm_encoding.config_encoding + let tests = [ tztest "Instruction roundtrip" `Quick test_instr_roundtrip; tztest "Module roundtrip" `Quick test_module_roundtrip; tztest "Module trees" `Quick test_module_tree; + tztest "Values trees" `Quick test_values_tree; + tztest "Admin_instr trees" `Quick test_admin_instr_tree; + tztest "Input_buffer trees" `Quick test_input_buffer_tree; + tztest "Frame trees" `Quick test_frame_tree; + tztest "Config trees" `Quick test_config_tree; ] diff --git a/src/lib_scoru_wasm/wasm_encoding.ml b/src/lib_scoru_wasm/wasm_encoding.ml index af77b8be2820..e99ad353b7b0 100644 --- a/src/lib_scoru_wasm/wasm_encoding.ml +++ b/src/lib_scoru_wasm/wasm_encoding.ml @@ -542,6 +542,8 @@ module Make (Tree_encoding : Tree_encoding.S) = struct (fun r -> Values.Ref r); ] + let values_encoding ~module_reg = list_encoding (value_encoding ~module_reg) + let memory_encoding = conv (fun (min, max, chunks) -> @@ -719,4 +721,155 @@ module Make (Tree_encoding : Tree_encoding.S) = struct (scope ["modules"] (ModuleMap.lazy_map (module_instance_encoding ~module_reg)))) + + let frame_encoding ~module_reg = + let locals_encoding = + list_encoding @@ conv ref ( ! ) @@ value_encoding ~module_reg + in + conv + (fun (inst, locals) -> Eval.{inst; locals}) + (fun Eval.{inst; locals} -> (inst, locals)) + (tup2 + ~flatten:true + (scope ["module"] (module_ref_encoding ~module_reg)) + (scope ["locals"] locals_encoding)) + + let rec admin_instr'_encoding ~module_reg = + let open Eval in + tagged_union + string_tag + [ + case + "From_block" + (tup2 + ~flatten:false + block_label_encoding + (value [] Data_encoding.int32)) + (function + | From_block (block, index) -> Some (block, index) | _ -> None) + (fun (block, index) -> From_block (block, index)); + case + "Plain" + Source.(conv (fun i -> i.it) (at no_region) instruction_encoding) + (function Plain x -> Some x | _ -> None) + (fun x -> Plain x); + case + "Refer" + (value_ref_encoding ~module_reg) + (function Refer x -> Some x | _ -> None) + (fun x -> Refer x); + case + "Invoke" + (function_encoding ~module_reg) + (function Invoke x -> Some x | _ -> None) + (fun x -> Invoke x); + case + "Trapping" + (value [] Data_encoding.string) + (function Trapping x -> Some x | _ -> None) + (fun x -> Trapping x); + case + "Returning" + (values_encoding ~module_reg) + (function Returning x -> Some x | _ -> None) + (fun x -> Returning x); + case + "Breaking" + (tup2 + ~flatten:false + (value [] Data_encoding.int32) + (values_encoding ~module_reg)) + (function + | Breaking (index, values) -> Some (index, values) | _ -> None) + (fun (index, values) -> Breaking (index, values)); + case + "Label" + (tup4 + ~flatten:false + (value [] Data_encoding.int32) + (list_encoding instruction_encoding) + (values_encoding ~module_reg) + (list_encoding (admin_instr_encoding ~module_reg))) + (function + | Label (index, final_instrs, (values, instrs)) -> + Some (index, final_instrs, values, instrs) + | _ -> None) + (fun (index, final_instrs, values, instrs) -> + Label (index, final_instrs, (values, instrs))); + case + "Frame" + (tup4 + ~flatten:false + (value [] Data_encoding.int32) + (frame_encoding ~module_reg) + (values_encoding ~module_reg) + (list_encoding (admin_instr_encoding ~module_reg))) + (function + | Frame (index, frame, (values, instrs)) -> + Some (index, frame, values, instrs) + | _ -> None) + (fun (index, frame, values, instrs) -> + Frame (index, frame, (values, instrs))); + ] + + and admin_instr_encoding ~module_reg = + conv + Source.(at no_region) + Source.(fun x -> x.it) + (delayed @@ fun () -> admin_instr'_encoding ~module_reg) + + let input_buffer_message_encoding = + conv_lwt + (fun (rtype, raw_level, message_counter, payload) -> + let open Lwt.Syntax in + let+ payload = C.to_bytes payload in + Input_buffer.{rtype; raw_level; message_counter; payload}) + (fun Input_buffer.{rtype; raw_level; message_counter; payload} -> + let payload = C.of_bytes payload in + Lwt.return (rtype, raw_level, message_counter, payload)) + (tup4 + ~flatten:true + (value ["rtype"] Data_encoding.int32) + (value ["raw-level"] Data_encoding.int32) + (value ["message-counter"] Data_encoding.z) + chunked_byte_vector) + + module InputBufferVec = Lazy_vector_encoding.Make (Lazy_vector.LwtZVector) + + let input_buffer_encoding = + conv + (fun (content, num_elements) -> + { + Input_buffer.content = + Lazy_vector.Mutable.LwtZVector.of_immutable content; + num_elements; + }) + (fun buffer -> + Input_buffer. + ( Lazy_vector.Mutable.LwtZVector.snapshot buffer.content, + buffer.num_elements )) + (tup2 + ~flatten:true + (scope + ["messages"] + (InputBufferVec.lazy_vector + (value [] Data_encoding.z) + input_buffer_message_encoding)) + (value ["num-messages"] Data_encoding.z)) + + let config_encoding ~host_funcs ~module_reg = + conv + (fun (frame, input, instrs, values, budget) -> + Eval.{frame; input; code = (values, instrs); host_funcs; budget}) + (fun Eval.{frame; input; code = values, instrs; budget; _} -> + (frame, input, instrs, values, budget)) + (tup5 + ~flatten:true + (scope ["frame"] (frame_encoding ~module_reg)) + (scope ["input"] input_buffer_encoding) + (scope + ["instructions"] + (list_encoding (admin_instr_encoding ~module_reg))) + (scope ["values"] (values_encoding ~module_reg)) + (value ["budget"] Data_encoding.int31)) end diff --git a/src/lib_scoru_wasm/wasm_encoding.mli b/src/lib_scoru_wasm/wasm_encoding.mli index 85aae716e443..54ae92015932 100644 --- a/src/lib_scoru_wasm/wasm_encoding.mli +++ b/src/lib_scoru_wasm/wasm_encoding.mli @@ -44,6 +44,9 @@ module Make (M : Tree_encoding.S) : sig val value_encoding : module_reg:Instance.module_reg Lazy.t -> Values.value t + val values_encoding : + module_reg:Instance.module_reg Lazy.t -> Values.value list t + val memory_encoding : Partial_memory.memory t val table_encoding : @@ -89,4 +92,16 @@ module Make (M : Tree_encoding.S) : sig module_reg:Instance.module_reg Lazy.t -> Instance.module_inst t val module_instances_encoding : Instance.module_reg t + + val input_buffer_encoding : Input_buffer.t t + + val admin_instr_encoding : + module_reg:Instance.module_reg Lazy.t -> Eval.admin_instr t + + val frame_encoding : module_reg:Instance.module_reg Lazy.t -> Eval.frame t + + val config_encoding : + host_funcs:Host_funcs.registry -> + module_reg:Instance.module_reg Lazy.t -> + Eval.config t end diff --git a/src/lib_tree_encoding/decoding.ml b/src/lib_tree_encoding/decoding.ml index 27d01acb5708..67d6002c065b 100644 --- a/src/lib_tree_encoding/decoding.ml +++ b/src/lib_tree_encoding/decoding.ml @@ -50,6 +50,8 @@ module type S = sig val lazy_mapping : ('i -> key) -> 'a t -> ('i -> 'a Lwt.t) t + val delayed : (unit -> 'a t) -> 'a t + val of_lwt : 'a Lwt.t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t @@ -106,6 +108,8 @@ module Make (T : Tree.S) : S with type tree = T.tree = struct } -> ('tag, 'a) case + let delayed f tree key = (f ()) tree key + let of_lwt lwt _tree _prefix = lwt let map f dec tree prefix = Lwt.map f (dec tree prefix) diff --git a/src/lib_tree_encoding/decoding.mli b/src/lib_tree_encoding/decoding.mli index 38bf255ccb3c..ef1e6d0dd24a 100644 --- a/src/lib_tree_encoding/decoding.mli +++ b/src/lib_tree_encoding/decoding.mli @@ -91,6 +91,11 @@ module type S = sig function to [Lazy_map.create]. *) val lazy_mapping : ('i -> key) -> 'a t -> ('i -> 'a Lwt.t) t + (** [delayed f] produces a tree decoder that delays evaluation of [f ()] until + the decoder is actually needed. This is required to allow for directly + recursive decoders. *) + val delayed : (unit -> 'a t) -> 'a t + (** [of_lwt p] lifts the promise [p] into a decoding value. *) val of_lwt : 'a Lwt.t -> 'a t diff --git a/src/lib_tree_encoding/encoding.ml b/src/lib_tree_encoding/encoding.ml index 0594374d2cef..55c52d8bec65 100644 --- a/src/lib_tree_encoding/encoding.ml +++ b/src/lib_tree_encoding/encoding.ml @@ -32,6 +32,8 @@ module type S = sig type -'a t + val delayed : (unit -> 'a t) -> 'a t + val contramap : ('a -> 'b) -> 'b t -> 'a t val contramap_lwt : ('a -> 'b Lwt.t) -> 'b t -> 'a t @@ -82,6 +84,8 @@ module Make (T : Tree.S) = struct let* v = value in enc v prefix tree + let delayed f x key tree = f () x key tree + let contramap f enc value = enc (f value) let contramap_lwt f enc value prefix tree = diff --git a/src/lib_tree_encoding/encoding.mli b/src/lib_tree_encoding/encoding.mli index d6a70ae18b84..d9408ab8f9b2 100644 --- a/src/lib_tree_encoding/encoding.mli +++ b/src/lib_tree_encoding/encoding.mli @@ -38,6 +38,11 @@ module type S = sig (** Represents a partial encoder for specific constructor of a sum-type. *) type ('tag, 'a) case + (** [delayed f] produces a tree encoder that delays evaluation of [f ()] until + the encoder is actually needed. This is required to allow for directly + recursive encoders. *) + val delayed : (unit -> 'a t) -> 'a t + (** [contramap f e] is contravariant map operation that creates a new decoder that maps its input using [f] before feeding it to [e]. *) val contramap : ('a -> 'b) -> 'b t -> 'a t diff --git a/src/lib_tree_encoding/tree_encoding.ml b/src/lib_tree_encoding/tree_encoding.ml index 408f1339c085..b60878054ae9 100644 --- a/src/lib_tree_encoding/tree_encoding.ml +++ b/src/lib_tree_encoding/tree_encoding.ml @@ -174,6 +174,8 @@ module type S = sig val option : 'a t -> 'a option t val with_self_reference : ('a Lazy.t -> 'a t) -> 'a t + + val delayed : (unit -> 'a t) -> 'a t end module Make (T : Tree.S) : S with type tree = T.tree = struct @@ -482,4 +484,18 @@ module Make (T : Tree.S) : S with type tree = T.tree = struct (* Intercepts the encoding and decoding steps to update the reference to the current module. *) conv set_current set_current (f (lazy (get_current ()))) + + let delayed f = + let enc = lazy (f ()) in + let encode = + E.delayed (fun () -> + let {encode; _} = Lazy.force enc in + encode) + in + let decode = + D.delayed (fun () -> + let {decode; _} = Lazy.force enc in + decode) + in + {encode; decode} end diff --git a/src/lib_tree_encoding/tree_encoding.mli b/src/lib_tree_encoding/tree_encoding.mli index 552b0672377b..3f8e1100f502 100644 --- a/src/lib_tree_encoding/tree_encoding.mli +++ b/src/lib_tree_encoding/tree_encoding.mli @@ -291,6 +291,11 @@ module type S = sig data-structures. Here, [f] is a function that takes the (lazy) self-reference as an argument and constructs an encoder. *) val with_self_reference : ('a Lazy.t -> 'a t) -> 'a t + + (** [delayed f] produces a tree encoder/decoder that delays evaluation of + [f ()] until the encoder or decoder is actually needed. This is required + to allow for directly recursive encoders/decoders. *) + val delayed : (unit -> 'a t) -> 'a t end (** Produces an encoder/decoder module with the provided map, vector and tree diff --git a/src/lib_webassembly/exec/eval.mli b/src/lib_webassembly/exec/eval.mli index 7dbfc1c9f6de..2ce6773ba6b6 100644 --- a/src/lib_webassembly/exec/eval.mli +++ b/src/lib_webassembly/exec/eval.mli @@ -23,3 +23,28 @@ val invoke : func_inst -> value list -> value list Lwt.t (* raises Trap *) + +type frame = {inst : module_ref; locals : value ref list} + +type code = value list * admin_instr list + +and admin_instr = admin_instr' Source.phrase + +and admin_instr' = + | From_block of Ast.block_label * int32 + | Plain of Ast.instr' + | Refer of ref_ + | Invoke of func_inst + | Trapping of string + | Returning of value list + | Breaking of int32 * value list + | Label of int32 * Ast.instr list * code + | Frame of int32 * frame * code + +type config = { + frame : frame; + input : input_inst; + code : code; + host_funcs : Host_funcs.registry; + budget : int; (* to model stack overflow *) +} diff --git a/src/lib_webassembly/runtime/input_buffer.mli b/src/lib_webassembly/runtime/input_buffer.mli index d00406021ba7..dcc272e0adc4 100644 --- a/src/lib_webassembly/runtime/input_buffer.mli +++ b/src/lib_webassembly/runtime/input_buffer.mli @@ -1,12 +1,6 @@ -(** This module implements a FIFO queue to model the input. The messages are +(** This module implements a FIFO queue to model the input. The messages are queued in an input_buffer in their order of appearance in the inbox. *) -(** An element of type t will have a content which is a lazy_vector of messages - and a pointer to the number of elements to be able to dequeue. At this point - there is no cleanup operation so an input_buffer content will likely have - more than [num_elements] messages (see #3340). *) -type t - type message = { rtype : int32; raw_level : int32; @@ -14,6 +8,16 @@ type message = { payload : bytes; } +(** An element of type t will have a content which is a lazy_vector of messages + and a pointer to the number of elements to be able to dequeue. At this point + there is no cleanup operation so an input_buffer content will likely have + more than [num_elements] messages (see #3340). *) + +type t = { + content : message Lazy_vector.Mutable.LwtZVector.t; + mutable num_elements : Z.t; +} + exception Cannot_store_an_earlier_message exception Dequeue_from_empty_queue @@ -21,22 +25,22 @@ exception Dequeue_from_empty_queue (** [alloc ()] returns an empty input_buffer. *) val alloc : unit -> t -(** [num_elements buffer] is the number of elements of [buffer]. - It is used by [dequeue] to pick the current message. Note that it is not +(** [num_elements buffer] is the number of elements of [buffer]. + It is used by [dequeue] to pick the current message. Note that it is not necessarily equal to the length of the content of the inbox (see #3340). *) val num_elements : t -> Z.t (* TODO: #3340 Note that op does not clean up the list. *) -(** [dequeue buffer] pops the current message from buffer and returns it. +(** [dequeue buffer] pops the current message from buffer and returns it. Note that the input buffer models a FIFO queue so the current message is - the oldest in the queue. If the queue is empty it raises + the oldest in the queue. If the queue is empty it raises [Dequeue_from_empty_queue]. *) val dequeue : t -> message Lwt.t -(** [enqueue buffer message] pushes the given [message] into the [buffer]. - Note that the message will have to have a higher raw_level/message_counter - than than the newest message in the queue. - If that fails it will raise the error [Cannot_store_an_earlier_message]. +(** [enqueue buffer message] pushes the given [message] into the [buffer]. + Note that the message will have to have a higher raw_level/message_counter + than than the newest message in the queue. + If that fails it will raise the error [Cannot_store_an_earlier_message]. *) val enqueue : t -> message -> unit Lwt.t -- GitLab