diff --git a/ml-proto/host/js.ml b/ml-proto/host/js.ml index f66997d596..6eb014f2ad 100644 --- a/ml-proto/host/js.ml +++ b/ml-proto/host/js.ml @@ -1,3 +1,5 @@ +open Types +open Ast open Script open Source @@ -28,8 +30,8 @@ let prefix = " return new WebAssembly.Module(buffer);\n" ^ "}\n" ^ "\n" ^ - "function instance(bytes) {\n" ^ - " return new WebAssembly.Instance(module(bytes), registry);\n" ^ + "function instance(bytes, imports = registry) {\n" ^ + " return new WebAssembly.Instance(module(bytes), imports);\n" ^ "}\n" ^ "\n" ^ "function assert_malformed(bytes) {\n" ^ @@ -69,6 +71,106 @@ let prefix = "\n" +(* Context *) + +module Map = Map.Make(String) + +type exports = external_type Map.t +type modules = exports Map.t + +let exports m = + List.fold_left + (fun map exp -> Map.add exp.it.name (export_type m exp) map) + Map.empty m.it.exports + +let of_var_opt = function + | None -> "$$" + | Some x -> x.it + +let bind mods x_opt m = + let exports = exports m in + mods := Map.add "$$" exports (Map.add (of_var_opt x_opt) exports !mods) + +let lookup mods x_opt name at = + let exports = + try Map.find (of_var_opt x_opt) !mods with Not_found -> + raise (Eval.Crash (at, + if x_opt = None then "no module defined within script" + else "unknown module " ^ of_var_opt x_opt ^ " within script")) + in try Map.find name exports with Not_found -> + raise (Eval.Crash (at, "unknown export \"" ^ name ^ "\" within module")) + + +(* Wrappers *) + +let eq_of = function + | I32Type -> Values.I32 I32Op.Eq + | I64Type -> Values.I64 I64Op.Eq + | F32Type -> Values.F32 F32Op.Eq + | F64Type -> Values.F64 F64Op.Eq + +let types_of lits = List.map (fun lit -> Values.type_of lit.it) lits + +let invoke t lits at = + [t], FuncImport (1l @@ at) @@ at, + List.map (fun lit -> Const lit @@ at) lits @ [Call (0l @@ at) @@ at] + +let get t at = + [], GlobalImport t @@ at, [GetGlobal (0l @@ at) @@ at] + +let assert_nothing ts at = + [], [] + +let assert_return lits ts at = + let test lit = + [ Const lit @@ at; + Compare (eq_of (Values.type_of lit.it)) @@ at; + Test (Values.I32 I32Op.Eqz) @@ at; + BrIf (0, 0l @@ at) @@ at ] + in [], List.flatten (List.rev_map test lits) + +let assert_return_nan ts at = + let var i = Int32.of_int i @@ at in + let init i t = [GetLocal (var i) @@ at; SetLocal (var i) @@ at] in + let test i t = + [ GetLocal (var i) @@ at; + GetLocal (var i) @@ at; + Compare (eq_of t) @@ at; + BrIf (0, 0l @@ at) @@ at ] + in ts, List.flatten (List.mapi init ts @ List.mapi test ts) + +let wrap module_name item_name wrap_action wrap_assertion at = + let itypes, ikind, action = wrap_action at in + let locals, assertion = wrap_assertion at in + let item = Lib.List32.length itypes @@ at in + let types = FuncType ([], []) :: itypes in + let imports = [{module_name; item_name; ikind} @@ at] in + let ekind = FuncExport @@ at in + let exports = [{name = "run"; ekind; item} @@ at] in + let body = + [Block (action @ assertion @ [Return @@ at]) @@ at; Unreachable @@ at] in + let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in + let m = {empty_module with types; funcs; imports; exports} @@ at in + Encode.encode m + + +let is_js_value_type = function + | I32Type -> true + | I64Type | F32Type | F64Type -> false + +let is_js_global_type = function + | GlobalType (t, mut) -> is_js_value_type t && mut = Immutable + +let is_js_func_type = function + | FuncType (ins, out) -> List.for_all is_js_value_type (ins @ out) + +let is_js_external_type = function + | ExternalFuncType t -> is_js_func_type t + | ExternalTableType _ + | ExternalMemoryType _ -> true + | ExternalGlobalType t -> is_js_global_type t + + (* Script conversion *) let add_hex_char buf c = Printf.bprintf buf "\\x%02x" (Char.code c) @@ -90,6 +192,11 @@ let of_string_with add_char s = let of_bytes = of_string_with add_hex_char let of_string = of_string_with add_char +let of_wrapper x_opt name wrap_action wrap_assertion at = + let x = of_var_opt x_opt in + let bs = wrap x name wrap_action wrap_assertion at in + "instance(" ^ of_bytes bs ^ ", " ^ "{" ^ x ^ "}).exports.run()" + let of_float z = match string_of_float z with | "nan" -> "NaN" @@ -105,10 +212,6 @@ let of_literal lit = | Values.F32 z -> of_float (F32.to_float z) | Values.F64 z -> of_float (F64.to_float z) -let of_var_opt = function - | None -> "$$" - | Some x -> x.it - let of_definition def = let bs = match def.it with @@ -116,42 +219,78 @@ let of_definition def = | Binary (_, bs) -> bs in of_bytes bs -let of_action act = +let of_action mods act = match act.it with | Invoke (x_opt, name, lits) -> of_var_opt x_opt ^ ".exports[" ^ of_string name ^ "]" ^ - "(" ^ String.concat ", " (List.map of_literal lits) ^ ")" + "(" ^ String.concat ", " (List.map of_literal lits) ^ ")", + (match lookup mods x_opt name act.at with + | ExternalFuncType ft when not (is_js_func_type ft) -> + let FuncType (_, out) = ft in + Some (of_wrapper x_opt name (invoke ft lits), out) + | _ -> None + ) | Get (x_opt, name) -> - of_var_opt x_opt ^ ".exports[" ^ of_string name ^ "]" + of_var_opt x_opt ^ ".exports[" ^ of_string name ^ "]", + (match lookup mods x_opt name act.at with + | ExternalGlobalType gt when not (is_js_global_type gt) -> + let GlobalType (t, _) = gt in + Some (of_wrapper x_opt name (get gt), [t]) + | _ -> None + ) + +let of_return_assertion mods act js wrapper = + match of_action mods act with + | act_js, None -> js act_js ^ ";" + | act_js, Some (act_wrapper, out) -> + act_wrapper (wrapper out) act.at ^ "; // " ^ js act_js -let of_assertion ass = +let of_assertion mods ass = match ass.it with | AssertMalformed (def, _) -> - "assert_malformed(" ^ of_definition def ^ ")" + "assert_malformed(" ^ of_definition def ^ ");" | AssertInvalid (def, _) -> - "assert_invalid(" ^ of_definition def ^ ")" + "assert_invalid(" ^ of_definition def ^ ");" | AssertUnlinkable (def, _) -> - "assert_unlinkable(" ^ of_definition def ^ ")" + "assert_unlinkable(" ^ of_definition def ^ ");" | AssertReturn (act, lits) -> - "assert_return(() => " ^ of_action act ^ ", " ^ - String.concat ", " (List.map of_literal lits) ^ ")" + of_return_assertion mods act + (fun act_js -> + "assert_return(() => " ^ act_js ^ + String.concat ", " ("" :: List.map of_literal lits) ^ ")") + (assert_return lits) | AssertReturnNaN act -> - "assert_return_nan(() => " ^ of_action act ^ ")" + of_return_assertion mods act + (fun act_js -> "assert_return_nan(() => " ^ act_js ^ ")") + assert_return_nan | AssertTrap (act, _) -> - "assert_trap(() => " ^ of_action act ^ ")" + let js act_js = "assert_trap(() => " ^ act_js ^ ")" in + match of_action mods act with + | act_js, None -> js act_js ^ ";" + | act_js, Some (act_wrapper, ts) -> + js (act_wrapper (assert_nothing ts) act.at) ^ "; // " ^ js act_js -let of_command cmd = +let of_command mods cmd = match cmd.it with | Module (x_opt, def) -> + let m = + match def.it with + | Textual m -> m + | Binary (_, bs) -> Decode.decode "binary" bs + in bind mods x_opt m; (if x_opt = None then "" else "let " ^ of_var_opt x_opt ^ " = ") ^ "$$ = instance(" ^ of_definition def ^ ");\n" | Register (name, x_opt) -> "register(" ^ of_string name ^ ", " ^ of_var_opt x_opt ^ ")\n" | Action act -> - of_action act ^ ";\n" + (match of_action mods act with + | js, None -> js ^ ";\n" + | js, Some (wrapper, ts) -> + wrapper (assert_nothing ts) act.at ^ "; // " ^ js ^ "\n" + ) | Assertion ass -> - of_assertion ass ^ ";\n" + of_assertion mods ass ^ "\n" | Meta _ -> assert false let of_script scr = - prefix ^ String.concat "" (List.map of_command scr) + prefix ^ String.concat "" (List.map (of_command (ref Map.empty)) scr) diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index 2ad00cffab..6f9b83f070 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -7,6 +7,9 @@ import glob import sys +# Set to run tests through JS as well +jsCommand = "" + def auxFile(path): try: os.remove(path) @@ -75,6 +78,8 @@ def _runTestFile(self, shortName, fileName, interpreterPath): jsPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".js")) logPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".js.log")) self._runCommand(("%s -d '%s' -o '%s'") % (interpreterPath, fileName, jsPath)) + if jsCommand != "": + self._runCommand(("%s '%s'") % (jsCommand, jsPath)) def generate_test_case(rec): return lambda self : self._runTestFile(*rec) diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index c57a37ef07..87f0f603af 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -186,3 +186,55 @@ and module_' = imports : import list; exports : export list; } + + +let empty_module = +{ + types = []; + globals = []; + tables = []; + memories = []; + funcs = []; + start = None; + elems = []; + data = []; + imports = []; + exports = []; +} + + +(* Auxiliary functions *) + +let import_type (m : module_) ekind (item : int32) = + let open Source in + let rec loop i imps = + let i' = Int32.sub i 1l in + match imps with + | [] -> i, None + | imp::imps' -> + match imp.it.ikind.it, ekind.it with + | FuncImport x, FuncExport -> + if i = 0l + then i, Some (ExternalFuncType (Lib.List32.nth m.it.types x.it)) + else loop i' imps' + | TableImport t, TableExport -> + if i = 0l then i, Some (ExternalTableType t) else loop i' imps' + | MemoryImport t, MemoryExport -> + if i = 0l then i, Some (ExternalMemoryType t) else loop i' imps' + | GlobalImport t, GlobalExport -> + if i = 0l then i, Some (ExternalGlobalType t) else loop i' imps' + | _ -> loop i imps' + in loop item m.it.imports + +let export_type (m : module_) (exp : export) = + let open Source in + match import_type m exp.it.ekind exp.it.item.it with + | _, Some t -> t + | n, None -> + match exp.it.ekind.it with + | FuncExport -> + ExternalFuncType + (Lib.List32.nth m.it.types (Lib.List32.nth m.it.funcs n).it.ftype.it) + | TableExport -> ExternalTableType (Lib.List32.nth m.it.tables n).it.ttype + | MemoryExport -> ExternalMemoryType (Lib.List32.nth m.it.memories n).it.mtype + | GlobalExport -> ExternalGlobalType (Lib.List32.nth m.it.globals n).it.gtype diff --git a/ml-proto/test/exports.wast b/ml-proto/test/exports.wast index d2098150d2..fdbb052b09 100644 --- a/ml-proto/test/exports.wast +++ b/ml-proto/test/exports.wast @@ -16,7 +16,7 @@ (assert_return (invoke "e" (i32.const 42)) (i32.const 43)) (assert_return (invoke $Func "e" (i32.const 42)) (i32.const 43)) (module) -(module $Other) +(module $Other1) (assert_return (invoke $Func "e" (i32.const 42)) (i32.const 43)) (assert_invalid @@ -61,7 +61,7 @@ (assert_return (get "e") (i32.const 42)) (assert_return (get $Global "e") (i32.const 42)) (module) -(module $Other) +(module $Other2) (assert_return (get $Global "e") (i32.const 42)) (assert_invalid