diff --git a/interpreter/README.md b/interpreter/README.md index 18aa36c05e..b64b41c401 100644 --- a/interpreter/README.md +++ b/interpreter/README.md @@ -391,10 +391,15 @@ module: ( module ? quote * ) ;; module quoted in text (may be malformed) action: - ( invoke ? * ) ;; invoke function export + ( invoke ? * ) ;; invoke function export ( get ? ) ;; get global export + ( set ? ) ;; set global export -const: +arg: + ;; literal argument + ;; expression argument + +literal: ( .const ) ;; number value ( + ) ;; vector value ( ref.null ) ;; null reference @@ -410,7 +415,7 @@ assertion: ( assert_trap ) ;; assert module traps on instantiation result: - + ( .const ) ( .const + ) ( ref.extern ) diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index 2eb849a6c1..2a3502a900 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -59,6 +59,7 @@ let registry = new Proxy({spectest}, handler); function register(name, instance) { registry[name] = instance.exports; + return instance; } function module(bytes, valid = true) { @@ -74,7 +75,19 @@ function module(bytes, valid = true) { throw new Error("Wasm validate throws"); } if (validated !== valid) { - throw new Error("Wasm validate failure" + (valid ? "" : " expected")); + let error; + skip: if (valid) { + try { + new WebAssembly.Module(buffer); + } catch (e) { + error = ": " + e; + break skip; + } + throw new Error("Wasm compile does not throw, although validation failed"); + } else { + error = " expected"; + } + throw new Error("Wasm validate failure" + error); } return new WebAssembly.Module(buffer); } @@ -88,12 +101,19 @@ function call(instance, name, args) { } function get(instance, name) { - let v = instance.exports[name]; - return (v instanceof WebAssembly.Global) ? v.value : v; + let global = instance.exports[name]; + if (global instanceof WebAssembly.Global) return global.value; + throw new Error("Wasm global expected"); } -function exports(instance) { - return {module: instance.exports, spectest: spectest}; +function set(instance, name, arg) { + let global = instance.exports[name]; + if (global instanceof WebAssembly.Global) { + try { + global.value = arg; return; + } catch (e) {} + } + throw new Error("Wasm mutable global expected"); } function run(action) { @@ -103,6 +123,7 @@ function run(action) { function assert_malformed(bytes) { try { module(bytes, false) } catch (e) { if (e instanceof WebAssembly.CompileError) return; + throw new Error("Wasm decoding failure expected, got: " + e); } throw new Error("Wasm decoding failure expected"); } @@ -110,6 +131,7 @@ function assert_malformed(bytes) { function assert_invalid(bytes) { try { module(bytes, false) } catch (e) { if (e instanceof WebAssembly.CompileError) return; + throw new Error("Wasm validation failure expected, got: " + e); } throw new Error("Wasm validation failure expected"); } @@ -118,6 +140,7 @@ function assert_unlinkable(bytes) { let mod = module(bytes); try { new WebAssembly.Instance(mod, registry) } catch (e) { if (e instanceof WebAssembly.LinkError) return; + throw new Error("Wasm linking failure expected, got: " + e); } throw new Error("Wasm linking failure expected"); } @@ -126,6 +149,7 @@ function assert_uninstantiable(bytes) { let mod = module(bytes); try { new WebAssembly.Instance(mod, registry) } catch (e) { if (e instanceof WebAssembly.RuntimeError) return; + throw new Error("Wasm trap failure expected, got: " + e); } throw new Error("Wasm trap expected"); } @@ -133,6 +157,7 @@ function assert_uninstantiable(bytes) { function assert_trap(action) { try { action() } catch (e) { if (e instanceof WebAssembly.RuntimeError) return; + throw new Error("Wasm trap expected, got: " + e); } throw new Error("Wasm trap expected"); } @@ -143,6 +168,7 @@ try { (function f() { 1 + f() })() } catch (e) { StackOverflow = e.constructor } function assert_exhaustion(action) { try { action() } catch (e) { if (e instanceof StackOverflow) return; + throw new Error("Wasm resource exhaustion expected, got: " + e); } throw new Error("Wasm resource exhaustion expected"); } @@ -188,6 +214,26 @@ function assert_return(action, ...expected) { |} +(* Errors & Tracing *) + +module Error = Error.Make () + +exception Error = Error.Error + +exception UnsupportedByJs + +let js_val_type = function + | NumType _ -> () + | VecType _ -> raise UnsupportedByJs + | RefType _ -> () + +let js_global_type = function + | GlobalType (t, _mut) -> js_val_type t + +let js_func_type = function + | FuncType (ts1, ts2) -> List.iter js_val_type (ts1 @ ts2) + + (* Context *) module NameMap = Map.Make(struct type t = Ast.name let compare = compare end) @@ -204,36 +250,105 @@ let exports m : exports = let modules () : modules = {env = Map.empty; current = 0} let current_var (mods : modules) = "$" ^ string_of_int mods.current -let of_var_opt (mods : modules) = function +let var_opt (mods : modules) = function | None -> current_var mods | Some x -> x.it let bind (mods : modules) x_opt m = let exports = exports m in mods.current <- mods.current + 1; - mods.env <- Map.add (of_var_opt mods x_opt) exports mods.env; + mods.env <- Map.add (var_opt mods x_opt) exports mods.env; if x_opt <> None then mods.env <- Map.add (current_var mods) exports mods.env let lookup (mods : modules) x_opt name at = let exports = - try Map.find (of_var_opt mods x_opt) mods.env with Not_found -> - raise (Eval.Crash (at, - if x_opt = None then "no module defined within script" - else "unknown module " ^ of_var_opt mods x_opt ^ " within script")) + try Map.find (var_opt mods x_opt) mods.env with Not_found -> + Error.error at + (if x_opt = None then "no module defined within script" + else "unknown module " ^ var_opt mods x_opt ^ " within script") in try NameMap.find name exports with Not_found -> - raise (Eval.Crash (at, "unknown export \"" ^ - string_of_name name ^ "\" within module")) - + Error.error at ("unknown export \"" ^ + string_of_name name ^ "\" within module") + +let lookup_func (mods : modules) x_opt name at = + match lookup mods x_opt name at with + | ExternFuncType ft -> ft + | _ -> + Error.error at ("export \"" ^ + string_of_name name ^ "\" is not a function") + +let lookup_global (mods : modules) x_opt name at = + match lookup mods x_opt name at with + | ExternGlobalType gt -> gt + | _ -> + Error.error at ("export \"" ^ + string_of_name name ^ "\" is not a global") + + +(* Dependencies for Wasm wrappers *) + +type deps = + { mutable dtypes : func_type list; + mutable descs : (import_desc' * int32) NameMap.t Map.t; + func_idx : int32 ref; + global_idx : int32 ref; + } -(* Wrappers *) +let new_deps () = + { dtypes = []; descs = Map.empty; + func_idx = ref 0l; global_idx = ref 0l } -let subject_idx = 0l -let externref_idx = 1l -let is_externref_idx = 2l -let is_funcref_idx = 3l -let eq_externref_idx = 4l -let _eq_funcref_idx = 5l -let subject_type_idx = 6l +let dep deps x name idxr idesc = + let nmap = + match Map.find_opt x deps.descs with + | Some nmap -> nmap + | None -> NameMap.empty + in + match NameMap.find_opt name nmap with + | Some (_, idx) -> idx + | None -> + let idx = !idxr in + deps.descs <- + Map.add x (NameMap.add name (idesc, idx) nmap) deps.descs; + idxr := Int32.add idx 1l; + idx + +let dep_type deps ft = + match Lib.List.index_of ft deps.dtypes with + | Some i -> Int32.of_int i + | None -> + let idx = Lib.List32.length deps.dtypes in + deps.dtypes <- deps.dtypes @ [ft]; + idx + +let dep_global deps x name gt = + dep deps x name deps.global_idx (GlobalImport gt) + +let dep_func deps x name ft = + dep deps x name deps.func_idx + (FuncImport (dep_type deps ft @@ Source.no_region)) + +let dep_spectest deps name ft = + dep_func deps "spectest" (Utf8.decode name) ft + +let dep_spectest_externref deps = + dep_spectest deps "externref" + (FuncType ([NumType I32Type], [RefType ExternRefType])) +let dep_spectest_is_externref deps = + dep_spectest deps "is_externref" + (FuncType ([RefType ExternRefType], [NumType I32Type])) +let dep_spectest_is_funcref deps = + dep_spectest deps "is_funcref" + (FuncType ([RefType FuncRefType], [NumType I32Type])) +let dep_spectest_eq_externref deps = + dep_spectest deps "eq_externref" + (FuncType ([RefType ExternRefType; RefType ExternRefType], [NumType I32Type])) +let _dep_spectest_eq_funcref deps = + dep_spectest deps "eq_funcref" + (FuncType ([RefType FuncRefType; RefType FuncRefType], [NumType I32Type])) + + +(* Script conversion to Wasm wrappers *) let eq_of = function | I32Type -> Values.I32 I32Op.Eq @@ -259,183 +374,184 @@ let abs_mask_of = function | I32Type | F32Type -> Values.I32 Int32.max_int | I64Type | F64Type -> Values.I64 Int64.max_int -let value v = - match v.it with - | Values.Num n -> [Const (n @@ v.at) @@ v.at] - | Values.Vec s -> [VecConst (s @@ v.at) @@ v.at] - | Values.Ref (Values.NullRef t) -> [RefNull t @@ v.at] +let nan_bitmask_of = function + | CanonicalNan -> abs_mask_of + | ArithmeticNan -> canonical_nan_of + + +let wasm_literal deps lit : instr list = + match lit.it with + | Values.Num n -> [Const (n @@ lit.at) @@ lit.at] + | Values.Vec s -> [VecConst (s @@ lit.at) @@ lit.at] + | Values.Ref (Values.NullRef t) -> [RefNull t @@ lit.at] | Values.Ref (ExternRef n) -> - [Const (Values.I32 n @@ v.at) @@ v.at; Call (externref_idx @@ v.at) @@ v.at] + let externref_idx = dep_spectest_externref deps in + [ Const (Values.I32 n @@ lit.at) @@ lit.at; + Call (externref_idx @@ lit.at) @@ lit.at; + ] | Values.Ref _ -> assert false -let invoke ft vs at = - [ft @@ at], FuncImport (subject_type_idx @@ at) @@ at, - List.concat (List.map value vs) @ [Call (subject_idx @@ at) @@ at] - -let get t at = - [], GlobalImport t @@ at, [GlobalGet (subject_idx @@ at) @@ at] +let rec wasm_action mods deps act : instr list * value_type list = + match act.it with + | Invoke (x_opt, name, args) -> + let FuncType (_, ts2) as ft = lookup_func mods x_opt name act.at in + let idx = dep_func deps (var_opt mods x_opt) name ft in + List.concat_map (wasm_argument mods deps) args @ + [Call (idx @@ act.at) @@ act.at], ts2 + | Get (x_opt, name) -> + let GlobalType (t, _) as gt = lookup_global mods x_opt name act.at in + let idx = dep_global deps (var_opt mods x_opt) name gt in + [GlobalGet (idx @@ act.at) @@ act.at], [t] + | Set (x_opt, name, arg) -> + let GlobalType (t, _) as gt = lookup_global mods x_opt name act.at in + let idx = dep_global deps (var_opt mods x_opt) name gt in + wasm_argument mods deps arg @ + [GlobalSet (idx @@ act.at) @@ act.at], [] + +and wasm_argument mods deps arg : instr list = + match arg.it with + | LiteralArg lit -> wasm_literal deps lit + | ActionArg act -> fst (wasm_action mods deps act) + +let wasm_result deps res : instr list = + let at = res.at in + match res.it with + | NumResult (NumPat {it = num; at = at'}) -> + let t', reinterpret = reinterpret_of (Values.type_of_num num) in + [ reinterpret @@ at; + Const (num @@ at') @@ at; + reinterpret @@ at; + Compare (eq_of t') @@ at; + Test (Values.I32 I32Op.Eqz) @@ at; + BrIf (0l @@ at) @@ at; + ] + | NumResult (NanPat nanop) -> + let open Values in + let nan = match nanop.it with F32 n | F64 n -> n | I32 _ | I64 _ -> . in + let t = Values.type_of_num nanop.it in + let t', reinterpret = reinterpret_of t in + [ reinterpret @@ at; + Const (nan_bitmask_of nan t' @@ at) @@ at; + Binary (and_of t') @@ at; + Const (canonical_nan_of t' @@ at) @@ at; + Compare (eq_of t') @@ at; + Test (Values.I32 I32Op.Eqz) @@ at; + BrIf (0l @@ at) @@ at; + ] + | VecResult (VecPat (Values.V128 (shape, pats))) -> + let open Values in + (* VecResult is a list of NumPat or LitPat. For float shapes, we can have a mix of literals + * and NaNs. For NaNs, we need to mask it and compare with a canonical NaN. To simplify + * comparison, we build masks even for literals (will just be all set), collect them into + * a v128, then compare the entire 128 bits. + *) + let mask_and_canonical = function + | NumPat {it = I32 _ as i; _} -> I32 (Int32.minus_one), i + | NumPat {it = I64 _ as i; _} -> I64 (Int64.minus_one), i + | NumPat {it = F32 f; _} -> + I32 (Int32.minus_one), I32 (I32_convert.reinterpret_f32 f) + | NumPat {it = F64 f; _} -> + I64 (Int64.minus_one), I64 (I64_convert.reinterpret_f64 f) + | NanPat {it = F32 nan; _} -> + nan_bitmask_of nan I32Type, canonical_nan_of I32Type + | NanPat {it = F64 nan; _} -> + nan_bitmask_of nan I64Type, canonical_nan_of I64Type + | _ -> . + in + let masks, canons = List.split (List.map (fun p -> mask_and_canonical p) pats) in + let all_ones = V128.I32x4.of_lanes (List.init 4 (fun _ -> Int32.minus_one)) in + let mask, expected = + match shape with + | V128.I8x16 () -> + all_ones, V128.I8x16.of_lanes (List.map (I32Num.of_num 0) canons) + | V128.I16x8 () -> + all_ones, V128.I16x8.of_lanes (List.map (I32Num.of_num 0) canons) + | V128.I32x4 () -> + all_ones, V128.I32x4.of_lanes (List.map (I32Num.of_num 0) canons) + | V128.I64x2 () -> + all_ones, V128.I64x2.of_lanes (List.map (I64Num.of_num 0) canons) + | V128.F32x4 () -> + V128.I32x4.of_lanes (List.map (I32Num.of_num 0) masks), + V128.I32x4.of_lanes (List.map (I32Num.of_num 0) canons) + | V128.F64x2 () -> + V128.I64x2.of_lanes (List.map (I64Num.of_num 0) masks), + V128.I64x2.of_lanes (List.map (I64Num.of_num 0) canons) + in + [ VecConst (V128 mask @@ at) @@ at; + VecBinaryBits (V128 V128Op.And) @@ at; + VecConst (V128 expected @@ at) @@ at; + VecCompare (V128 (V128.I8x16 V128Op.Eq)) @@ at; + (* If all lanes are non-zero, then they are equal *) + VecTest (V128 (V128.I8x16 V128Op.AllTrue)) @@ at; + Test (I32 I32Op.Eqz) @@ at; + BrIf (0l @@ at) @@ at; + ] + | RefResult (RefPat {it = Values.NullRef t; _}) -> + [ RefIsNull @@ at; + Test (Values.I32 I32Op.Eqz) @@ at; + BrIf (0l @@ at) @@ at; + ] + | RefResult (RefPat {it = ExternRef n; _}) -> + let externref_idx = dep_spectest_externref deps in + let eq_externref_idx = dep_spectest_eq_externref deps in + [ Const (Values.I32 n @@ at) @@ at; + Call (externref_idx @@ at) @@ at; + Call (eq_externref_idx @@ at) @@ at; + Test (Values.I32 I32Op.Eqz) @@ at; + BrIf (0l @@ at) @@ at; + ] + | RefResult (RefPat _) -> + assert false + | RefResult (RefTypePat t) -> + let is_ref_idx = + match t with + | FuncRefType -> dep_spectest_is_funcref deps + | ExternRefType -> dep_spectest_is_externref deps + in + [ Call (is_ref_idx @@ at) @@ at; + Test (Values.I32 I32Op.Eqz) @@ at; + BrIf (0l @@ at) @@ at; + ] -let run ts at = - [], [] +let wasm_assertion mods deps ass : instr list * value_type list = + match ass.it with + | AssertReturn (act, ress) -> + [ Block (ValBlockType None, + fst (wasm_action mods deps act) @ + List.concat_map (wasm_result deps) (List.rev ress) @ + [Return @@ ass.at] + ) @@ ass.at; + Unreachable @@ ass.at; + ], [] + | _ -> assert false -let assert_return ress ts at = - let test res = - let nan_bitmask_of = function - | CanonicalNan -> abs_mask_of (* must only differ from the canonical NaN in its sign bit *) - | ArithmeticNan -> canonical_nan_of (* can be any NaN that's one everywhere the canonical NaN is one *) - in - match res.it with - | NumResult (NumPat {it = num; at = at'}) -> - let t', reinterpret = reinterpret_of (Values.type_of_num num) in - [ reinterpret @@ at; - Const (num @@ at') @@ at; - reinterpret @@ at; - Compare (eq_of t') @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at ] - | NumResult (NanPat nanop) -> - let nan = - match nanop.it with - | Values.I32 _ | Values.I64 _ -> . - | Values.F32 n | Values.F64 n -> n - in - let t = Values.type_of_num nanop.it in - let t', reinterpret = reinterpret_of t in - [ reinterpret @@ at; - Const (nan_bitmask_of nan t' @@ at) @@ at; - Binary (and_of t') @@ at; - Const (canonical_nan_of t' @@ at) @@ at; - Compare (eq_of t') @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at ] - | VecResult (VecPat (Values.V128 (shape, pats))) -> - let open Values in - (* VecResult is a list of NumPat or LitPat. For float shapes, we can have a mix of literals - * and NaNs. For NaNs, we need to mask it and compare with a canonical NaN. To simplify - * comparison, we build masks even for literals (will just be all set), collect them into - * a v128, then compare the entire 128 bits. - *) - let mask_and_canonical = function - | NumPat {it = I32 _ as i; _} -> I32 (Int32.minus_one), i - | NumPat {it = I64 _ as i; _} -> I64 (Int64.minus_one), i - | NumPat {it = F32 f; _} -> - I32 (Int32.minus_one), I32 (I32_convert.reinterpret_f32 f) - | NumPat {it = F64 f; _} -> - I64 (Int64.minus_one), I64 (I64_convert.reinterpret_f64 f) - | NanPat {it = F32 nan; _} -> - nan_bitmask_of nan I32Type, canonical_nan_of I32Type - | NanPat {it = F64 nan; _} -> - nan_bitmask_of nan I64Type, canonical_nan_of I64Type - | _ -> . - in - let masks, canons = List.split (List.map (fun p -> mask_and_canonical p) pats) in - let all_ones = V128.I32x4.of_lanes (List.init 4 (fun _ -> Int32.minus_one)) in - let mask, expected = match shape with - | V128.I8x16 () -> - all_ones, V128.I8x16.of_lanes (List.map (I32Num.of_num 0) canons) - | V128.I16x8 () -> - all_ones, V128.I16x8.of_lanes (List.map (I32Num.of_num 0) canons) - | V128.I32x4 () -> - all_ones, V128.I32x4.of_lanes (List.map (I32Num.of_num 0) canons) - | V128.I64x2 () -> - all_ones, V128.I64x2.of_lanes (List.map (I64Num.of_num 0) canons) - | V128.F32x4 () -> - V128.I32x4.of_lanes (List.map (I32Num.of_num 0) masks), - V128.I32x4.of_lanes (List.map (I32Num.of_num 0) canons) - | V128.F64x2 () -> - V128.I64x2.of_lanes (List.map (I64Num.of_num 0) masks), - V128.I64x2.of_lanes (List.map (I64Num.of_num 0) canons) - in - [ VecConst (V128 mask @@ at) @@ at; - VecBinaryBits (V128 V128Op.And) @@ at; - VecConst (V128 expected @@ at) @@ at; - VecCompare (V128 (V128.I8x16 V128Op.Eq)) @@ at; - (* If all lanes are non-zero, then they are equal *) - VecTest (V128 (V128.I8x16 V128Op.AllTrue)) @@ at; - Test (I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at ] - | RefResult (RefPat {it = Values.NullRef t; _}) -> - [ RefIsNull @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at ] - | RefResult (RefPat {it = ExternRef n; _}) -> - [ Const (Values.I32 n @@ at) @@ at; - Call (externref_idx @@ at) @@ at; - Call (eq_externref_idx @@ at) @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at ] - | RefResult (RefPat _) -> - assert false - | RefResult (RefTypePat t) -> - let is_ref_idx = - match t with - | FuncRefType -> is_funcref_idx - | ExternRefType -> is_externref_idx - in - [ Call (is_ref_idx @@ at) @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at ] - in [], List.flatten (List.rev_map test ress) - -let wrap item_name wrap_action wrap_assertion at = - let itypes, idesc, action = wrap_action at in - let locals, assertion = wrap_assertion at in - let types = - (FuncType ([], []) @@ at) :: - (FuncType ([NumType I32Type], [RefType ExternRefType]) @@ at) :: - (FuncType ([RefType ExternRefType], [NumType I32Type]) @@ at) :: - (FuncType ([RefType FuncRefType], [NumType I32Type]) @@ at) :: - (FuncType ([RefType ExternRefType; RefType ExternRefType], [NumType I32Type]) @@ at) :: - (FuncType ([RefType FuncRefType; RefType FuncRefType], [NumType I32Type]) @@ at) :: - itypes - in +let wasm_module mk_code mods phrase : string = + let at = phrase.at in + let deps = new_deps () in + let code, ts = mk_code mods deps phrase in + let ts' = try List.iter js_val_type ts; ts with UnsupportedByJs -> [] in + let ftype = dep_type deps (FuncType ([], ts')) @@ at in + let types = List.map (fun ft -> ft @@ at) deps.dtypes in let imports = - [ {module_name = Utf8.decode "module"; item_name; idesc} @@ at; - {module_name = Utf8.decode "spectest"; item_name = Utf8.decode "externref"; - idesc = FuncImport (1l @@ at) @@ at} @@ at; - {module_name = Utf8.decode "spectest"; item_name = Utf8.decode "is_externref"; - idesc = FuncImport (2l @@ at) @@ at} @@ at; - {module_name = Utf8.decode "spectest"; item_name = Utf8.decode "is_funcref"; - idesc = FuncImport (3l @@ at) @@ at} @@ at; - {module_name = Utf8.decode "spectest"; item_name = Utf8.decode "eq_externref"; - idesc = FuncImport (4l @@ at) @@ at} @@ at; - {module_name = Utf8.decode "spectest"; item_name = Utf8.decode "eq_funcref"; - idesc = FuncImport (5l @@ at) @@ at} @@ at ] - in - let item = - List.fold_left - (fun i im -> - match im.it.idesc.it with FuncImport _ -> Int32.add i 1l | _ -> i - ) 0l imports @@ at + Map.bindings deps.descs |> + List.concat_map (fun (x, nmap) -> + NameMap.bindings nmap |> + List.map (fun (item_name, (idesc', idx)) -> + let idesc = idesc' @@ at in + idx, {module_name = Utf8.decode x; item_name; idesc} @@ at + ) + ) |> + List.sort compare |> List.map snd |> List.sort compare in - let edesc = FuncExport item @@ at in + let edesc = FuncExport (!(deps.func_idx) @@ at) @@ at in let exports = [{name = Utf8.decode "run"; edesc} @@ at] in - let body = - [ Block (ValBlockType None, action @ assertion @ [Return @@ at]) @@ at; - Unreachable @@ at ] - in - let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in + let body = code @ (if ts = ts' then [] else [Return @@ at]) in + let funcs = [{ftype; locals = []; body} @@ at] in let m = {empty_module with types; funcs; imports; exports} @@ at in Encode.encode m -let is_js_num_type = function - | I32Type -> true - | I64Type | F32Type | F64Type -> false - -let is_js_value_type = function - | NumType t -> is_js_num_type t - | VecType t -> false - | RefType t -> true - -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) - - -(* Script conversion *) +(* Script conversion to plain JS *) let add_hex_char buf c = Printf.bprintf buf "\\x%02x" (Char.code c) let add_char buf c = @@ -451,141 +567,125 @@ let add_unicode_char buf uc = else add_char buf (Char.chr uc) -let of_string_with iter add_char s = +let js_string_with iter add_char s = let buf = Buffer.create 256 in Buffer.add_char buf '\"'; iter (add_char buf) s; Buffer.add_char buf '\"'; Buffer.contents buf -let of_bytes = of_string_with String.iter add_hex_char -let of_name = of_string_with List.iter add_unicode_char +let js_bytes = js_string_with String.iter add_hex_char +let js_name = js_string_with List.iter add_unicode_char -let of_float z = - match string_of_float z with - | "nan" -> "NaN" - | "-nan" -> "-NaN" +let js_float z = + match Printf.sprintf "%.17g" z with + | "nan" | "-nan" -> raise UnsupportedByJs | "inf" -> "Infinity" | "-inf" -> "-Infinity" | s -> s -let of_num n = +let js_num n = let open Values in match n with | I32 i -> I32.to_string_s i - | I64 i -> "int64(\"" ^ I64.to_string_s i ^ "\")" - | F32 z -> of_float (F32.to_float z) - | F64 z -> of_float (F64.to_float z) + | I64 i -> I64.to_string_s i ^ "n" + | F32 z -> js_float (F32.to_float z) + | F64 z -> js_float (F64.to_float z) -let of_vec v = - let open Values in - match v with - | V128 v -> "v128(\"" ^ V128.to_string v ^ "\")" +let js_vec v = + raise UnsupportedByJs -let of_ref r = +let js_ref r = let open Values in match r with | NullRef _ -> "null" | ExternRef n -> "externref(" ^ Int32.to_string n ^ ")" - | _ -> assert false + | _ -> raise UnsupportedByJs -let of_value v = +let js_literal lit = let open Values in - match v.it with - | Num n -> of_num n - | Vec v -> of_vec v - | Ref r -> of_ref r - -let of_nan = function - | CanonicalNan -> "\"nan:canonical\"" - | ArithmeticNan -> "\"nan:arithmetic\"" - -let of_num_pat = function - | NumPat num -> of_num num.it - | NanPat nanop -> - match nanop.it with - | Values.I32 _ | Values.I64 _ -> . - | Values.F32 n | Values.F64 n -> of_nan n - -let of_vec_pat = function - | VecPat (Values.V128 (shape, pats)) -> - Printf.sprintf "v128(\"%s\")" (String.concat " " (List.map of_num_pat pats)) - -let of_ref_pat = function - | RefPat r -> of_ref r.it + match lit.it with + | Num n -> js_num n + | Vec v -> js_vec v + | Ref r -> js_ref r + +let js_num_pat = function + | NumPat num -> + if num = num then js_num num.it else raise UnsupportedByJs (* NaN *) + | NanPat nanop -> raise UnsupportedByJs + +let js_vec_pat = function + | VecPat _ -> raise UnsupportedByJs + +let js_ref_pat = function + | RefPat r -> js_ref r.it | RefTypePat t -> "\"ref." ^ string_of_refed_type t ^ "\"" -let of_result res = +let js_result res = match res.it with - | NumResult np -> of_num_pat np - | VecResult vp -> of_vec_pat vp - | RefResult rp -> of_ref_pat rp + | NumResult np -> js_num_pat np + | VecResult vp -> js_vec_pat vp + | RefResult rp -> js_ref_pat rp -let rec of_definition def = +let rec js_definition def = match def.it with - | Textual m -> of_bytes (Encode.encode m) - | Encoded (_, bs) -> of_bytes bs + | Textual m -> js_bytes (Encode.encode m) + | Encoded (_, bs) -> js_bytes bs | Quoted (_, s) -> - try of_definition (Parse.string_to_module s) with Parse.Syntax _ -> - of_bytes "" - -let of_wrapper mods x_opt name wrap_action wrap_assertion at = - let x = of_var_opt mods x_opt in - let bs = wrap name wrap_action wrap_assertion at in - "call(instance(" ^ of_bytes bs ^ ", " ^ - "exports(" ^ x ^ ")), " ^ " \"run\", [])" + try js_definition (Parse.string_to_module s) with Parse.Syntax _ -> + js_bytes "" -let of_action mods act = +let rec js_action mods act = match act.it with - | Invoke (x_opt, name, vs) -> - "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^ - "[" ^ String.concat ", " (List.map of_value vs) ^ "])", - (match lookup mods x_opt name act.at with - | ExternFuncType ft when not (is_js_func_type ft) -> - let FuncType (_, out) = ft in - Some (of_wrapper mods x_opt name (invoke ft vs), out) - | _ -> None - ) + | Invoke (x_opt, name, args) -> + js_func_type (lookup_func mods x_opt name act.at); + "call(" ^ var_opt mods x_opt ^ ", " ^ js_name name ^ ", " ^ + "[" ^ String.concat ", " (List.map (js_argument mods) args) ^ + "].flat())" | Get (x_opt, name) -> - "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")", - (match lookup mods x_opt name act.at with - | ExternGlobalType gt when not (is_js_global_type gt) -> - let GlobalType (t, _) = gt in - Some (of_wrapper mods x_opt name (get gt), [t]) - | _ -> None - ) - -let of_assertion' mods act name args wrapper_opt = - let act_js, act_wrapper_opt = of_action mods act in - let js = name ^ "(() => " ^ act_js ^ String.concat ", " ("" :: args) ^ ")" in - match act_wrapper_opt with - | None -> js ^ ";" - | Some (act_wrapper, out) -> - let run_name, wrapper = - match wrapper_opt with - | None -> name, run - | Some wrapper -> "run", wrapper - in run_name ^ "(() => " ^ act_wrapper (wrapper out) act.at ^ "); // " ^ js - -let of_assertion mods ass = + js_global_type (lookup_global mods x_opt name act.at); + "get(" ^ var_opt mods x_opt ^ ", " ^ js_name name ^ ")" + | Set (x_opt, name, arg) -> + js_global_type (lookup_global mods x_opt name act.at); + "set(" ^ var_opt mods x_opt ^ ", " ^ js_name name ^ ", " ^ + js_argument mods arg ^ ")" + +and js_argument mods arg = + match arg.it with + | LiteralArg lit -> js_literal lit + | ActionArg act -> js_action mods act + +let js_run_wasm bs = + "call(instance(" ^ js_bytes bs ^ ", registry), \"run\", [])" + +let js_or_wasm_action mods act = + try js_action mods act + with UnsupportedByJs -> js_run_wasm (wasm_module wasm_action mods act) + +let js_assertion mods ass = match ass.it with | AssertMalformed (def, _) -> - "assert_malformed(" ^ of_definition def ^ ");" + "assert_malformed(" ^ js_definition def ^ ")" | AssertInvalid (def, _) -> - "assert_invalid(" ^ of_definition def ^ ");" + "assert_invalid(" ^ js_definition def ^ ")" | AssertUnlinkable (def, _) -> - "assert_unlinkable(" ^ of_definition def ^ ");" + "assert_unlinkable(" ^ js_definition def ^ ")" | AssertUninstantiable (def, _) -> - "assert_uninstantiable(" ^ of_definition def ^ ");" + "assert_uninstantiable(" ^ js_definition def ^ ")" | AssertReturn (act, ress) -> - of_assertion' mods act "assert_return" (List.map of_result ress) - (Some (assert_return ress)) + (try + let js_ress = List.map js_result ress in + "assert_return(() => " ^ js_or_wasm_action mods act ^ + String.concat ", " ("" :: js_ress) ^ ")" + with UnsupportedByJs -> + js_run_wasm (wasm_module wasm_assertion mods ass) + ) | AssertTrap (act, _) -> - of_assertion' mods act "assert_trap" [] None + "assert_trap(() => " ^ js_or_wasm_action mods act ^ ")" | AssertExhaustion (act, _) -> - of_assertion' mods act "assert_exhaustion" [] None + "assert_exhaustion(() => " ^ js_or_wasm_action mods act ^ ")" -let of_command mods cmd = +let js_command mods cmd = "\n// " ^ Filename.basename cmd.at.left.file ^ ":" ^ string_of_int cmd.at.left.line ^ "\n" ^ match cmd.it with @@ -595,18 +695,23 @@ let of_command mods cmd = | Textual m -> m | Encoded (_, bs) -> Decode.decode "binary" bs | Quoted (_, s) -> unquote (Parse.string_to_module s) - in bind mods x_opt (unquote def); - "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" ^ - (if x_opt = None then "" else - "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n") + in + bind mods x_opt (unquote def); + let xi = current_var mods in + "let " ^ current_var mods ^ + " = register(\"" ^ xi ^ "\", instance(" ^ js_definition def ^ "));\n" ^ + ( if x_opt = None then "" else + let x = var_opt mods x_opt in + "let " ^ x ^ " = register(\"" ^ x ^ "\", " ^ xi ^ ");\n" + ) | Register (name, x_opt) -> - "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n" + "register(" ^ js_name name ^ ", " ^ var_opt mods x_opt ^ ");\n" | Action act -> - of_assertion' mods act "run" [] None ^ "\n" + js_or_wasm_action mods act ^ ";\n" | Assertion ass -> - of_assertion mods ass ^ "\n" + js_assertion mods ass ^ ";\n" | Meta _ -> assert false let of_script scr = (if !Flags.harness then harness else "") ^ - String.concat "" (List.map (of_command (modules ())) scr) + String.concat "" (List.map (js_command (modules ())) scr) diff --git a/interpreter/script/js.mli b/interpreter/script/js.mli index c60d3c501b..905433462d 100644 --- a/interpreter/script/js.mli +++ b/interpreter/script/js.mli @@ -1 +1,3 @@ +exception Error of Source.region * string + val of_script : Script.script -> string diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index e0019d84a0..64938536e4 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -114,6 +114,7 @@ let input_from get_script run = | Eval.Crash (at, msg) -> error at "runtime crash" msg | Encode.Code (at, msg) -> error at "encoding error" msg | Script.Error (at, msg) -> error at "script error" msg + | Js.Error (at, msg) -> error at "script error" msg | IO (at, msg) -> error at "i/o error" msg | Assert (at, msg) -> error at "assertion failure" msg | Abort _ -> false @@ -340,25 +341,25 @@ let rec run_definition def : Ast.module_ = let def' = Parse.string_to_module s in run_definition def' -let run_action act : Values.value list = +let rec run_action act : Values.value list = match act.it with - | Invoke (x_opt, name, vs) -> + | Invoke (x_opt, name, args) -> trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"..."); let inst = lookup_instance x_opt act.at in (match Instance.export inst name with | Some (Instance.ExternFunc f) -> - let Types.FuncType (ins, out) = Func.type_of f in - if List.length vs <> List.length ins then + let Types.FuncType (ts1, _) = Func.type_of f in + let vs = List.concat_map run_argument args in + if List.length vs <> List.length ts1 then Script.error act.at "wrong number of arguments"; - List.iter2 (fun v t -> - if Values.type_of_value v.it <> t then - Script.error v.at "wrong type of argument" - ) vs ins; - Eval.invoke f (List.map (fun v -> v.it) vs) + List.iteri (fun i (v, t) -> + if Values.type_of_value v <> t then + Script.error act.at ("type mismatch for argument " ^ string_of_int i) + ) (List.combine vs ts1); + Eval.invoke f vs | Some _ -> Assert.error act.at "export is not a function" | None -> Assert.error act.at "undefined export" ) - | Get (x_opt, name) -> trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); let inst = lookup_instance x_opt act.at in @@ -367,7 +368,24 @@ let run_action act : Values.value list = | Some _ -> Assert.error act.at "export is not a global" | None -> Assert.error act.at "undefined export" ) + | Set (x_opt, name, arg) -> + trace ("Setting global \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + let v = + match run_argument arg with + | [v] -> v + | _ -> Assert.error act.at "wrong number of arguments" + in + (match Instance.export inst name with + | Some (Instance.ExternGlobal gl) -> Global.store gl v; [] + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" + ) +and run_argument arg : Values.value list = + match arg.it with + | LiteralArg lit -> [lit.it] + | ActionArg act -> run_action act let assert_nan_pat n nan = let open Values in diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index 4c4f550f2c..fc66a59840 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -13,8 +13,14 @@ and definition' = type action = action' Source.phrase and action' = - | Invoke of var option * Ast.name * literal list + | Invoke of var option * Ast.name * arg list | Get of var option * Ast.name + | Set of var option * Ast.name * arg + +and arg = arg' Source.phrase +and arg' = + | LiteralArg of literal + | ActionArg of action type nanop = nanop' Source.phrase and nanop' = (Lib.void, Lib.void, nan, nan) Values.op diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index dc56743eb6..13e3380b48 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -699,12 +699,19 @@ let definition mode x_opt def = let access x_opt n = String.concat " " [var_opt x_opt; name n] -let action mode act = +let rec action mode act = match act.it with - | Invoke (x_opt, name, lits) -> - Node ("invoke" ^ access x_opt name, List.map (literal mode) lits) + | Invoke (x_opt, name, args) -> + Node ("invoke" ^ access x_opt name, List.map (argument mode) args) | Get (x_opt, name) -> Node ("get" ^ access x_opt name, []) + | Set (x_opt, name, arg) -> + Node ("set" ^ access x_opt name, [argument mode arg]) + +and argument mode arg = + match arg.it with + | LiteralArg lit -> literal mode lit + | ActionArg act -> action mode act let nan = function | CanonicalNan -> "nan:canonical" diff --git a/interpreter/text/lexer.mll b/interpreter/text/lexer.mll index d9a12b5d21..0d8a9c7524 100644 --- a/interpreter/text/lexer.mll +++ b/interpreter/text/lexer.mll @@ -678,6 +678,7 @@ rule token = parse | "register" -> REGISTER | "invoke" -> INVOKE | "get" -> GET + | "set" -> SET | "assert_malformed" -> ASSERT_MALFORMED | "assert_invalid" -> ASSERT_INVALID | "assert_unlinkable" -> ASSERT_UNLINKABLE diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index 7489acf72b..c31e08e2a0 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -232,7 +232,7 @@ let inline_type_explicit (c : context) x ft at = %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL %token TABLE ELEM MEMORY DATA DECLARE OFFSET ITEM IMPORT EXPORT %token MODULE BIN QUOTE -%token SCRIPT REGISTER INVOKE GET +%token SCRIPT REGISTER INVOKE GET SET %token ASSERT_MALFORMED ASSERT_INVALID ASSERT_UNLINKABLE %token ASSERT_RETURN ASSERT_TRAP ASSERT_EXHAUSTION %token NAN @@ -1015,10 +1015,12 @@ script_module : { $3, Quoted ("quote:" ^ string_of_pos (at()).left, $5) @@ at() } action : - | LPAR INVOKE module_var_opt name literal_list RPAR + | LPAR INVOKE module_var_opt name arg_list RPAR { Invoke ($3, $4, $5) @@ at () } | LPAR GET module_var_opt name RPAR { Get ($3, $4) @@ at() } + | LPAR SET module_var_opt name arg RPAR + { Set ($3, $4, $5) @@ at() } assertion : | LPAR ASSERT_MALFORMED script_module STRING RPAR @@ -1065,9 +1067,13 @@ literal : | literal_vec { Values.Vec $1 @@ at () } | literal_ref { Values.Ref $1 @@ at () } -literal_list : +arg : + | literal { LiteralArg $1 @@ at () } + | action { ActionArg $1 @@ at () } + +arg_list : | /* empty */ { [] } - | literal literal_list { $1 :: $2 } + | arg arg_list { $1 :: $2 } numpat : | num { fun sh -> vec_lane_lit sh $1.it $1.at } diff --git a/test/core/script.wast b/test/core/script.wast new file mode 100644 index 0000000000..e5b562408d --- /dev/null +++ b/test/core/script.wast @@ -0,0 +1,101 @@ +(module $m1 + (global (export "g") i32 (i32.const 41)) + (func (export "f") (result i32) (i32.const 41)) + (func (export "inc") (param $x i32) (result i32) + (i32.add (local.get $x) (i32.const 1)) + ) +) + +(module $m2 + (global (export "g") (mut i32) (i32.const 42)) + (func (export "f") (result i32) (i32.const 42)) + (func (export "add3") (param i32 i32 i32) (result i32) + (i32.add (i32.add (local.get 0) (local.get 1)) (local.get 2)) + ) + (func (export "swap") (param i32 i32) (result i32 i32) + (local.get 1) (local.get 0) + ) +) + +(assert_return (get "g") (i32.const 42)) +(assert_return (get $m1 "g") (i32.const 41)) +(assert_return (get $m2 "g") (i32.const 42)) + +(set "g" (i32.const 43)) +(assert_return (set "g" (i32.const 43))) +(assert_return (get "g") (i32.const 43)) +(set $m2 "g" (i32.const 44)) +(assert_return (get "g") (i32.const 44)) +(set "g" (invoke $m1 "inc" (get "g"))) +(assert_return (get "g") (i32.const 45)) +(assert_return (get $m1 "g") (i32.const 41)) +(assert_return (get $m2 "g") (i32.const 45)) + +(assert_return (invoke "f") (i32.const 42)) +(assert_return (invoke $m1 "f") (i32.const 41)) +(assert_return (invoke $m2 "f") (i32.const 42)) + +(assert_return (invoke $m1 "inc" (i32.const 2)) (i32.const 3)) +(assert_return (invoke $m1 "inc" (get $m1 "g")) (i32.const 42)) +(assert_return (invoke $m1 "inc" (get $m2 "g")) (i32.const 46)) +(assert_return (invoke $m1 "inc" (invoke $m1 "inc" (get "g"))) (i32.const 47)) + +(assert_return + (invoke "add3" (get $m1 "g") (invoke $m1 "inc" (get "g")) (get "g")) + (i32.const 132) + ) +(assert_return + (invoke "add3" + (invoke "swap" (get $m1 "g") (invoke $m1 "inc" (get "g"))) + (i32.const -20) + ) + (i32.const 67) +) + + +(module + (global (export "g-i32") i32 (i32.const 42)) + (global (export "g-i64") i64 (i64.const 42)) + (global (export "g-f32") f32 (f32.const 42)) + (global (export "g-f64") f64 (f64.const 42)) + (global (export "g-v128") v128 (v128.const i32x4 42 42 42 42)) + (global (export "g-funcref") funcref (ref.null func)) + (global (export "g-externref") externref (ref.null extern)) + + (func (export "f-i32") (param i32) (result i32) (local.get 0)) + (func (export "f-i64") (param i64) (result i64) (local.get 0)) + (func (export "f-f32") (param f32) (result f32) (local.get 0)) + (func (export "f-f64") (param f64) (result f64) (local.get 0)) + (func (export "f-v128") (param v128) (result v128) (local.get 0)) + (func (export "f-funcref") (param funcref) (result funcref) (local.get 0)) + (func (export "f-externref") (param externref) (result externref) (local.get 0)) +) + +(assert_return (invoke "f-i32" (get "g-i32")) (i32.const 42)) +(assert_return (invoke "f-i64" (get "g-i64")) (i64.const 42)) +(assert_return (invoke "f-f32" (get "g-f32")) (f32.const 42)) +(assert_return (invoke "f-f64" (get "g-f64")) (f64.const 42)) +(assert_return (invoke "f-v128" (v128.const i32x4 42 42 42 42)) (v128.const i32x4 42 42 42 42)) +;; TODO: Reactivate once the fix for https://bugs.chromium.org/p/v8/issues/detail?id=13732 +;; has made it to the downstream node.js version that we use on CI. +;; (assert_return (invoke "f-v128" (get "g-v128")) (v128.const i32x4 42 42 42 42)) +(assert_return (invoke "f-funcref" (get "g-funcref")) (ref.null func)) +(assert_return (invoke "f-externref" (get "g-externref")) (ref.null extern)) + + +(module + (global $g (export "g") (mut i32) (i32.const 1)) + (func (export "inc") (global.set $g (i32.add (global.get $g) (i32.const 1)))) + (func (export "get") (result i32) (global.get $g)) +) + +;; Left-to-right evaluation order +(assert_return + (invoke "get" + (set "g" (i32.const 3)) + (invoke "inc") + (set "g" (invoke $m1 "inc" (get "g"))) + (invoke "inc") + ) + (i32.const 6) +)