From 98a2fddfe7518d56dd24e4c96bf8e74d802b0540 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ole=20Kr=C3=BCger?= Date: Tue, 26 Jul 2022 11:00:45 +0100 Subject: [PATCH] SCORU: WASM: Make module references explicit --- src/lib_scoru_wasm/host_funcs.ml | 2 +- src/lib_scoru_wasm/host_funcs.mli | 2 +- src/lib_scoru_wasm/test/ast_generators.ml | 23 ++- src/lib_scoru_wasm/test/test_input.ml | 20 +- src/lib_scoru_wasm/test/test_wasm_encoding.ml | 45 +++- src/lib_scoru_wasm/tree_encoding_decoding.ml | 3 + src/lib_scoru_wasm/tree_encoding_decoding.mli | 2 + src/lib_scoru_wasm/wasm_encoding.ml | 192 +++++++++--------- src/lib_scoru_wasm/wasm_encoding.mli | 31 ++- src/lib_webassembly/bin/script/run.ml | 74 +++++-- src/lib_webassembly/exec/eval.ml | 165 +++++++++------ src/lib_webassembly/exec/eval.mli | 5 +- src/lib_webassembly/host/env.ml | 3 +- src/lib_webassembly/runtime/host_funcs.ml | 2 +- src/lib_webassembly/runtime/host_funcs.mli | 2 +- src/lib_webassembly/runtime/instance.ml | 35 +++- 16 files changed, 385 insertions(+), 221 deletions(-) diff --git a/src/lib_scoru_wasm/host_funcs.ml b/src/lib_scoru_wasm/host_funcs.ml index 9320566785d9..e5febe7ad152 100644 --- a/src/lib_scoru_wasm/host_funcs.ml +++ b/src/lib_scoru_wasm/host_funcs.ml @@ -31,7 +31,7 @@ exception Bad_input let aux_write_input_in_memory ~input_buffer ~module_inst ~rtype_offset ~level_offset ~id_offset ~dst ~max_bytes = let open Lwt.Syntax in - let memories = !module_inst.memories in + let memories = module_inst.memories in let* {rtype; raw_level; message_counter; payload} = Input_buffer.dequeue input_buffer in diff --git a/src/lib_scoru_wasm/host_funcs.mli b/src/lib_scoru_wasm/host_funcs.mli index fb4ac90aa3f6..871a25802ddc 100644 --- a/src/lib_scoru_wasm/host_funcs.mli +++ b/src/lib_scoru_wasm/host_funcs.mli @@ -60,7 +60,7 @@ module Internal_for_tests : sig payload.*) val aux_write_input_in_memory : input_buffer:Tezos_webassembly_interpreter.Input_buffer.t -> - module_inst:Tezos_webassembly_interpreter.Instance.module_inst ref -> + module_inst:Tezos_webassembly_interpreter.Instance.module_inst -> rtype_offset:int32 -> level_offset:int32 -> id_offset:int32 -> diff --git a/src/lib_scoru_wasm/test/ast_generators.ml b/src/lib_scoru_wasm/test/ast_generators.ml index 2678bf5ae9d0..fda221495983 100644 --- a/src/lib_scoru_wasm/test/ast_generators.ml +++ b/src/lib_scoru_wasm/test/ast_generators.ml @@ -295,7 +295,7 @@ let func_gen current_module = let ast_func () = let* func_type = func_type_gen in let* func = func_gen in - return @@ Func.AstFunc (func_type, current_module (), func) + return @@ Func.AstFunc (func_type, current_module, func) in oneof [ @@ -397,19 +397,22 @@ let allocations_gen = let+ datas = datas_table_gen in Ast.{blocks; datas} -let module_gen () = - let current_module = ref None in - let get_current_module () = - match !current_module with - | Some c -> c - | None -> Stdlib.failwith "Current module not initialized" +let module_gen ?module_reg () = + let module_reg = + match module_reg with + | None -> Instance.ModuleMap.create () + | Some module_reg -> module_reg + in + let* module_name = string_printable in + let module_ref = + Instance.(alloc_module_ref (Module_key module_name) module_reg) in let* types = vector_gen func_type_gen in - let* funcs = vector_gen @@ func_gen get_current_module in + let* funcs = vector_gen @@ func_gen module_ref in let* tables = vector_gen table_gen in let* memories = vector_gen memory_gen in let* globals = vector_gen global_gen in - let* exports = map_gen (extern_gen get_current_module) in + let* exports = map_gen (extern_gen module_ref) in let* elems = vector_gen elems_gen in let* datas = vector_gen datas_gen in let* allocations = allocations_gen in @@ -426,5 +429,5 @@ let module_gen () = allocations; } in - current_module := Some (ref module_) ; + Instance.update_module_ref module_ref module_ ; return module_ diff --git a/src/lib_scoru_wasm/test/test_input.ml b/src/lib_scoru_wasm/test/test_input.ml index 48bdf6784a8b..8699f52fd9ac 100644 --- a/src/lib_scoru_wasm/test/test_input.ml +++ b/src/lib_scoru_wasm/test/test_input.ml @@ -93,15 +93,13 @@ let read_input () = } in assert (Input_buffer.num_elements input_buffer = Z.one) ; - let module_inst = - ref Tezos_webassembly_interpreter.Instance.empty_module_inst - in + let module_inst = Tezos_webassembly_interpreter.Instance.empty_module_inst in let memories = Tezos_webassembly_interpreter.Instance.Vector.cons memory - !module_inst.memories + module_inst.memories in - module_inst := {!module_inst with memories} ; + let module_inst = {module_inst with memories} in let* result = Host_funcs.Internal_for_tests.aux_write_input_in_memory ~input_buffer @@ -113,7 +111,7 @@ let read_input () = ~max_bytes:36000l in let* memory = - Tezos_webassembly_interpreter.Instance.Vector.get 0l !module_inst.memories + Tezos_webassembly_interpreter.Instance.Vector.get 0l module_inst.memories in assert (Input_buffer.num_elements input_buffer = Z.zero) ; assert (result = 5) ; @@ -156,14 +154,20 @@ let test_host_fun () = let host_funcs_registry = Tezos_webassembly_interpreter.Host_funcs.empty () in Host_funcs.register_host_funcs host_funcs_registry ; - let* module_inst, result = + let module_reg = Instance.ModuleMap.create () in + let module_ref = + Instance.(alloc_module_ref (Module_key "test") ~module_inst module_reg) + in + + let* result = Eval.invoke + ~caller:module_ref host_funcs_registry - ~module_inst ~input Host_funcs.Internal_for_tests.read_input values in + let* module_inst = Instance.resolve_module_ref module_ref in let* memory = Tezos_webassembly_interpreter.Lazy_vector.LwtInt32Vector.get 0l diff --git a/src/lib_scoru_wasm/test/test_wasm_encoding.ml b/src/lib_scoru_wasm/test/test_wasm_encoding.ml index f844d50631d2..f5021ea2b5d2 100644 --- a/src/lib_scoru_wasm/test/test_wasm_encoding.ml +++ b/src/lib_scoru_wasm/test/test_wasm_encoding.ml @@ -33,6 +33,7 @@ open Tztest open Tezos_scoru_wasm +open Tezos_webassembly_interpreter let qcheck ?count ?print gen f = let open Lwt_result_syntax in @@ -89,15 +90,31 @@ let assert_string_equal s1 s2 = let test_module_roundtrip () = let print = Format.asprintf "%a" Ast_printer.pp_module in let open Lwt_result_syntax in - qcheck ~print (Ast_generators.module_gen ()) (fun module1 -> + let dummy_module_reg = + (* It is ok to use a dummy here, because the module lookup (dereferenceing) + is not important when encoding or decoding. *) + 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 -> (* We need to print here in order to force lazy bindings to be evaluated. *) let module1_str = print module1 in let*! module2 = - encode_decode Wasm_encoding.module_instance_encoding module1 + encode_decode + (Wasm_encoding.module_instance_encoding + ~module_reg:lazy_dummy_module_reg) + module1 in let module2_str = print module2 in let*! module3 = - encode_decode Wasm_encoding.module_instance_encoding module2 + encode_decode + (Wasm_encoding.module_instance_encoding + ~module_reg:lazy_dummy_module_reg) + module2 in let module3_str = print module3 in (* Check that modules match. *) @@ -108,24 +125,38 @@ let test_module_roundtrip () = let test_module_tree () = let print = Format.asprintf "%a" Ast_printer.pp_module in let open Lwt_result_syntax in - qcheck ~print (Ast_generators.module_gen ()) (fun module1 -> + let dummy_module_reg = + (* It is ok to use a dummy here, because the module lookup (dereferenceing) + is not important when encoding or decoding. *) + 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*! empty_tree = empty_tree () in (* We need to print here in order to force lazy bindings to be evaluated. *) let _ = print module1 in let*! tree1 = Merklizer.encode - Wasm_encoding.module_instance_encoding + (Wasm_encoding.module_instance_encoding + ~module_reg:lazy_dummy_module_reg) module1 empty_tree in let*! module2 = - Merklizer.decode Wasm_encoding.module_instance_encoding tree1 + Merklizer.decode + (Wasm_encoding.module_instance_encoding + ~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*! tree2 = Merklizer.encode - Wasm_encoding.module_instance_encoding + (Wasm_encoding.module_instance_encoding + ~module_reg:lazy_dummy_module_reg) module2 empty_tree in diff --git a/src/lib_scoru_wasm/tree_encoding_decoding.ml b/src/lib_scoru_wasm/tree_encoding_decoding.ml index df868c86e5e6..f2edf1acf39f 100644 --- a/src/lib_scoru_wasm/tree_encoding_decoding.ml +++ b/src/lib_scoru_wasm/tree_encoding_decoding.ml @@ -136,6 +136,8 @@ module type S = sig module Make (Map : Lwt_map) : S with type 'a map := 'a Map.t module NameMap : S with type 'a map := 'a Instance.NameMap.t + + module ModuleMap : S with type 'a map := 'a Instance.ModuleMap.Map.t end module Lazy_vector_encoding_decoding : sig @@ -359,6 +361,7 @@ module Make (T : Tree.S) : S with type tree = T.tree = struct end module NameMap = Make (Instance.NameMap) + module ModuleMap = Make (Instance.ModuleMap.Map) end module Lazy_vector_encoding_decoding = struct diff --git a/src/lib_scoru_wasm/tree_encoding_decoding.mli b/src/lib_scoru_wasm/tree_encoding_decoding.mli index 443baa3f8b5f..5a87e1645172 100644 --- a/src/lib_scoru_wasm/tree_encoding_decoding.mli +++ b/src/lib_scoru_wasm/tree_encoding_decoding.mli @@ -217,6 +217,8 @@ module type S = sig module Make (Map : Lwt_map) : S with type 'a map := 'a Map.t module NameMap : S with type 'a map := 'a Instance.NameMap.t + + module ModuleMap : S with type 'a map := 'a Instance.ModuleMap.Map.t end module Lazy_vector_encoding_decoding : sig diff --git a/src/lib_scoru_wasm/wasm_encoding.ml b/src/lib_scoru_wasm/wasm_encoding.ml index 7a6e6adbcd31..d05e2379f3c6 100644 --- a/src/lib_scoru_wasm/wasm_encoding.ml +++ b/src/lib_scoru_wasm/wasm_encoding.ml @@ -451,7 +451,14 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct "type_result" (value [] Interpreter_encodings.Types.value_type_encoding))) - let function_encoding ~current_module = + let module_ref_encoding ~module_reg = + conv + (fun key -> + Instance.{key = Module_key key; registry = Lazy.force module_reg}) + (fun Instance.{key = Module_key key; _} -> key) + (value [] Data_encoding.string) + + let function_encoding ~module_reg = tagged_union string_tag [ @@ -467,37 +474,34 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (fun (func_type, name) -> Func.HostFunc (func_type, name)); case "Native" - (tup4 + (tup5 ~flatten:false function_type_encoding + (scope ["module"] (module_ref_encoding ~module_reg)) (value ["ftype"] Interpreter_encodings.Ast.var_encoding) (lazy_vector_encoding "locals" (value [] Interpreter_encodings.Types.value_type_encoding)) block_label_encoding) (function - | Func.AstFunc - (type_, _current_module, {at = _; it = {ftype; locals; body}}) + | Func.AstFunc (type_, module_, {at = _; it = {ftype; locals; body}}) -> - (* Note that we do not encode [_current_module] to avoid - infinite recursion. Instead we use the given self-reference - [current_module] on decoding. *) - Some (type_, ftype, locals, body) + Some (type_, module_, ftype, locals, body) | _ -> None) - (fun (type_, ftype, locals, body) -> + (fun (type_, module_, ftype, locals, body) -> let func = Source.{at = no_region; it = {Ast.ftype; locals; body}} in - Func.AstFunc (type_, Lazy.force current_module, func)); + Func.AstFunc (type_, module_, func)); ] - let value_ref_encoding ~current_module = + let value_ref_encoding ~module_reg = tagged_union string_tag [ case "FuncRef" - (function_encoding ~current_module) + (function_encoding ~module_reg) (fun val_ref -> match val_ref with | Instance.FuncRef func_inst -> Some func_inst @@ -515,7 +519,7 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (fun v -> Values.NullRef v); ] - let value_encoding ~current_module = + let value_encoding ~module_reg = tagged_union string_tag [ @@ -531,7 +535,7 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (fun v -> Values.Vec v); case "RefType" - (value_ref_encoding ~current_module) + (value_ref_encoding ~module_reg) (function Values.Ref r -> Some r | _ -> None) (fun r -> Values.Ref r); ] @@ -550,7 +554,7 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (value_option ["max"] Data_encoding.int32) (scope ["chunks"] chunked_byte_vector)) - let table_encoding ~current_module = + let table_encoding ~module_reg = conv (fun (min, max, vector, ref_type) -> let table_type = Types.TableType ({min; max}, ref_type) in @@ -562,10 +566,10 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct ~flatten:false (value ["min"] Data_encoding.int32) (value_option ["max"] Data_encoding.int32) - (lazy_vector_encoding "refs" (value_ref_encoding ~current_module)) + (lazy_vector_encoding "refs" (value_ref_encoding ~module_reg)) (value ["ref-type"] Interpreter_encodings.Types.ref_type_encoding)) - let global_encoding ~current_module = + let global_encoding ~module_reg = conv (fun (type_, value) -> let ty = Types.GlobalType (Values.type_of_value value, type_) in @@ -577,41 +581,41 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (tup2 ~flatten:false (value ["type"] Interpreter_encodings.Types.mutability_encoding) - (scope ["value"] (value_encoding ~current_module))) + (scope ["value"] (value_encoding ~module_reg))) let memory_instance_encoding = lazy_vector_encoding "memories" memory_encoding - let table_vector_encoding ~current_module = - lazy_vector_encoding "tables" (table_encoding ~current_module) + let table_vector_encoding ~module_reg = + lazy_vector_encoding "tables" (table_encoding ~module_reg) - let global_vector_encoding ~current_module = - lazy_vector_encoding "globals" (global_encoding ~current_module) + let global_vector_encoding ~module_reg = + lazy_vector_encoding "globals" (global_encoding ~module_reg) let data_label_ref_encoding = conv (fun x -> ref x) (fun r -> !r) data_label_encoding - let function_vector_encoding ~current_module = - lazy_vector_encoding "functions" (function_encoding ~current_module) + let function_vector_encoding ~module_reg = + lazy_vector_encoding "functions" (function_encoding ~module_reg) let function_type_vector_encoding = lazy_vector_encoding "types" function_type_encoding - let value_ref_vector_encoding ~current_module = - lazy_vector_encoding "refs" (value_ref_encoding ~current_module) + let value_ref_vector_encoding ~module_reg = + lazy_vector_encoding "refs" (value_ref_encoding ~module_reg) - let extern_map_encoding ~current_module = + let extern_map_encoding ~module_reg = lazy_map (tagged_union string_tag [ case "ExternFunc" - (function_encoding ~current_module) + (function_encoding ~module_reg) (function Instance.ExternFunc x -> Some x | _ -> None) (fun x -> Instance.ExternFunc x); case "ExternTable" - (table_encoding ~current_module) + (table_encoding ~module_reg) (function Instance.ExternTable x -> Some x | _ -> None) (fun x -> Instance.ExternTable x); case @@ -621,18 +625,18 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (fun x -> Instance.ExternMemory x); case "ExternGlobal" - (global_encoding ~current_module) + (global_encoding ~module_reg) (function Instance.ExternGlobal x -> Some x | _ -> None) (fun x -> Instance.ExternGlobal x); ]) - let value_ref_vector_vector_encoding ~current_module = + let value_ref_vector_vector_encoding ~module_reg = lazy_vector_encoding "elements" (conv (fun x -> ref x) (fun r -> !r) - (value_ref_vector_encoding ~current_module)) + (value_ref_vector_encoding ~module_reg)) let data_instance_encoding = lazy_vector_encoding "datas" data_label_ref_encoding @@ -651,65 +655,67 @@ module Make (Tree_encoding_decoding : Tree_encoding_decoding.S) = struct (fun {blocks; datas} -> (blocks, datas)) (tup2 ~flatten:false block_table_encoding datas_table_encoding) - let module_instance_encoding = - let open Lwt_syntax in - let gen_encoding current_module = - let current_module = Lazy.map (fun x -> ref x) current_module in - conv_lwt - (fun ( types, - funcs, - tables, - memories, - globals, - exports, - elems, - datas, - allocations ) -> - let open Lwt_syntax in - return - { - Instance.types; - funcs; - tables; - memories; - globals; - exports; - elems; - datas; - allocations; - }) - (fun { - Instance.types; - funcs; - tables; - memories; - globals; - exports; - elems; - datas; - allocations; - } -> - return - ( types, - funcs, - tables, - memories, - globals, - exports, - elems, - datas, - allocations )) - (tup9 - ~flatten:false - function_type_vector_encoding - (function_vector_encoding ~current_module) - (table_vector_encoding ~current_module) - memory_instance_encoding - (global_vector_encoding ~current_module) - (extern_map_encoding ~current_module) - (value_ref_vector_vector_encoding ~current_module) - data_instance_encoding - allocations_encoding) - in - scope ["module"] @@ with_self_reference gen_encoding + let module_instance_encoding ~module_reg = + conv + (fun ( types, + funcs, + tables, + memories, + globals, + exports, + elems, + datas, + allocations ) -> + { + Instance.types; + funcs; + tables; + memories; + globals; + exports; + elems; + datas; + allocations; + }) + (fun { + Instance.types; + funcs; + tables; + memories; + globals; + exports; + elems; + datas; + allocations; + } -> + ( types, + funcs, + tables, + memories, + globals, + exports, + elems, + datas, + allocations )) + (tup9 + ~flatten:false + function_type_vector_encoding + (function_vector_encoding ~module_reg) + (table_vector_encoding ~module_reg) + memory_instance_encoding + (global_vector_encoding ~module_reg) + (extern_map_encoding ~module_reg) + (value_ref_vector_vector_encoding ~module_reg) + data_instance_encoding + allocations_encoding) + + let module_instances_encoding = + with_self_reference (fun module_reg -> + conv + Instance.ModuleMap.of_immutable + Instance.ModuleMap.snapshot + (scope + ["modules"] + (Lazy_map_encoding_decoding.ModuleMap.lazy_map + (module_instance_encoding ~module_reg)))) end diff --git a/src/lib_scoru_wasm/wasm_encoding.mli b/src/lib_scoru_wasm/wasm_encoding.mli index 708be6a8f1c7..69dbba3b6b6d 100644 --- a/src/lib_scoru_wasm/wasm_encoding.mli +++ b/src/lib_scoru_wasm/wasm_encoding.mli @@ -37,50 +37,46 @@ module Make (M : Tree_encoding_decoding.S) : sig val instruction_encoding : Ast.instr t val function_encoding : - current_module:Instance.module_inst ref Lazy.t -> Instance.func_inst t + module_reg:Instance.module_reg Lazy.t -> Instance.func_inst t val value_ref_encoding : - current_module:Instance.module_inst ref Lazy.t -> Values.ref_ t + module_reg:Instance.module_reg Lazy.t -> Values.ref_ t - val value_encoding : - current_module:Instance.module_inst ref Lazy.t -> Values.value t + val value_encoding : module_reg:Instance.module_reg Lazy.t -> Values.value t val memory_encoding : Partial_memory.memory t val table_encoding : - current_module:Instance.module_inst ref Lazy.t -> Partial_table.table t + module_reg:Instance.module_reg Lazy.t -> Partial_table.table t - val global_encoding : - current_module:Instance.module_inst ref Lazy.t -> Global.global t + val global_encoding : module_reg:Instance.module_reg Lazy.t -> Global.global t val memory_instance_encoding : Partial_memory.memory Instance.Vector.t t val table_vector_encoding : - current_module:Instance.module_inst ref Lazy.t -> + module_reg:Instance.module_reg Lazy.t -> Partial_table.table Instance.Vector.t t val global_vector_encoding : - current_module:Instance.module_inst ref Lazy.t -> - Global.global Instance.Vector.t t + module_reg:Instance.module_reg Lazy.t -> Global.global Instance.Vector.t t val data_label_ref_encoding : Ast.data_label ref t val function_vector_encoding : - current_module:Instance.module_inst ref Lazy.t -> + module_reg:Instance.module_reg Lazy.t -> Instance.func_inst Instance.Vector.t t val function_type_vector_encoding : Types.func_type Instance.Vector.t t val value_ref_vector_encoding : - current_module:Instance.module_inst ref Lazy.t -> - Values.ref_ Instance.Vector.t t + module_reg:Instance.module_reg Lazy.t -> Values.ref_ Instance.Vector.t t val extern_map_encoding : - current_module:Instance.module_inst ref Lazy.t -> + module_reg:Instance.module_reg Lazy.t -> Instance.extern Instance.NameMap.t t val value_ref_vector_vector_encoding : - current_module:Instance.module_inst ref Lazy.t -> + module_reg:Instance.module_reg Lazy.t -> Values.ref_ Instance.Vector.t ref Instance.Vector.t t val block_table_encoding : Ast.block_table t @@ -89,5 +85,8 @@ module Make (M : Tree_encoding_decoding.S) : sig val allocations_encoding : Ast.allocations t - val module_instance_encoding : Instance.module_inst t + val module_instance_encoding : + module_reg:Instance.module_reg Lazy.t -> Instance.module_inst t + + val module_instances_encoding : Instance.module_reg t end diff --git a/src/lib_webassembly/bin/script/run.ml b/src/lib_webassembly/bin/script/run.ml index ba455f0f525b..84142a9529c5 100644 --- a/src/lib_webassembly/bin/script/run.ml +++ b/src/lib_webassembly/bin/script/run.ml @@ -330,10 +330,46 @@ let scripts : script Map.t ref = ref Map.empty let modules : Ast.module_ Map.t ref = ref Map.empty -let instances : Instance.module_inst Map.t ref = ref Map.empty +(* NOTE: See [instantiate_module] below on why this exists. *) +let unnamed_instance_counter = ref 0 + +(* NOTE: See [instantiate_module] below on why this exists. *) +let unnamed_instances : Instance.module_reg = Instance.ModuleMap.create () + +let instances : Instance.module_reg = Instance.ModuleMap.create () let registry : Instance.module_inst Map.t ref = ref Map.empty +let instantiate_module x_opt m imports = + let self = + match x_opt with + | None -> + (* The WASM REPL allows you to create modules without a name. The + intended use case is to define a module without a name and then + register it under one or more names later. + This mechanism used a slot "" for the temporary module. + Unfortunately, this doesn't work super well with our module + references because they require module keys (their names) to be + stable. E.g. multiple modules temporarily assigned as "" will + conflict given their module key will statically be "" regardless of + how many times it was rebound. + The solution is to bind to a unique temporary module each time the + module in question has no name. + *) + let index = !unnamed_instance_counter in + unnamed_instance_counter := !unnamed_instance_counter + 1 ; + Instance. + {registry = unnamed_instances; key = Module_key (Int.to_string index)} + | Some name -> Instance.{registry = instances; key = Module_key name.it} + in + Eval.init ~self host_funcs_registry m imports + +let bind_lazy module_reg name instance = + Option.iter + (fun name -> Instance.ModuleMap.set name.it instance module_reg) + name ; + Instance.ModuleMap.set "" instance module_reg + let bind map x_opt y = let map' = match x_opt with None -> !map | Some x -> Map.add x.it y !map in map := Map.add "" y map' @@ -351,7 +387,18 @@ let lookup_script = lookup "script" scripts let lookup_module = lookup "module" modules -let lookup_instance = lookup "module" instances +let lookup_instance name at = + let category = "instance" in + let key = match name with Some name -> name.it | None -> "" in + Lwt.catch + (fun () -> Instance.ModuleMap.get key instances) + (function + | Lazy_map.UnexpectedAccess -> + IO.error + at + (if key = "" then "no " ^ category ^ " defined" + else "unknown " ^ category ^ " " ^ key) + | exn -> raise exn) let lookup_registry module_name item_name = let* item_name = Lazy_vector.LwtInt32Vector.to_list item_name in @@ -377,7 +424,7 @@ let run_action act : Values.value list Lwt.t = let* () = trace_lwt ("Invoking function \"" ^ Ast.string_of_name name ^ "\"...") in - let inst = lookup_instance x_opt act.at in + let* inst = lookup_instance x_opt act.at in let* name = Lazy_vector.LwtInt32Vector.to_list name in let* export = Instance.export inst name in match export with @@ -392,7 +439,7 @@ let run_action act : Values.value list Lwt.t = Script.error v.at "wrong type of argument") vs ins_l ; - let+ _, result = + let+ result = Eval.invoke host_funcs_registry f (List.map (fun v -> v.it) vs) in result @@ -402,7 +449,7 @@ let run_action act : Values.value list Lwt.t = let* () = trace_lwt ("Getting global \"" ^ Ast.string_of_name name ^ "\"...") in - let inst = lookup_instance x_opt act.at in + let* inst = lookup_instance x_opt act.at in let* name = Lazy_vector.LwtInt32Vector.to_list name in let+ export = Instance.export inst name in match export with @@ -513,7 +560,7 @@ let run_assertion ass : unit Lwt.t = Lwt.try_bind (fun () -> let* imports = Import.link m in - Eval.init host_funcs_registry m imports) + instantiate_module None m imports) (fun _ -> Assert.error ass.at "expected linking error") (function | Import.Unknown (_, msg) | Eval.Link (_, msg) -> @@ -528,7 +575,7 @@ let run_assertion ass : unit Lwt.t = Lwt.try_bind (fun () -> let* imports = Import.link m in - Eval.init host_funcs_registry m imports) + instantiate_module None m imports) (fun _ -> Assert.error ass.at "expected instantiation error") (function | Eval.Trap (_, msg) -> assert_message ass.at "instantiation" msg re @@ -576,14 +623,14 @@ let rec run_command cmd : unit Lwt.t = if not !Flags.dry then let* () = trace_lwt "Initializing..." in let* imports = Import.link m in - let+ inst = Eval.init host_funcs_registry m imports in - bind instances x_opt inst + let+ inst = instantiate_module x_opt m imports in + bind_lazy instances x_opt inst else Lwt.return_unit | Register (name, x_opt) -> quote := cmd :: !quote ; if not !Flags.dry then ( trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"...") ; - let inst = lookup_instance x_opt cmd.at in + let* inst = lookup_instance x_opt cmd.at in let* utf8_name = Utf8.encode name in registry := Map.add utf8_name inst !registry ; Import.register ~module_name:name (lookup_registry utf8_name)) @@ -605,7 +652,7 @@ and run_meta cmd = let+ () = run_quote_script script in bind scripts x_opt (lookup_script None cmd.at) | Input (x_opt, file) -> - let+ () = + let* () = Lwt.catch (fun () -> let+ res = input_file file run_quote_script in @@ -616,7 +663,10 @@ and run_meta cmd = if x_opt <> None then ( bind modules x_opt (lookup_module None cmd.at) ; if not !Flags.dry then - bind instances x_opt (lookup_instance None cmd.at)) + let+ inst = lookup_instance None cmd.at in + bind_lazy instances x_opt inst + else Lwt.return_unit) + else Lwt.return_unit | Output (x_opt, Some file) -> Lwt.catch (fun () -> diff --git a/src/lib_webassembly/exec/eval.ml b/src/lib_webassembly/exec/eval.ml index 006ceafa2110..20043cb64e24 100644 --- a/src/lib_webassembly/exec/eval.ml +++ b/src/lib_webassembly/exec/eval.ml @@ -55,7 +55,7 @@ let numeric_error at = function type 'a stack = 'a list -type frame = {inst : module_inst; locals : value ref list} +type frame = {inst : module_ref; locals : value ref list} type code = value stack * admin_instr list @@ -138,7 +138,7 @@ let func_ref inst x i at = | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) let func_type_of = function - | Func.AstFunc (t, inst, f) -> t + | Func.AstFunc (t, _inst, _f) -> t | Func.HostFunc (t, _) -> t let block_type inst bt = @@ -167,26 +167,30 @@ let drop n (vs : 'a stack) at = *) let mem_oob frame x i n = - let+ mem = memory frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ mem = memory inst x in I64.gt_u (I64.add (I64_convert.extend_i32_u i) (I64_convert.extend_i32_u n)) (Memory.bound mem) let data_oob frame x i n = - let* data_label = data frame.inst x in - let+ data = Ast.get_data !data_label frame.inst.allocations.datas in + let* inst = resolve_module_ref frame.inst in + let* data_label = data inst x in + let+ data = Ast.get_data !data_label inst.allocations.datas in I64.gt_u (I64.add (I64_convert.extend_i32_u i) (I64_convert.extend_i32_u n)) (Chunked_byte_vector.Lwt.length data) let table_oob frame x i n = - let+ tbl = table frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ tbl = table inst x in I64.gt_u (I64.add (I64_convert.extend_i32_u i) (I64_convert.extend_i32_u n)) (I64_convert.extend_i32_u (Table.size tbl)) let elem_oob frame x i n = - let+ elem = elem frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ elem = elem inst x in I64.gt_u (I64.add (I64_convert.extend_i32_u i) (I64_convert.extend_i32_u n)) (Int64.of_int32 (Instance.Vector.num_elements !elem)) @@ -195,7 +199,8 @@ let rec step (c : config) : config Lwt.t = let {frame; code = vs, es; _} = c in match es with | {it = From_block (Block_label b, i); at} :: es -> - let* block = Vector.get b frame.inst.Instance.allocations.blocks in + let* inst = resolve_module_ref frame.inst in + let* block = Vector.get b inst.allocations.blocks in let length = Vector.num_elements block in if i = length then Lwt.return {c with code = (vs, es)} else @@ -219,7 +224,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = Lwt.return (vs, [Trapping "unreachable executed" @@ e.at]) | Nop, vs -> Lwt.return (vs, []) | Block (bt, es'), vs -> - let+ (FuncType (ts1, ts2)) = block_type frame.inst bt in + let* inst = resolve_module_ref frame.inst in + let+ (FuncType (ts1, ts2)) = block_type inst bt in let n1 = Lazy_vector.LwtInt32Vector.num_elements ts1 in let n2 = Lazy_vector.LwtInt32Vector.num_elements ts2 in let args, vs' = (take n1 vs e.at, drop n1 vs e.at) in @@ -227,7 +233,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = [Label (n2, [], (args, [From_block (es', 0l) @@ e.at])) @@ e.at] ) | Loop (bt, es'), vs -> - let+ (FuncType (ts1, ts2)) = block_type frame.inst bt in + let* inst = resolve_module_ref frame.inst in + let+ (FuncType (ts1, ts2)) = block_type inst bt in let n1 = Lazy_vector.LwtInt32Vector.num_elements ts1 in let args, vs' = (take n1 vs e.at, drop n1 vs e.at) in ( vs', @@ -250,11 +257,12 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = else (vs', [Plain (Br (Lib.List32.nth xs i)) @@ e.at])) | Return, vs -> Lwt.return ([], [Returning vs @@ e.at]) | Call x, vs -> - let+ func = func frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ func = func inst x in (vs, [Invoke func @@ e.at]) | CallIndirect (x, y), Num (I32 i) :: vs -> - let* func = func_ref frame.inst x i e.at - and* type_ = type_ frame.inst y in + let* inst = resolve_module_ref frame.inst in + let* func = func_ref inst x i e.at and* type_ = type_ inst y in let+ check_eq = Types.func_types_equal type_ (Func.type_of func) in if not check_eq then (vs, [Trapping "indirect call type mismatch" @@ e.at]) @@ -272,13 +280,15 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (local frame x := v ; (v :: vs', [])) | GlobalGet x, vs -> - let+ glob = global frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ glob = global inst x in let value = Global.load glob in (value :: vs, []) | GlobalSet x, v :: vs' -> Lwt.catch (fun () -> - let+ glob = global frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ glob = global inst x in Global.store glob v ; (vs', [])) (function @@ -290,7 +300,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = | TableGet x, Num (I32 i) :: vs' -> Lwt.catch (fun () -> - let* tbl = table frame.inst x in + let* inst = resolve_module_ref frame.inst in + let* tbl = table inst x in let+ value = Table.load tbl i in (Ref value :: vs', [])) (fun exn -> @@ -298,16 +309,19 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = | TableSet x, Ref r :: Num (I32 i) :: vs' -> Lwt.catch (fun () -> - let+ tbl = table frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ tbl = table inst x in Table.store tbl i r ; (vs', [])) (fun exn -> Lwt.return (vs', [Trapping (table_error e.at exn) @@ e.at])) | TableSize x, vs -> - let+ tbl = table frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ tbl = table inst x in (Num (I32 (Table.size tbl)) :: vs, []) | TableGrow x, Num (I32 delta) :: Ref r :: vs' -> - let+ tab = table frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ tab = table inst x in let old_size = Table.size tab in let result = try @@ -378,7 +392,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (vs', [Trapping (table_error e.at Table.Bounds) @@ e.at]) else if n = 0l then Lwt.return (vs', []) else - let* seg = elem frame.inst y in + let* inst = resolve_module_ref frame.inst in + let* seg = elem inst y in let+ value = Instance.Vector.get s !seg in ( vs', List.map @@ -397,11 +412,13 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = Plain (TableInit (x, y)); ] ) | ElemDrop x, vs -> - let+ seg = elem frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ seg = elem inst x in seg := Instance.Vector.create 0l ; (vs, []) | Load {offset; ty; pack; _}, Num (I32 i) :: vs' -> - let* mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let* mem = memory inst (0l @@ e.at) in Lwt.catch (fun () -> let+ n = @@ -414,7 +431,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (fun exn -> Lwt.return (vs', [Trapping (memory_error e.at exn) @@ e.at])) | Store {offset; pack; _}, Num n :: Num (I32 i) :: vs' -> - let* mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let* mem = memory inst (0l @@ e.at) in Lwt.catch (fun () -> let+ () = @@ -426,7 +444,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (fun exn -> Lwt.return (vs', [Trapping (memory_error e.at exn) @@ e.at])) | VecLoad {offset; ty; pack; _}, Num (I32 i) :: vs' -> - let* mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let* mem = memory inst (0l @@ e.at) in Lwt.catch (fun () -> let+ v = @@ -439,7 +458,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (fun exn -> Lwt.return (vs', [Trapping (memory_error e.at exn) @@ e.at])) | VecStore {offset; _}, Vec v :: Num (I32 i) :: vs' -> - let* mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let* mem = memory inst (0l @@ e.at) in Lwt.catch (fun () -> let+ () = Memory.store_vec mem i offset v in @@ -448,7 +468,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = Lwt.return (vs', [Trapping (memory_error e.at exn) @@ e.at])) | ( VecLoadLane ({offset; ty; pack; _}, j), Vec (V128 v) :: Num (I32 i) :: vs' ) -> - let* mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let* mem = memory inst (0l @@ e.at) in Lwt.catch (fun () -> let+ v = @@ -475,7 +496,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = Lwt.return (vs', [Trapping (memory_error e.at exn) @@ e.at])) | ( VecStoreLane ({offset; ty; pack; _}, j), Vec (V128 v) :: Num (I32 i) :: vs' ) -> - let* mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let* mem = memory inst (0l @@ e.at) in Lwt.catch (fun () -> let+ () = @@ -511,10 +533,12 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (fun exn -> Lwt.return (vs', [Trapping (memory_error e.at exn) @@ e.at])) | MemorySize, vs -> - let+ mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let+ mem = memory inst (0l @@ e.at) in (Num (I32 (Memory.size mem)) :: vs, []) | MemoryGrow, Num (I32 delta) :: vs' -> - let+ mem = memory frame.inst (0l @@ e.at) in + let* inst = resolve_module_ref frame.inst in + let+ mem = memory inst (0l @@ e.at) in let old_size = Memory.size mem in let result = try @@ -621,8 +645,9 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = (vs', [Trapping (memory_error e.at Memory.Bounds) @@ e.at]) else if n = 0l then Lwt.return (vs', []) else - let* seg = data frame.inst x in - let* seg = Ast.get_data !seg frame.inst.allocations.datas in + let* inst = resolve_module_ref frame.inst in + let* seg = data inst x in + let* seg = Ast.get_data !seg inst.allocations.datas in let+ b = Chunked_byte_vector.Lwt.load_byte seg (Int64.of_int32 s) in @@ -647,7 +672,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = Plain (MemoryInit x); ] ) | DataDrop x, vs -> - let+ seg = data frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ seg = data inst x in seg := Data_label 0l ; (vs, []) | RefNull t, vs' -> Lwt.return (Ref (NullRef t) :: vs', []) @@ -657,7 +683,8 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = | NullRef _ -> (Num (I32 1l) :: vs', []) | _ -> (Num (I32 0l) :: vs', [])) | RefFunc x, vs' -> - let+ f = func frame.inst x in + let* inst = resolve_module_ref frame.inst in + let+ f = func inst x in (Ref (FuncRef f) :: vs', []) | Const n, vs -> Lwt.return (Num n.it :: vs, []) | Test testop, Num n :: vs' -> @@ -796,7 +823,7 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = Lazy_vector in the config for local variables. *) let+ locals = Lazy_vector.LwtInt32Vector.to_list f.it.locals in let locals' = List.rev args @ List.map default_value locals in - let frame' = {inst = !inst'; locals = List.map ref locals'} in + let frame' = {inst = inst'; locals = List.map ref locals'} in let instr' = [ Label (n2, [], ([], [From_block (f.it.body, 0l) @@ f.at])) @@ -805,12 +832,12 @@ and step_resolved (c : config) frame vs e es : config Lwt.t = in (vs', [Frame (n2, frame', ([], instr')) @@ e.at]) | Func.HostFunc (_, global_name) -> - let inst = ref frame.inst in Lwt.catch (fun () -> let (Host_funcs.Host_func f) = Host_funcs.lookup ~global_name c.host_funcs in + let* inst = resolve_module_ref frame.inst in let+ res = f c.input inst (List.rev args) in (List.rev res @ vs', [])) (function @@ -828,9 +855,8 @@ let rec eval (c : config) : value stack Lwt.t = (* Functions & Constants *) -let invoke ?(module_inst = empty_module_inst) ?(input = Input_buffer.alloc ()) - host_funcs (func : func_inst) (vs : value list) : - (module_inst * value list) Lwt.t = +let invoke ?caller ?(input = Input_buffer.alloc ()) host_funcs + (func : func_inst) (vs : value list) : value list Lwt.t = let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in let (FuncType (ins, out)) = Func.type_of func in let* ins_l = Lazy_vector.LwtInt32Vector.to_list ins in @@ -841,28 +867,25 @@ let invoke ?(module_inst = empty_module_inst) ?(input = Input_buffer.alloc ()) (* TODO: tickify? *) if not (List.for_all2 (fun v -> ( = ) (type_of_value v)) vs ins_l) then Crash.error at "wrong types of arguments" ; - let allocations = + let inst = match func with - | Func.AstFunc (_, {contents = {allocations; _}}, _) -> allocations - | Func.HostFunc _ -> Ast.empty_allocations () - in - let c = - config - ~input - host_funcs - {module_inst with allocations} - (List.rev vs) - [Invoke func @@ at] + | Func.AstFunc (_, inst, _) -> inst + | Func.HostFunc (_, _) -> ( + (* We create a fresh module reference to an empty module. [invoke] is + called at the top-level where we are not in a module context, yet. + Hence we need to create one for this call. *) + match caller with None -> empty_module_ref () | Some inst -> inst) in + let c = config ~input host_funcs inst (List.rev vs) [Invoke func @@ at] in Lwt.catch (fun () -> let+ values = eval c in - (c.frame.inst, List.rev values)) + List.rev values) (function | Stack_overflow -> Exhaustion.error at "call stack exhausted" | exn -> Lwt.fail exn) -let eval_const (inst : module_inst) (const : const) : value Lwt.t = +let eval_const (inst : module_ref) (const : const) : value Lwt.t = let c = config (Host_funcs.empty ()) inst [] [From_block (const.it, 0l) @@ const.at] in @@ -873,9 +896,10 @@ let eval_const (inst : module_inst) (const : const) : value Lwt.t = (* Modules *) -let create_func (inst : module_inst) (f : func) : func_inst Lwt.t = +let create_func (inst_ref : module_ref) (f : func) : func_inst Lwt.t = + let* inst = resolve_module_ref inst_ref in let+ type_ = type_ inst f.it.ftype in - Func.alloc type_ (ref inst) f + Func.alloc type_ inst_ref f let create_table (inst : module_inst) (tab : table) : table_inst = let {ttype} = tab.it in @@ -886,7 +910,7 @@ let create_memory (inst : module_inst) (mem : memory) : memory_inst = let {mtype} = mem.it in Memory.alloc mtype -let create_global (inst : module_inst) (glob : global) : global_inst Lwt.t = +let create_global (inst : module_ref) (glob : global) : global_inst Lwt.t = let {gtype; ginit} = glob.it in let+ v = eval_const inst ginit in Global.alloc gtype v @@ -910,7 +934,7 @@ let create_export (inst : module_inst) (ex : export) : export_inst Lwt.t = in (name, ext) -let create_elem (inst : module_inst) (seg : elem_segment) : elem_inst Lwt.t = +let create_elem (inst : module_ref) (seg : elem_segment) : elem_inst Lwt.t = let {etype; einit; _} = seg.it in (* TODO: #3076 [einit] should be changed to a lazy structure. We want to avoid traversing @@ -952,11 +976,6 @@ let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : | ExternMemory mem -> {inst with memories = Vector.cons mem inst.memories} | ExternGlobal glob -> {inst with globals = Vector.cons glob inst.globals} -let init_func (inst : module_inst) (func : func_inst) = - match func with - | Func.AstFunc (_, inst_ref, _) -> inst_ref := inst - | _ -> assert false - let run_elem inst i elem = let at = elem.it.emode.at in let x = i @@ at in @@ -1003,7 +1022,8 @@ let run_data (inst : module_inst) i data = let run_start start = List.map plain [Call start.it.sfunc @@ start.at] -let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = +let init ~self host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t + = let open Lwt.Syntax in let { imports; @@ -1021,6 +1041,9 @@ let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = m.it in + (* Initialize as empty module. *) + update_module_ref self empty_module_inst ; + (* TODO: #3076 These transformations should be refactored and abadoned during the @@ -1051,6 +1074,8 @@ let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = | Error () -> Link.error m.at "wrong number of imports provided for initialisation" in + update_module_ref self init_inst0 ; + let inst0 = { init_inst0 with @@ -1062,7 +1087,9 @@ let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = allocations; } in - let* fs = TzStdLib.List.map_s (create_func inst0) funcs in + update_module_ref self inst0 ; + + let* fs = TzStdLib.List.map_s (create_func self) funcs in let inst1 = { inst0 with @@ -1072,7 +1099,9 @@ let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = funcs = Vector.concat inst0.funcs (Vector.of_list fs); } in - let* new_globals = TzStdLib.List.map_s (create_global inst1) globals in + update_module_ref self inst1 ; + + let* new_globals = TzStdLib.List.map_s (create_global self) globals in let inst2 = { inst1 with @@ -1093,8 +1122,10 @@ let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = Vector.concat inst1.globals (Vector.of_list new_globals); } in + update_module_ref self inst2 ; + let* new_exports = TzStdLib.List.map_s (create_export inst2) exports in - let* new_elems = TzStdLib.List.map_s (create_elem inst2) elems in + let* new_elems = TzStdLib.List.map_s (create_elem self) elems in let new_datas = List.map (create_data inst2) datas in let* exports = (* TODO: #3076 @@ -1120,12 +1151,14 @@ let init host_funcs (m : module_) (exts : extern list) : module_inst Lwt.t = Vector.of_list new_datas; } in - List.iter (init_func inst) fs ; + update_module_ref self inst ; + let es_elem = List.concat (Lib.List32.mapi (run_elem inst) elems) in let* datas = Lib.List32.mapi_s (run_data inst) datas in let es_data = TzStdLib.List.concat datas in let es_start = Lib.Option.get (Lib.Option.map run_start start) [] in let+ (_ : Values.value stack) = - eval (config host_funcs inst [] (es_elem @ es_data @ es_start)) + eval (config host_funcs self [] (es_elem @ es_data @ es_start)) in + inst diff --git a/src/lib_webassembly/exec/eval.mli b/src/lib_webassembly/exec/eval.mli index cb39ff061951..7dbfc1c9f6de 100644 --- a/src/lib_webassembly/exec/eval.mli +++ b/src/lib_webassembly/exec/eval.mli @@ -10,15 +10,16 @@ exception Crash of Source.region * string exception Exhaustion of Source.region * string val init : + self:module_ref -> Host_funcs.registry -> Ast.module_ -> extern list -> module_inst Lwt.t (* raises Link, Trap *) val invoke : - ?module_inst:module_inst -> + ?caller:module_ref -> ?input:Input_buffer.t -> Host_funcs.registry -> func_inst -> value list -> - (module_inst * value list) Lwt.t (* raises Trap *) + value list Lwt.t (* raises Trap *) diff --git a/src/lib_webassembly/host/env.ml b/src/lib_webassembly/host/env.ml index e6200de05876..6bca32506e91 100644 --- a/src/lib_webassembly/host/env.ml +++ b/src/lib_webassembly/host/env.ml @@ -34,8 +34,7 @@ let abort = exit (-1)) let exit = - Host_funcs.Host_func - (fun _input (_mod_inst : module_inst ref) vs -> exit (int (single vs))) + Host_funcs.Host_func (fun _input _mod_inst vs -> exit (int (single vs))) let register_host_funcs registry = Host_funcs.register ~global_name:"abort" abort registry ; diff --git a/src/lib_webassembly/runtime/host_funcs.ml b/src/lib_webassembly/runtime/host_funcs.ml index e0e016cc21d8..d459ccb94063 100644 --- a/src/lib_webassembly/runtime/host_funcs.ml +++ b/src/lib_webassembly/runtime/host_funcs.ml @@ -1,7 +1,7 @@ type host_func = | Host_func of (Input_buffer.t -> - Instance.module_inst ref -> + Instance.module_inst -> Values.value list -> Values.value list Lwt.t) [@@ocaml.unboxed] diff --git a/src/lib_webassembly/runtime/host_funcs.mli b/src/lib_webassembly/runtime/host_funcs.mli index 34e1cb30badb..75ae6720d5e7 100644 --- a/src/lib_webassembly/runtime/host_funcs.mli +++ b/src/lib_webassembly/runtime/host_funcs.mli @@ -2,7 +2,7 @@ type host_func = | Host_func of (Input_buffer.t -> - Instance.module_inst ref -> + Instance.module_inst -> Values.value list -> Values.value list Lwt.t) [@@ocaml.unboxed] diff --git a/src/lib_webassembly/runtime/instance.ml b/src/lib_webassembly/runtime/instance.ml index d72418db20ec..b7ab3e6a9f22 100644 --- a/src/lib_webassembly/runtime/instance.ml +++ b/src/lib_webassembly/runtime/instance.ml @@ -1,4 +1,14 @@ open Types + +module ModuleMap = + Lazy_map.Mutable.Make + (Lazy_map.Effect.Lwt) + (struct + include String + + let to_string = Fun.id + end) + module Vector = Lazy_vector.LwtInt32Vector module NameMap = @@ -12,6 +22,8 @@ module NameMap = let to_string = Utf8.encode_list end) +type module_key = Module_key of string + type module_inst = { types : func_type Vector.t; funcs : func_inst Vector.t; @@ -24,7 +36,7 @@ type module_inst = { allocations : Ast.allocations; } -and func_inst = module_inst ref Func.t +and func_inst = module_ref Func.t and table_inst = Table.t @@ -46,6 +58,10 @@ and extern = | ExternMemory of memory_inst | ExternGlobal of global_inst +and module_reg = module_inst ModuleMap.t + +and module_ref = {registry : module_reg; key : module_key} + (* Reference types *) type Values.ref_ += FuncRef of func_inst @@ -83,6 +99,23 @@ let empty_module_inst = allocations = Ast.empty_allocations (); } +let empty_module_ref () = + let registry = ModuleMap.create () in + let key = "empty" in + ModuleMap.set key empty_module_inst registry ; + {registry; key = Module_key key} + +let alloc_module_ref (Module_key mkey as key) ?(module_inst = empty_module_inst) + registry = + ModuleMap.set mkey module_inst registry ; + {registry; key} + +let update_module_ref {registry; key = Module_key key} module_inst = + ModuleMap.set key module_inst registry + +let resolve_module_ref {registry; key = Module_key key} = + ModuleMap.get key registry + let extern_type_of = function | ExternFunc func -> ExternFuncType (Func.type_of func) | ExternTable tab -> ExternTableType (Table.type_of tab) -- GitLab