diff --git a/ml-proto/README.md b/ml-proto/README.md index 73239ed4c5..e9a9104d9f 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -183,8 +183,8 @@ exkind: ( func ) ( table ) ( memory ) -module: ( module * * * * ? ? * * ? ) - ( module + ) +module: ( module ? * * * *
? ? * * ? ) + ( module ? + ) ``` Here, productions marked with respective comments are abbreviation forms for equivalent expansions (see the explanation of the kernel AST below). @@ -215,17 +215,25 @@ In order to be able to check and run modules for testing purposes, the S-express script: * cmd: - ;; define, validate, and initialize module - ( invoke * ) ;; invoke export and print result - ( assert_return (invoke * ) ) ;; assert return with expected result of invocation - ( assert_return_nan (invoke * )) ;; assert return with floating point nan result of invocation - ( assert_trap (invoke * ) ) ;; assert invocation traps with given failure string - ( assert_invalid ) ;; assert invalid module with given failure string - ( input ) ;; read script or module from file - ( output ? ) ;; output module to stout or file + ;; define, validate, and initialize module + ;; perform action and print results + ( register ? ) ;; register module for imports + ( assert_return ? ) ;; assert action has expected results + ( assert_return_nan ) ;; assert action results in NaN + ( assert_trap ) ;; assert action traps with given failure string + ( assert_invalid ) ;; assert module is invalid with given failure string + ( assert_unlinkable ) ;; assert module fails to link module with given failure string + ( input ) ;; read script or module from file + ( output ? ? ) ;; output module to stout or file + +action: + ( invoke ? * ) ;; invoke function export + ( get ? ) ;; get global export ``` -Commands are executed in sequence. Invocation, assertions, and output apply to the most recently defined module (the _current_ module), and are only possible after a module has been defined. Note that there only ever is one current module, the different module definitions cannot interact. +Commands are executed in sequence. Commands taking an optional module name refer to the most recently defined module if no name is given. They are only possible after a module has been defined. + +After a module is _registered_ under a string name it is available for importing in other modules. The input and output commands determine the requested file format from the file name extension. They can handle both `.wast` and `.wasm` files. In the case of input, a `.wast` script will be recursively executed. diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index 789fe856ca..999e44ac41 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -1,3 +1,9 @@ +module Fun = +struct + let rec repeat n f x = + if n = 0 then () else (f x; repeat (n - 1) f x) +end + module List = struct let rec make n x = diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index 97b54f23e5..f216a8ecfb 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -1,5 +1,10 @@ (* Things that should be in the OCaml library... *) +module Fun : +sig + val repeat : int -> ('a -> unit) -> 'a -> unit +end + module List : sig val make : int -> 'a -> 'a list diff --git a/ml-proto/host/import.mli b/ml-proto/host/import.mli index 3eb201212b..5ec32397f0 100644 --- a/ml-proto/host/import.mli +++ b/ml-proto/host/import.mli @@ -2,4 +2,7 @@ exception Unknown of Source.region * string val link : Kernel.module_ -> Instance.extern list (* raises Unknown *) -val register : string -> (string -> Types.external_type -> Instance.extern) -> unit +val register : + string -> + (string -> Types.external_type -> Instance.extern (* raise Not_found *)) -> + unit diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index a115d6c651..58ba61a5da 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -371,12 +371,14 @@ rule token = parse | "import" { IMPORT } | "export" { EXPORT } + | "register" { REGISTER } + | "invoke" { INVOKE } + | "get" { GET } | "assert_invalid" { ASSERT_INVALID } | "assert_unlinkable" { ASSERT_UNLINKABLE } | "assert_return" { ASSERT_RETURN } | "assert_return_nan" { ASSERT_RETURN_NAN } | "assert_trap" { ASSERT_TRAP } - | "invoke" { INVOKE } | "input" { INPUT } | "output" { OUTPUT } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index f059bba3fb..c54898fcbd 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -63,15 +63,15 @@ type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list} let empty_types () = {tmap = VarMap.empty; tlist = []} type context = - {types : types; tables : space; memories : space; funcs : space; - locals : space; globals : space; labels : int VarMap.t} + { types : types; tables : space; memories : space; + funcs : space; locals : space; globals : space; labels : int VarMap.t } let empty_context () = - {types = empty_types (); tables = empty (); memories = empty (); - funcs = empty (); locals = empty (); globals = empty (); labels = VarMap.empty} + { types = empty_types (); tables = empty (); memories = empty (); + funcs = empty (); locals = empty (); globals = empty (); + labels = VarMap.empty } let enter_func c = - assert (VarMap.is_empty c.labels); {c with labels = VarMap.empty; locals = empty ()} let type_ c x = @@ -91,12 +91,18 @@ let label c x = try VarMap.find x.it c.labels with Not_found -> error x.at ("unknown label " ^ x.it) +let bind_module () x = Some x +let anon_module () = None + let bind_type c x ty = if VarMap.mem x.it c.types.tmap then error x.at ("duplicate type " ^ x.it); c.types.tmap <- VarMap.add x.it (List.length c.types.tlist) c.types.tmap; c.types.tlist <- c.types.tlist @ [ty] +let anon_type c ty = + c.types.tlist <- c.types.tlist @ [ty] + let bind category space x = if VarMap.mem x.it space.map then error x.at ("duplicate " ^ category ^ " " ^ x.it); @@ -111,9 +117,6 @@ let bind_memory c x = bind "memory" c.memories x let bind_label c x = {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)} -let anon_type c ty = - c.types.tlist <- c.types.tlist @ [ty] - let anon space n = space.count <- space.count + n let anon_func c = anon c.funcs 1 @@ -151,8 +154,9 @@ let inline_type c t at = %token UNREACHABLE CURRENT_MEMORY GROW_MEMORY %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL %token MODULE TABLE ELEM MEMORY DATA IMPORT EXPORT TABLE +%token REGISTER INVOKE GET %token ASSERT_INVALID ASSERT_UNLINKABLE -%token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE +%token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP %token INPUT OUTPUT %token EOF @@ -597,28 +601,39 @@ module_fields : {m with exports = $1 c :: m.exports} } ; module_ : - | LPAR MODULE module_fields RPAR - { Textual ($3 (empty_context ()) @@ at ()) @@ at() } - | LPAR MODULE TEXT text_list RPAR { Binary ($3 ^ $4) @@ at() } + | LPAR MODULE module_var_opt module_fields RPAR + { $3, Textual ($4 (empty_context ()) @@ at ()) @@ at () } + | LPAR MODULE module_var_opt TEXT text_list RPAR + { $3, Binary ($4 ^ $5) @@ at() } ; /* Scripts */ +module_var_opt : + | /* empty */ { None } + | VAR { Some ($1 @@ at ()) } /* Sugar */ +; +action : + | LPAR INVOKE module_var_opt TEXT const_list RPAR + { Invoke ($3, $4, $5) @@ at () } + | LPAR GET module_var_opt TEXT RPAR + { Get ($3, $4) @@ at() } +; cmd : - | module_ { Define $1 @@ at () } - | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () } - | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () } - | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR { AssertUnlinkable ($3, $4) @@ at () } - | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_opt RPAR - { AssertReturn ($5, $6, $8) @@ at () } - | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR - { AssertReturnNaN ($5, $6) @@ at () } - | LPAR ASSERT_TRAP LPAR INVOKE TEXT const_list RPAR TEXT RPAR - { AssertTrap ($5, $6, $8) @@ at () } + | module_ { Define (fst $1, snd $1) @@ at () } + | action { Action $1 @@ at () } + | LPAR REGISTER TEXT module_var_opt RPAR { Register ($3, $4) @@ at () } + | LPAR ASSERT_INVALID module_ TEXT RPAR + { AssertInvalid (snd $3, $4) @@ at () } + | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR + { AssertUnlinkable (snd $3, $4) @@ at () } + | LPAR ASSERT_RETURN action const_opt RPAR { AssertReturn ($3, $4) @@ at () } + | LPAR ASSERT_RETURN_NAN action RPAR { AssertReturnNaN $3 @@ at () } + | LPAR ASSERT_TRAP action TEXT RPAR { AssertTrap ($3, $4) @@ at () } | LPAR INPUT TEXT RPAR { Input $3 @@ at () } - | LPAR OUTPUT TEXT RPAR { Output (Some $3) @@ at () } - | LPAR OUTPUT RPAR { Output None @@ at () } + | LPAR OUTPUT module_var_opt TEXT RPAR { Output ($3, Some $4) @@ at () } + | LPAR OUTPUT module_var_opt RPAR { Output ($3, None) @@ at () } ; cmd_list : | /* empty */ { [] } @@ -644,6 +659,6 @@ script1 : | cmd { [$1] } ; module1 : - | module_ EOF { $1 } + | module_ EOF { snd $1 } ; %% diff --git a/ml-proto/host/run.ml b/ml-proto/host/run.ml index 2c4b6b63e5..ea9bc3615d 100644 --- a/ml-proto/host/run.ml +++ b/ml-proto/host/run.ml @@ -45,7 +45,7 @@ let run_binary name buf = run_from (fun _ -> let m = Decode.decode name buf in - [Script.Define (Script.Textual m @@ m.at) @@ m.at]) + [Script.Define (None, Script.Textual m @@ m.at) @@ m.at]) let run_sexpr_file file = Script.trace ("Loading (" ^ file ^ ")..."); diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 7cf8a7dfbe..1566c8a595 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -1,24 +1,33 @@ open Source +open Instance (* Script representation *) +type var = string Source.phrase + type definition = definition' Source.phrase and definition' = | Textual of Ast.module_ | Binary of string +type action = action' Source.phrase +and action' = + | Invoke of var option * string * Kernel.literal list + | Get of var option * string + type command = command' Source.phrase and command' = - | Define of definition - | Invoke of string * Kernel.literal list + | Define of var option * definition + | Register of string * var option + | Action of action | AssertInvalid of definition * string | AssertUnlinkable of definition * string - | AssertReturn of string * Kernel.literal list * Kernel.literal option - | AssertReturnNaN of string * Kernel.literal list - | AssertTrap of string * Kernel.literal list * string + | AssertReturn of action * Kernel.literal option + | AssertReturnNaN of action + | AssertTrap of action * string | Input of string - | Output of string option + | Output of var option * string option type script = command list @@ -37,16 +46,40 @@ exception IO = IO.Error let trace name = if !Flags.trace then print_endline ("-- " ^ name) +module Map = Map.Make(String) + +let registry : Instance.instance Map.t ref = ref Map.empty + +let lookup module_name item_name _t = + match Instance.export (Map.find module_name !registry) item_name with + | Some ext -> ext + | None -> raise Not_found + +let modules : Ast.module_ Map.t ref = ref Map.empty +let instances : Instance.instance Map.t ref = ref Map.empty let current_module : Ast.module_ option ref = ref None let current_instance : Instance.instance option ref = ref None -let get_module at = match !current_module with - | Some m -> m - | None -> raise (Eval.Crash (at, "no module defined")) +let bind map x_opt y = + match x_opt with + | None -> () + | Some x -> map := Map.add x.it y !map + +let get_module x_opt at = + match x_opt, !current_module with + | None, Some m -> m + | None, None -> raise (Eval.Crash (at, "no module defined")) + | Some x, _ -> + try Map.find x.it !modules with Not_found -> + raise (Eval.Crash (x.at, "unknown module " ^ x.it)) -let get_instance at = match !current_instance with - | Some m -> m - | None -> raise (Eval.Crash (at, "no module defined")) +let get_instance x_opt at = + match x_opt, !current_instance with + | None, Some inst -> inst + | None, None -> raise (Eval.Crash (at, "no module defined")) + | Some x, _ -> + try Map.find x.it !instances with Not_found -> + raise (Eval.Crash (x.at, "unknown module " ^ x.it)) let input_file = ref (fun _ -> assert false) let output_file = ref (fun _ -> assert false) @@ -59,9 +92,28 @@ let run_def def = trace "Decoding..."; Decode.decode "binary" bs +let run_action act = + match act.it with + | Invoke (x_opt, name, es) -> + trace ("Invoking function \"" ^ name ^ "\"..."); + let inst = get_instance x_opt act.at in + (match Instance.export inst name with + | Some (ExternalFunc f) -> Eval.invoke f (List.map it es) + | Some _ -> Assert.error act.at "export is not a function" + | None -> Assert.error act.at "undefined export" + ) + | Get (x_opt, name) -> + trace ("Getting global \"" ^ name ^ "\"..."); + let inst = get_instance x_opt act.at in + (match Instance.export inst name with + | Some (ExternalGlobal v) -> Some v + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" + ) + let run_cmd cmd = match cmd.it with - | Define def -> + | Define (x_opt, def) -> let m = run_def def in let m' = Desugar.desugar m in if not !Flags.unchecked then begin @@ -74,13 +126,20 @@ let run_cmd cmd = end; trace "Initializing..."; let imports = Import.link m' in + let inst = Eval.init m' imports in current_module := Some m; - current_instance := Some (Eval.init m' imports) + current_instance := Some inst; + bind modules x_opt m; + bind instances x_opt inst - | Invoke (name, es) -> - trace ("Invoking \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - let v = Eval.invoke m name (List.map it es) in + | Register (name, x_opt) -> + trace ("Registering module \"" ^ name ^ "\"..."); + let inst = get_instance x_opt cmd.at in + registry := Map.add name inst !registry; + Import.register name (lookup name) + + | Action act -> + let v = run_action act in if v <> None then Print.print_value v | AssertInvalid (def, re) -> @@ -119,21 +178,19 @@ let run_cmd cmd = Assert.error cmd.at "expected linking error" ) - | AssertReturn (name, es, expect_e) -> - trace ("Asserting return \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - let got_v = Eval.invoke m name (List.map it es) in - let expect_v = Lib.Option.map it expect_e in + | AssertReturn (act, expect) -> + trace ("Asserting return..."); + let got_v = run_action act in + let expect_v = Lib.Option.map it expect in if got_v <> expect_v then begin print_string "Result: "; Print.print_value got_v; print_string "Expect: "; Print.print_value expect_v; Assert.error cmd.at "wrong return value" end - | AssertReturnNaN (name, es) -> - trace ("Asserting return \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - let got_v = Eval.invoke m name (List.map it es) in + | AssertReturnNaN act -> + trace ("Asserting return..."); + let got_v = run_action act in if match got_v with | Some (Values.Float32 got_f32) -> @@ -147,10 +204,9 @@ let run_cmd cmd = Assert.error cmd.at "wrong return value" end - | AssertTrap (name, es, re) -> - trace ("Asserting trap \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - (match Eval.invoke m name (List.map it es) with + | AssertTrap (act, re) -> + trace ("Asserting trap..."); + (match run_action act with | exception Eval.Trap (_, msg) -> if not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); @@ -165,12 +221,12 @@ let run_cmd cmd = (try if not (!input_file file) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg) - | Output (Some file) -> - (try !output_file file (get_module cmd.at) + | Output (x_opt, Some file) -> + (try !output_file file (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) - | Output None -> - (try !output_stdout (get_module cmd.at) + | Output (x_opt, None) -> + (try !output_stdout (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) let dry_def def = @@ -182,7 +238,7 @@ let dry_def def = let dry_cmd cmd = match cmd.it with - | Define def -> + | Define (x_opt, def) -> let m = dry_def def in let m' = Desugar.desugar m in if not !Flags.unchecked then begin @@ -193,17 +249,19 @@ let dry_cmd cmd = Print.print_module_sig m' end end; - current_module := Some m + current_module := Some m; + bind modules x_opt m | Input file -> (try if not (!input_file file) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg) - | Output (Some file) -> - (try !output_file file (get_module cmd.at) + | Output (x_opt, Some file) -> + (try !output_file file (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) - | Output None -> - (try !output_stdout (get_module cmd.at) + | Output (x_opt, None) -> + (try !output_stdout (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) - | Invoke _ + | Register _ + | Action _ | AssertInvalid _ | AssertUnlinkable _ | AssertReturn _ diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index ca03e3a78a..e738a3a05c 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -1,19 +1,27 @@ +type var = string Source.phrase + type definition = definition' Source.phrase and definition' = | Textual of Ast.module_ | Binary of string +type action = action' Source.phrase +and action' = + | Invoke of var option * string * Kernel.literal list + | Get of var option * string + type command = command' Source.phrase and command' = - | Define of definition - | Invoke of string * Kernel.literal list + | Define of var option * definition + | Register of string * var option + | Action of action | AssertInvalid of definition * string | AssertUnlinkable of definition * string - | AssertReturn of string * Kernel.literal list * Kernel.literal option - | AssertReturnNaN of string * Kernel.literal list - | AssertTrap of string * Kernel.literal list * string + | AssertReturn of action * Kernel.literal option + | AssertReturnNaN of action + | AssertTrap of action * string | Input of string - | Output of string option + | Output of var option * string option type script = command list diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index f0877f5f07..38dac5ccdd 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -50,23 +50,23 @@ def _runTestFile(self, shortName, fileName, interpreterPath): if expectedExitCode != 0: return - # Convert to binary and run again + # Convert to binary and validate again wasmPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm")) logPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.log")) self._runCommand(("%s -d %s -o %s") % (interpreterPath, fileName, wasmPath)) - self._runCommand(("%s %s") % (interpreterPath, wasmPath), logPath) + self._runCommand(("%s -d %s") % (interpreterPath, wasmPath), logPath) - # Convert back to text and run again + # Convert back to text and validate again wastPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast")) logPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast.log")) self._runCommand(("%s -d %s -o %s") % (interpreterPath, wasmPath, wastPath)) - self._runCommand(("%s %s ") % (interpreterPath, wastPath), logPath) + self._runCommand(("%s -d %s ") % (interpreterPath, wastPath), logPath) #return # Convert back to binary once more and compare wasm2Path = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast.wasm")) self._runCommand(("%s -d %s -o %s") % (interpreterPath, wastPath, wasm2Path)) - self._runCommand(("%s %s") % (interpreterPath, wasm2Path), logPath) + self._runCommand(("%s -d %s") % (interpreterPath, wasm2Path), logPath) # TODO: Ultimately, the binary should stay the same, but currently desugaring gets in the way. # self._compareFile(wasmPath, wasm2Path) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index e730846fae..3b03ac12ff 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -64,18 +64,19 @@ let global c x = lookup "global" c.instance.globals x let local c x = lookup "local" c.locals x let label c x = lookup "label" c.labels x -let export inst name = - try ExportMap.find name.it inst.exports with Not_found -> - Crash.error name.at ("undefined export \"" ^ name.it ^ "\"") - let elem c x i t at = match Table.load (table c x) i t with - | Some j -> j + | Some item -> item | None -> Trap.error at ("uninitialized element " ^ Int32.to_string i) | exception Table.Bounds -> Trap.error at ("undefined element " ^ Int32.to_string i) +let func_elem c x i at = + match elem c x i AnyFuncType at with + | Func f -> f + | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) + let func_type_of t at = match t with | AstFunc (inst, f) -> lookup "type" (!inst).module_.it.types f.it.ftype @@ -177,7 +178,7 @@ let rec eval_expr (c : config) (e : expr) : value option = | CallIndirect (x, e1, es) -> let i = int32 (eval_expr c e1) e1.at in let vs = List.map (fun vo -> some (eval_expr c vo) vo.at) es in - let f = func c (elem c (0 @@ e.at) i AnyFuncType e1.at @@ e1.at) in + let f = func_elem c (0 @@ e.at) i e1.at in if type_ c.instance x <> func_type_of f e1.at then Trap.error e1.at "indirect call signature mismatch"; eval_func f vs e.at @@ -328,8 +329,9 @@ let init_func c f = | _ -> assert false let non_host_func c x = - ignore (func_type_of (func c x) x.at); - Some x.it + let f = func c x in + ignore (func_type_of f x.at); + Some (Func f) let init_table c seg = let {index; offset = e; init} = seg.it in @@ -414,13 +416,9 @@ let init m externals = Lib.Option.app (fun x -> ignore (eval_func (func c x) [] x.at)) start; {inst with exports = List.fold_right (add_export c) exports inst.exports} -let invoke inst name vs = - match export inst (name @@ no_region) with - | ExternalFunc f -> - (try eval_func f vs no_region - with Stack_overflow -> Trap.error no_region "call stack exhausted") - | _ -> - Crash.error no_region ("export \"" ^ name ^ "\" is not a function") +let invoke func vs = + (try eval_func func vs no_region + with Stack_overflow -> Trap.error no_region "call stack exhausted") let const m e = some (eval_expr (empty_config (instance m)) e) e.at diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli index 8e37e65633..5f85ac72f4 100644 --- a/ml-proto/spec/eval.mli +++ b/ml-proto/spec/eval.mli @@ -6,6 +6,5 @@ exception Trap of Source.region * string exception Crash of Source.region * string val init : Kernel.module_ -> extern list -> instance -val invoke : instance -> string -> value list -> value option - (* raises Trap, Crash *) +val invoke : func -> value list -> value option (* raises Trap *) val const : Kernel.module_ -> Kernel.expr -> value diff --git a/ml-proto/spec/instance.ml b/ml-proto/spec/instance.ml index a7e1f35c81..3404c7177d 100644 --- a/ml-proto/spec/instance.ml +++ b/ml-proto/spec/instance.ml @@ -24,6 +24,11 @@ and instance = exports : extern ExportMap.t; } +exception Func of func + let instance m = { module_ = m; funcs = []; tables = []; memories = []; globals = []; exports = ExportMap.empty } + +let export inst name = + try Some (ExportMap.find name inst.exports) with Not_found -> None diff --git a/ml-proto/spec/table.ml b/ml-proto/spec/table.ml index 3c9afc8743..8426661852 100644 --- a/ml-proto/spec/table.ml +++ b/ml-proto/spec/table.ml @@ -4,7 +4,7 @@ open Values type size = int32 type index = int32 -type elem = int option +type elem = exn option type elem_type = Types.elem_type type 'a limits = 'a Types.limits diff --git a/ml-proto/spec/table.mli b/ml-proto/spec/table.mli index d7098f074a..3b88e3d1be 100644 --- a/ml-proto/spec/table.mli +++ b/ml-proto/spec/table.mli @@ -4,7 +4,7 @@ type t = table type size = int32 type index = int32 -type elem = int option +type elem = exn option type elem_type = Types.elem_type type 'a limits = 'a Types.limits diff --git a/ml-proto/test/binary.wast b/ml-proto/test/binary.wast index 0e16d05933..b2b7908cb3 100644 --- a/ml-proto/test/binary.wast +++ b/ml-proto/test/binary.wast @@ -1,5 +1,7 @@ (module "\00asm\0c\00\00\00") (module "\00asm" "\0c\00\00\00") +(module $M "\00asm\0c\00\00\00") +(module $M "\00asm" "\0c\00\00\00") (assert_invalid (module "") "unexpected end") (assert_invalid (module "\01") "unexpected end") diff --git a/ml-proto/test/exports.wast b/ml-proto/test/exports.wast index 16f495239f..d2098150d2 100644 --- a/ml-proto/test/exports.wast +++ b/ml-proto/test/exports.wast @@ -7,6 +7,18 @@ (module (func (export "a"))) (module (func $a (export "a"))) +(module $Func + (export "e" (func $f)) + (func $f (param $n i32) (result i32) + (return (i32.add (get_local $n) (i32.const 1))) + ) +) +(assert_return (invoke "e" (i32.const 42)) (i32.const 43)) +(assert_return (invoke $Func "e" (i32.const 42)) (i32.const 43)) +(module) +(module $Other) +(assert_return (invoke $Func "e" (i32.const 42)) (i32.const 43)) + (assert_invalid (module (func) (export "a" (func 1))) "unknown function" @@ -32,16 +44,6 @@ "duplicate export name" ) -(module - (func $f (param $n i32) (result i32) - (return (i32.add (get_local $n) (i32.const 1))) - ) - - (export "e" (func $f)) -) - -(assert_return (invoke "e" (i32.const 42)) (i32.const 43)) - ;; Globals @@ -52,6 +54,16 @@ (module (global (export "a") i32 (i32.const 0))) (module (global $a (export "a") i32 (i32.const 0))) +(module $Global + (export "e" (global $g)) + (global $g i32 (i32.const 42)) +) +(assert_return (get "e") (i32.const 42)) +(assert_return (get $Global "e") (i32.const 42)) +(module) +(module $Other) +(assert_return (get $Global "e") (i32.const 42)) + (assert_invalid (module (global i32 (i32.const 0)) (export "a" (global 1))) "unknown global" @@ -77,8 +89,6 @@ "duplicate export name" ) -(; TODO: get global value ;) - ;; Tables @@ -92,6 +102,8 @@ (module (table $a (export "a") 0 anyfunc)) (module (table $a (export "a") 0 1 anyfunc)) +(; TODO: access table ;) + (assert_invalid (module (table 0 anyfunc) (export "a" (table 1))) "unknown table" @@ -118,8 +130,6 @@ "duplicate export name" ) -(; TODO: access table ;) - ;; Memories @@ -133,6 +143,8 @@ (module (memory $a (export "a") 0)) (module (memory $a (export "a") 0 1)) +(; TODO: access memory ;) + (assert_invalid (module (memory 0) (export "a" (memory 1))) "unknown memory" @@ -158,6 +170,3 @@ (module (memory 0) (table 0 anyfunc) (export "a" (memory 0)) (export "a" (table 0))) "duplicate export name" ) - -(; TODO: access memory ;) - diff --git a/ml-proto/test/imports.wast b/ml-proto/test/imports.wast index 133481a4d3..3c7e7de03d 100644 --- a/ml-proto/test/imports.wast +++ b/ml-proto/test/imports.wast @@ -189,13 +189,11 @@ (func (export "load") (param i32) (result i32) (i32.load (get_local 0))) ) - (assert_return (invoke "load" (i32.const 0)) (i32.const 0)) (assert_return (invoke "load" (i32.const 10)) (i32.const 16)) (assert_return (invoke "load" (i32.const 8)) (i32.const 0x100000)) (assert_trap (invoke "load" (i32.const 1000000)) "out of bounds memory access") - (assert_invalid (module (import "" "" (memory 1)) (import "" "" (memory 1))) "multiple memories" diff --git a/ml-proto/test/linking.wast b/ml-proto/test/linking.wast new file mode 100644 index 0000000000..8dc627e4f4 --- /dev/null +++ b/ml-proto/test/linking.wast @@ -0,0 +1,203 @@ +;; Functions + +(module $M + (func (export "call") (result i32) (call $g)) + (func $g (result i32) (i32.const 2)) +) +(register "M" $M) + +(module $N + (func $f (import "M" "call") (result i32)) + (export "M.call" (func $f)) + (func (export "call M.call") (result i32) (call $f)) + (func (export "call") (result i32) (call $g)) + (func $g (result i32) (i32.const 3)) +) + +(assert_return (invoke $M "call") (i32.const 2)) +(assert_return (invoke $N "M.call") (i32.const 2)) +(assert_return (invoke $N "call") (i32.const 3)) +(assert_return (invoke $N "call M.call") (i32.const 2)) + + +;; Globals + +(module $M + (global $glob (export "glob") i32 (i32.const 42)) + (func (export "get") (result i32) (get_global $glob)) +) +(register "M" $M) + +(module $N + (global $x (import "M" "glob") i32) + (func $f (import "M" "get") (result i32)) + (export "M.glob" (global $x)) + (export "M.get" (func $f)) + (global $glob (export "glob") i32 (i32.const 43)) + (func (export "get") (result i32) (get_global $glob)) +) + +(assert_return (get $M "glob") (i32.const 42)) +(assert_return (get $N "M.glob") (i32.const 42)) +(assert_return (get $N "glob") (i32.const 43)) +(assert_return (invoke $M "get") (i32.const 42)) +(assert_return (invoke $N "M.get") (i32.const 42)) +(assert_return (invoke $N "get") (i32.const 43)) + + +;; Tables + +(module $M + (type (func (result i32))) + (type (func)) + + (table (export "tab") 10 anyfunc) + (elem (i32.const 2) $g $g $g $g) + (func $g (result i32) (i32.const 4)) + (func (export "h") (result i32) (i32.const -4)) + + (func (export "call") (param i32) (result i32) + (call_indirect 0 (get_local 0)) + ) +) +(register "M" $M) + +(module $N + (type (func)) + (type (func (result i32))) + + (func $f (import "M" "call") (param i32) (result i32)) + (func $h (import "M" "h") (result i32)) + + (table anyfunc (elem $g $g $g $h $f)) + (func $g (result i32) (i32.const 5)) + + (export "M.call" (func $f)) + (func (export "call M.call") (param i32) (result i32) + (call $f (get_local 0)) + ) + (func (export "call") (param i32) (result i32) + (call_indirect 1 (get_local 0)) + ) +) + +(assert_return (invoke $M "call" (i32.const 2)) (i32.const 4)) +(assert_return (invoke $N "M.call" (i32.const 2)) (i32.const 4)) +(assert_return (invoke $N "call" (i32.const 2)) (i32.const 5)) +(assert_return (invoke $N "call M.call" (i32.const 2)) (i32.const 4)) + +(assert_trap (invoke $M "call" (i32.const 1)) "uninitialized") +(assert_trap (invoke $N "M.call" (i32.const 1)) "uninitialized") +(assert_return (invoke $N "call" (i32.const 1)) (i32.const 5)) +(assert_trap (invoke $N "call M.call" (i32.const 1)) "uninitialized") + +(assert_trap (invoke $M "call" (i32.const 0)) "uninitialized") +(assert_trap (invoke $N "M.call" (i32.const 0)) "uninitialized") +(assert_return (invoke $N "call" (i32.const 0)) (i32.const 5)) +(assert_trap (invoke $N "call M.call" (i32.const 0)) "uninitialized") + +(assert_trap (invoke $M "call" (i32.const 20)) "undefined") +(assert_trap (invoke $N "M.call" (i32.const 20)) "undefined") +(assert_trap (invoke $N "call" (i32.const 7)) "undefined") +(assert_trap (invoke $N "call M.call" (i32.const 20)) "undefined") + +(assert_return (invoke $N "call" (i32.const 3)) (i32.const -4)) +(assert_trap (invoke $N "call" (i32.const 4)) "indirect call") + +(module $O + (type (func (result i32))) + + (func $h (import "M" "h") (result i32)) + (table (import "M" "tab") 5 anyfunc) + (elem (i32.const 1) $i $h) + (func $i (result i32) (i32.const 6)) + + (func (export "call") (param i32) (result i32) + (call_indirect 0 (get_local 0)) + ) +) + +(assert_return (invoke $M "call" (i32.const 3)) (i32.const 4)) +(assert_return (invoke $N "M.call" (i32.const 3)) (i32.const 4)) +(assert_return (invoke $N "call M.call" (i32.const 3)) (i32.const 4)) +(assert_return (invoke $O "call" (i32.const 3)) (i32.const 4)) + +(assert_return (invoke $M "call" (i32.const 2)) (i32.const -4)) +(assert_return (invoke $N "M.call" (i32.const 2)) (i32.const -4)) +(assert_return (invoke $N "call" (i32.const 2)) (i32.const 5)) +(assert_return (invoke $N "call M.call" (i32.const 2)) (i32.const -4)) +(assert_return (invoke $O "call" (i32.const 2)) (i32.const -4)) + +(assert_return (invoke $M "call" (i32.const 1)) (i32.const 6)) +(assert_return (invoke $N "M.call" (i32.const 1)) (i32.const 6)) +(assert_return (invoke $N "call" (i32.const 1)) (i32.const 5)) +(assert_return (invoke $N "call M.call" (i32.const 1)) (i32.const 6)) +(assert_return (invoke $O "call" (i32.const 1)) (i32.const 6)) + +(assert_trap (invoke $M "call" (i32.const 0)) "uninitialized") +(assert_trap (invoke $N "M.call" (i32.const 0)) "uninitialized") +(assert_return (invoke $N "call" (i32.const 0)) (i32.const 5)) +(assert_trap (invoke $N "call M.call" (i32.const 0)) "uninitialized") +(assert_trap (invoke $O "call" (i32.const 0)) "uninitialized") + +(assert_trap (invoke $O "call" (i32.const 20)) "undefined") + + +;; Memories + +(module $M + (memory (export "mem") 1 5) + (data (i32.const 10) "\00\01\02\03\04\05\06\07\08\09") + + (func (export "load") (param $a i32) (result i32) + (i32.load8_u (get_local 0)) + ) +) +(register "M" $M) + +(module $N + (func $loadM (import "M" "load") (param i32) (result i32)) + + (memory 1) + (data (i32.const 10) "\f0\f1\f2\f3\f4\f5") + + (export "M.load" (func $loadM)) + (func (export "load") (param $a i32) (result i32) + (i32.load8_u (get_local 0)) + ) +) + +(assert_return (invoke $M "load" (i32.const 12)) (i32.const 2)) +(assert_return (invoke $N "M.load" (i32.const 12)) (i32.const 2)) +(assert_return (invoke $N "load" (i32.const 12)) (i32.const 0xf2)) + +(module $O + (memory (import "M" "mem") 1) + (data (i32.const 5) "\a0\a1\a2\a3\a4\a5\a6\a7") + + (func (export "load") (param $a i32) (result i32) + (i32.load8_u (get_local 0)) + ) +) + +(assert_return (invoke $M "load" (i32.const 12)) (i32.const 0xa7)) +(assert_return (invoke $N "M.load" (i32.const 12)) (i32.const 0xa7)) +(assert_return (invoke $N "load" (i32.const 12)) (i32.const 0xf2)) +(assert_return (invoke $O "load" (i32.const 12)) (i32.const 0xa7)) + +(module $P + (memory (import "M" "mem") 1 8) + + (func (export "grow") (param $a i32) (result i32) + (grow_memory (get_local 0)) + ) +) + +(assert_return (invoke $P "grow" (i32.const 0)) (i32.const 1)) +(assert_return (invoke $P "grow" (i32.const 2)) (i32.const 1)) +(assert_return (invoke $P "grow" (i32.const 0)) (i32.const 3)) +(assert_return (invoke $P "grow" (i32.const 1)) (i32.const 3)) +(assert_return (invoke $P "grow" (i32.const 1)) (i32.const 4)) +(assert_return (invoke $P "grow" (i32.const 0)) (i32.const 5)) +(assert_return (invoke $P "grow" (i32.const 1)) (i32.const -1)) +(assert_return (invoke $P "grow" (i32.const 0)) (i32.const 5))