Create wrapper modules for tests that JS can't handle

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,53 +212,85 @@ 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
     | Textual m -> Encode.encode m
     | 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)

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)

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

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