From 832dba6207692c25541746416b8d29d5721a5cc0 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sat, 10 Sep 2016 12:42:23 +0200 Subject: [PATCH 01/10] Implement converion of script to JavaScript --- ml-proto/host/js.ml | 58 ++++++ ml-proto/host/lexer.mll | 1 + ml-proto/host/main.ml | 4 +- ml-proto/host/parser.mly | 30 +-- ml-proto/host/run.ml | 65 ++----- ml-proto/host/run.mli | 2 - ml-proto/host/script.ml | 369 ++++++++++++++++++++++++++++++------- ml-proto/host/script.mli | 22 ++- ml-proto/test/binary.wast | 5 +- ml-proto/test/linking.wast | 202 ++++++++++---------- 10 files changed, 513 insertions(+), 245 deletions(-) create mode 100644 ml-proto/host/js.ml diff --git a/ml-proto/host/js.ml b/ml-proto/host/js.ml new file mode 100644 index 0000000000..802274ff76 --- /dev/null +++ b/ml-proto/host/js.ml @@ -0,0 +1,58 @@ +let js_prefix = + "'use strict';\n" ^ + "\n" ^ + "let spectest = {\n" ^ + " print: print || ((...xs) => console.log(...xs)),\n" ^ + " global: 666,\n" ^ + "};\n" ^ (* TODO: table, memory *) + "\n" ^ + "let registry = {spectest: spectest};\n" ^ + "let $$;\n" ^ + "\n" ^ + "function register(name, instance) {\n" ^ + " registry[name] = instance.exports;\n" ^ + "}\n" ^ + "\n" ^ + "function module(bytes) {\n" ^ + " let buffer = new ArrayBuffer(bytes.length);\n" ^ + " let view = new Uint8Array(buffer);\n" ^ + " for (let i = 0; i < bytes.length; ++i) {\n" ^ + " view[i] = bytes.charCodeAt(i);\n" ^ + " }\n" ^ + " return new WebAssembly.Module(buffer);\n" ^ + "}\n" ^ + "\n" ^ + "function instance(bytes) {\n" ^ + " return new WebAssembly.Instance(module(bytes), registry);\n" ^ + "}\n" ^ + "\n" ^ + "function assert_invalid(bytes) {\n" ^ + " try { module(bytes) } catch (e) { return }\n" ^ + " throw new Error(\"Wasm validation failure expected\");\n" ^ + "}\n" ^ + "\n" ^ + "function assert_unlinkable(bytes) {\n" ^ + " let mod = module(bytes);\n" ^ + " try { instance(mod, registry) } catch (e) { return }\n" ^ + " throw new Error(\"Wasm linking failure expected\");\n" ^ + "}\n" ^ + "\n" ^ + "function assert_trap(action) {\n" ^ + " try { action() } catch (e) { return }\n" ^ + " throw new Error(\"Wasm trap expected\");\n" ^ + "}\n" ^ + "\n" ^ + "function assert_return(action, expected) {\n" ^ + " let actual = action();\n" ^ + " if (actual !== expected) {\n" ^ + " throw new Error(\"Wasm return value \" + expected + \" expected, got \" + actual);\n" ^ + " };\n" ^ + "}\n" ^ + "\n" ^ + "function assert_return(action) {\n" ^ + " let actual = action();\n" ^ + " if (!actual.isNaN()) {\n" ^ + " throw new Error(\"Wasm return value NaN expected, got \" + actual);\n" ^ + " };\n" ^ + "}\n" ^ + "\n" diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 73846fec3b..56ef3acc43 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -300,6 +300,7 @@ rule token = parse | "import" { IMPORT } | "export" { EXPORT } + | "script" { SCRIPT } | "register" { REGISTER } | "invoke" { INVOKE } | "get" { GET } diff --git a/ml-proto/host/main.ml b/ml-proto/host/main.ml index f34e601589..d082b9be5c 100644 --- a/ml-proto/host/main.ml +++ b/ml-proto/host/main.ml @@ -22,9 +22,11 @@ let argspec = Arg.align " read script from file"; "-o", Arg.String (fun file -> add_arg ("(output \"" ^ file ^ "\")")), " write module to file"; + "-s", Arg.String (fun file -> add_arg ("(script (input \"" ^ file ^ "\"))")), + " read script from file"; "-w", Arg.Int (fun n -> Flags.width := n), " configure output width (default is 80)"; - "-s", Arg.Set Flags.print_sig, " show module signatures"; + "-g", Arg.Set Flags.print_sig, " show module signatures"; "-u", Arg.Set Flags.unchecked, " unchecked, do not perform validation"; "-d", Arg.Set Flags.dry, " dry, do not run program"; "-t", Arg.Set Flags.trace, " trace execution"; diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 5c9d1a6e63..8fdfee51ef 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -163,7 +163,7 @@ 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 OFFSET IMPORT EXPORT TABLE -%token REGISTER INVOKE GET +%token SCRIPT REGISTER INVOKE GET %token ASSERT_INVALID ASSERT_UNLINKABLE %token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP %token INPUT OUTPUT @@ -668,29 +668,27 @@ module_fields : {m with exports = $1 c :: m.exports} } ; module_ : - | LPAR MODULE module_var_opt module_fields RPAR + | LPAR MODULE script_var_opt module_fields RPAR { $3, Textual ($4 (empty_context ()) @@ at ()) @@ at () } - | LPAR MODULE module_var_opt TEXT text_list RPAR + | LPAR MODULE script_var_opt TEXT text_list RPAR { $3, Binary ($4 ^ $5) @@ at() } ; /* Scripts */ -module_var_opt : +script_var_opt : | /* empty */ { None } | VAR { Some ($1 @@ at ()) } /* Sugar */ ; + action : - | LPAR INVOKE module_var_opt TEXT const_list RPAR + | LPAR INVOKE script_var_opt TEXT const_list RPAR { Invoke ($3, $4, $5) @@ at () } - | LPAR GET module_var_opt TEXT RPAR + | LPAR GET script_var_opt TEXT RPAR { Get ($3, $4) @@ at() } ; -cmd : - | module_ { Define (fst $1, snd $1) @@ at () } - | action { Action $1 @@ at () } - | LPAR REGISTER TEXT module_var_opt RPAR { Register ($3, $4) @@ at () } +assertion : | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid (snd $3, $4) @@ at () } | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR @@ -698,9 +696,17 @@ cmd : | LPAR ASSERT_RETURN action const_list RPAR { AssertReturn ($3, $4) @@ at () } | LPAR ASSERT_RETURN_NAN action RPAR { AssertReturnNaN $3 @@ at () } | LPAR ASSERT_TRAP action TEXT RPAR { AssertTrap ($3, $4) @@ at () } +; + +cmd : + | action { Action $1 @@ at () } + | assertion { Assertion $1 @@ at () } + | module_ { Module (fst $1, snd $1) @@ at () } + | LPAR SCRIPT script_var_opt cmd_list RPAR { Script ($3, $4) @@ at () } + | LPAR REGISTER TEXT script_var_opt RPAR { Register ($3, $4) @@ at () } | LPAR INPUT TEXT RPAR { Input $3 @@ at () } - | LPAR OUTPUT module_var_opt TEXT RPAR { Output ($3, Some $4) @@ at () } - | LPAR OUTPUT module_var_opt RPAR { Output ($3, None) @@ at () } + | LPAR OUTPUT script_var_opt TEXT RPAR { Output ($3, Some $4) @@ at () } + | LPAR OUTPUT script_var_opt RPAR { Output ($3, None) @@ at () } ; cmd_list : | /* empty */ { [] } diff --git a/ml-proto/host/run.ml b/ml-proto/host/run.ml index 4596e370c3..e8a78b899e 100644 --- a/ml-proto/host/run.ml +++ b/ml-proto/host/run.ml @@ -19,11 +19,11 @@ let error at category msg = prerr_endline (Source.string_of_region at ^ ": " ^ category ^ ": " ^ msg); false -let run_from get_script = +let run_from run get_script = try let script = get_script () in Script.trace "Running..."; - Script.run script; + run script; true with | Decode.Code (at, msg) -> error at "decoding error" msg @@ -37,28 +37,28 @@ let run_from get_script = | Script.IO (at, msg) -> error at "i/o error" msg | Script.Abort _ -> false -let run_sexpr name lexbuf start = - run_from (fun _ -> Parse.parse name lexbuf start) +let run_sexpr run name lexbuf start = + run_from run (fun _ -> Parse.parse name lexbuf start) -let run_binary name buf = +let run_binary run name buf = let open Source in - run_from + run_from run (fun _ -> let m = Decode.decode name buf in - [Script.Define (None, Script.Textual m @@ m.at) @@ m.at]) + [Script.Module (None, Script.Textual m @@ m.at) @@ m.at]) -let run_sexpr_file file = +let run_sexpr_file file run = Script.trace ("Loading (" ^ file ^ ")..."); let ic = open_in file in try let lexbuf = Lexing.from_channel ic in Script.trace "Parsing..."; - let success = run_sexpr file lexbuf Parse.Script in + let success = run_sexpr run file lexbuf Parse.Script in close_in ic; success with exn -> close_in ic; raise exn -let run_binary_file file = +let run_binary_file file run = Script.trace ("Loading (" ^ file ^ ")..."); let ic = open_in_bin file in try @@ -66,20 +66,21 @@ let run_binary_file file = let buf = Bytes.make len '\x00' in really_input ic buf 0 len; Script.trace "Decoding..."; - let success = run_binary file buf in + let success = run_binary run file buf in close_in ic; success with exn -> close_in ic; raise exn -let run_file = dispatch_file_ext run_sexpr_file run_binary_file +let run_file file = + dispatch_file_ext run_sexpr_file run_binary_file file Script.run let run_string string = Script.trace ("Running (\"" ^ String.escaped string ^ "\")..."); let lexbuf = Lexing.from_string string in Script.trace "Parsing..."; - run_sexpr "string" lexbuf Parse.Script + run_sexpr Script.run "string" lexbuf Parse.Script -let () = Script.input_file := run_file +let () = Script.input_file := dispatch_file_ext run_sexpr_file run_binary_file (* Interactive *) @@ -103,7 +104,7 @@ let lexbuf_stdin buf len = let rec run_stdin () = let lexbuf = Lexing.from_function lexbuf_stdin in let rec loop () = - let success = run_sexpr "stdin" lexbuf Parse.Script1 in + let success = run_sexpr Script.run "stdin" lexbuf Parse.Script1 in if not success then Lexing.flush_input lexbuf; if Lexing.(lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len - 1) then continuing := false; @@ -112,37 +113,3 @@ let rec run_stdin () = try loop () with End_of_file -> print_endline ""; Script.trace "Bye." - - -(* Output *) - -let print_stdout m = - Script.trace "Formatting..."; - let sexpr = Arrange.module_ m in - Script.trace "Printing..."; - Sexpr.output stdout !Flags.width sexpr - -let create_sexpr_file file m = - Script.trace ("Formatting (" ^ file ^ ")..."); - let sexpr = Arrange.module_ m in - let oc = open_out file in - try - Script.trace "Writing..."; - Sexpr.output oc !Flags.width sexpr; - close_out oc - with exn -> close_out oc; raise exn - -let create_binary_file file m = - Script.trace ("Encoding (" ^ file ^ ")..."); - let s = Encode.encode m in - let oc = open_out_bin file in - try - Script.trace "Writing..."; - output_string oc s; - close_out oc - with exn -> close_out oc; raise exn - -let create_file = dispatch_file_ext create_sexpr_file create_binary_file - -let () = Script.output_file := create_file -let () = Script.output_stdout := print_stdout diff --git a/ml-proto/host/run.mli b/ml-proto/host/run.mli index 8b57b619d9..9b0869bb4a 100644 --- a/ml-proto/host/run.mli +++ b/ml-proto/host/run.mli @@ -1,5 +1,3 @@ val run_string : string -> bool val run_file : string -> bool val run_stdin : unit -> unit - -val create_file : string -> Ast.module_ -> unit diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 74b1abe05a..969043f5e6 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -16,23 +16,102 @@ and action' = | Invoke of var option * string * Ast.literal list | Get of var option * string -type command = command' Source.phrase -and command' = - | Define of var option * definition - | Register of string * var option - | Action of action +type assertion = assertion' Source.phrase +and assertion' = | AssertInvalid of definition * string | AssertUnlinkable of definition * string | AssertReturn of action * Ast.literal list | AssertReturnNaN of action | AssertTrap of action * string + +type command = command' Source.phrase +and command' = + | Script of var option * script + | Module of var option * definition + | Register of string * var option + | Action of action + | Assertion of assertion | Input of string | Output of var option * string option -type script = command list +and script = command list + + +(* JS conversion *) + +let hex n = + assert (0 <= n && n < 16); + if n < 10 + then Char.chr (n + Char.code '0') + else Char.chr (n - 10 + Char.code 'a') + +let js_of_bytes s = + let buf = Buffer.create (4 * String.length s) in + for i = 0 to String.length s - 1 do + Buffer.add_string buf "\\x"; + Buffer.add_char buf (hex (Char.code s.[i] / 16)); + Buffer.add_char buf (hex (Char.code s.[i] mod 16)); + done; + "\"" ^ Buffer.contents buf ^ "\"" + +let js_of_literal lit = + match lit.it with + | Values.I32 i -> I32.to_string i + | Values.I64 i -> I64.to_string i (* TODO *) + | Values.F32 z -> F32.to_string z + | Values.F64 z -> F64.to_string z + +let js_of_var_opt = function + | None -> "$$" + | Some x -> x.it + +let js_of_def def = + let bs = + match def.it with + | Textual m -> Encode.encode m + | Binary bs -> bs + in js_of_bytes bs + +let js_of_action act = + match act.it with + | Invoke (x_opt, name, lits) -> + js_of_var_opt x_opt ^ ".export[\"" ^ name ^ "\"]" ^ + "(" ^ String.concat ", " (List.map js_of_literal lits) ^ ")" + | Get (x_opt, name) -> + js_of_var_opt x_opt ^ ".export[\"" ^ name ^ "\"]" + +let js_of_assertion ass = + match ass.it with + | AssertInvalid (def, _) -> + "assert_invalid(" ^ js_of_def def ^ ")" + | AssertUnlinkable (def, _) -> + "assert_unlinkable(" ^ js_of_def def ^ ")" + | AssertReturn (act, lits) -> + "assert_return(() => " ^ js_of_action act ^ ", " ^ + String.concat ", " (List.map js_of_literal lits) ^ ")" + | AssertReturnNaN act -> + "assert_return_nan(() => " ^ js_of_action act ^ ")" + | AssertTrap (act, _) -> + "assert_trap(() => " ^ js_of_action act ^ ")" + +let js_of_cmd cmd = + match cmd.it with + | Module (x_opt, def) -> + (if x_opt <> None then "let " else "") ^ + js_of_var_opt x_opt ^ " = module(" ^ js_of_def def ^ ");\n" + | Register (name, x_opt) -> + "register(" ^ name ^ ", " ^ js_of_var_opt x_opt ^ ")\n" + | Action act -> + js_of_action act ^ ";\n" + | Assertion ass -> + js_of_assertion ass ^ ";\n" + | Script _ | Input _ | Output _ -> assert false + +let js_of_script script = + Js.js_prefix ^ String.concat "" (List.map js_of_cmd script) -(* Execution *) +(* Errors *) module Abort = Error.Make () module Syntax = Error.Make () @@ -44,10 +123,12 @@ exception Syntax = Syntax.Error exception Assert = Assert.Error exception IO = IO.Error -let trace name = if !Flags.trace then print_endline ("-- " ^ name) + +(* Configuration *) module Map = Map.Make(String) +let quote : script ref = ref [] let registry : Instance.instance Map.t ref = ref Map.empty let lookup module_name item_name _t = @@ -55,18 +136,29 @@ let lookup module_name item_name _t = | Some ext -> ext | None -> raise Not_found +let scripts : script Map.t ref = ref Map.empty 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 last_script : script option ref = ref None +let last_module : Ast.module_ option ref = ref None +let last_instance : Instance.instance option ref = ref None let bind map x_opt y = match x_opt with | None -> () | Some x -> map := Map.add x.it y !map +let get_script x_opt at = + match x_opt, !last_script with + | None, Some m -> m + | None, None -> raise (Eval.Crash (at, "no script defined")) + | Some x, _ -> + try Map.find x.it !scripts with Not_found -> + raise (Eval.Crash (x.at, "unknown script " ^ x.it)) + let get_module x_opt at = - match x_opt, !current_module with + match x_opt, !last_module with | None, Some m -> m | None, None -> raise (Eval.Crash (at, "no module defined")) | Some x, _ -> @@ -74,16 +166,127 @@ let get_module x_opt at = raise (Eval.Crash (x.at, "unknown module " ^ x.it)) let get_instance x_opt at = - match x_opt, !current_instance with + match x_opt, !last_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)) + +(* Input & Output *) + +let trace name = if !Flags.trace then print_endline ("-- " ^ name) + let input_file = ref (fun _ -> assert false) -let output_file = ref (fun _ -> assert false) -let output_stdout = ref (fun _ -> assert false) + +let binary_ext = "wasm" +let sexpr_ext = "wast" +let js_ext = "js" + +let dispatch_file_ext on_binary on_sexpr on_js file = + if Filename.check_suffix file binary_ext then + on_binary file + else if Filename.check_suffix file sexpr_ext then + on_sexpr file + else if Filename.check_suffix file js_ext then + on_js file + else + raise (Sys_error (file ^ ": Unrecognized file type")) + +let create_binary_file file m script = + trace ("Encoding (" ^ file ^ ")..."); + let s = Encode.encode m in + let oc = open_out_bin file in + try + trace "Writing..."; + output_string oc s; + close_out oc + with exn -> close_out oc; raise exn + +let create_sexpr_file file m script = + trace ("Formatting (" ^ file ^ ")..."); + let sexpr = Arrange.module_ m in + let oc = open_out file in + try + trace "Writing..."; + Sexpr.output oc !Flags.width sexpr; + close_out oc + with exn -> close_out oc; raise exn + +let create_js_file file m script = + trace ("Converting (" ^ file ^ ")..."); + let js = js_of_script script in + let oc = open_out file in + try + trace "Writing..."; + output_string oc js; + close_out oc + with exn -> close_out oc; raise exn + +let output_file = + dispatch_file_ext create_binary_file create_sexpr_file create_js_file + +let output_stdout m = + trace "Formatting..."; + let sexpr = Arrange.module_ m in + trace "Printing..."; + Sexpr.output stdout !Flags.width sexpr + + +(* Quoting *) + +let quote_def def = + match def.it with + | Textual m -> m + | Binary bs -> + trace "Decoding..."; + Decode.decode "binary" bs + +let rec quote_cmd cmd = + match cmd.it with + | Script (x_opt, script) -> + let save_quote = !quote in + quote := []; + quote_script script; + let script' = List.rev !quote in + last_script := Some script'; + bind scripts x_opt script'; + quote := !quote @ save_quote + + | Module (x_opt, def) -> + let m = quote_def def in + last_script := Some [cmd]; + last_module := Some m; + bind scripts x_opt [cmd]; + bind modules x_opt m; + quote := cmd :: !quote + + | Register _ + | Action _ + | Assertion _ -> + quote := cmd :: !quote + + | Input file -> + (try if not (!input_file file quote_script) then + Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, Some file) -> + (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, None) -> + (try output_stdout (get_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg) + +and quote_script cmds = + let save_scripts = !scripts in + List.iter quote_cmd cmds; + scripts := save_scripts + + +(* Running *) let run_def def = match def.it with @@ -112,36 +315,8 @@ let run_action act = | None -> Assert.error act.at "undefined export" ) -let run_cmd cmd = - match cmd.it with - | Define (x_opt, def) -> - let m = run_def def in - if not !Flags.unchecked then begin - trace "Checking..."; - Check.check_module m; - if !Flags.print_sig then begin - trace "Signature:"; - Print.print_module_sig m - end - end; - trace "Initializing..."; - let imports = Import.link m in - let inst = Eval.init m imports in - current_module := Some m; - current_instance := Some inst; - bind modules x_opt m; - bind instances x_opt inst - - | 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 vs = run_action act in - if vs <> [] then Print.print_result vs - +let run_assertion ass = + match ass.it with | AssertInvalid (def, re) -> trace "Asserting invalid..."; (match @@ -152,10 +327,10 @@ let run_cmd cmd = if not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error cmd.at "wrong validation error" + Assert.error ass.at "wrong validation error" end | _ -> - Assert.error cmd.at "expected validation error" + Assert.error ass.at "expected validation error" ) | AssertUnlinkable (def, re) -> @@ -170,10 +345,10 @@ let run_cmd cmd = if not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error cmd.at "wrong linking error" + Assert.error ass.at "wrong linking error" end | _ -> - Assert.error cmd.at "expected linking error" + Assert.error ass.at "expected linking error" ) | AssertReturn (act, es) -> @@ -183,7 +358,7 @@ let run_cmd cmd = if got_vs <> expect_vs then begin print_string "Result: "; Print.print_result got_vs; print_string "Expect: "; Print.print_result expect_vs; - Assert.error cmd.at "wrong return value" + Assert.error ass.at "wrong return values" end | AssertReturnNaN act -> @@ -199,7 +374,7 @@ let run_cmd cmd = then begin print_string "Result: "; Print.print_result got_vs; print_string "Expect: "; print_endline "nan"; - Assert.error cmd.at "wrong return value" + Assert.error ass.at "wrong return value" end | AssertTrap (act, re) -> @@ -209,24 +384,73 @@ let run_cmd cmd = if not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error cmd.at "wrong runtime trap" + Assert.error ass.at "wrong runtime trap" end | _ -> - Assert.error cmd.at "expected runtime trap" + Assert.error ass.at "expected runtime trap" ) +let rec run_cmd cmd = + match cmd.it with + | Script (x_opt, script) -> + assert (!quote = []); + quote_script script; + let script' = List.rev !quote in + quote := []; + last_script := Some script'; + bind scripts x_opt script' + + | Module (x_opt, def) -> + let m = run_def def in + if not !Flags.unchecked then begin + trace "Checking..."; + Check.check_module m; + if !Flags.print_sig then begin + trace "Signature:"; + Print.print_module_sig m + end + end; + trace "Initializing..."; + let imports = Import.link m in + let inst = Eval.init m imports in + last_script := Some [cmd]; + last_module := Some m; + last_instance := Some inst; + bind scripts x_opt [cmd]; + bind modules x_opt m; + bind instances x_opt inst + + | 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 vs = run_action act in + if vs <> [] then Print.print_result vs + + | Assertion ass -> + run_assertion ass + | Input file -> - (try if not (!input_file file) then Abort.error cmd.at "aborting" + (try if not (!input_file file run_script) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg) | Output (x_opt, Some file) -> - (try !output_file file (get_module x_opt cmd.at) + (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) | Output (x_opt, None) -> - (try !output_stdout (get_module x_opt cmd.at) + (try output_stdout (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) +and run_script script = + List.iter run_cmd script + + +(* Dry run *) + let dry_def def = match def.it with | Textual m -> m @@ -234,9 +458,17 @@ let dry_def def = trace "Decoding..."; Decode.decode "binary" bs -let dry_cmd cmd = +let rec dry_cmd cmd = match cmd.it with - | Define (x_opt, def) -> + | Script (x_opt, script) -> + assert (!quote = []); + quote_script script; + let script' = List.rev !quote in + quote := []; + last_script := Some script'; + bind scripts x_opt script' + + | Module (x_opt, def) -> let m = dry_def def in if not !Flags.unchecked then begin trace "Checking..."; @@ -246,24 +478,27 @@ let dry_cmd cmd = Print.print_module_sig m end end; - current_module := Some m; + last_script := Some [cmd]; + last_module := Some m; + bind scripts x_opt [cmd]; bind modules x_opt m + | Input file -> - (try if not (!input_file file) then Abort.error cmd.at "aborting" + (try if not (!input_file file dry_script) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg) | Output (x_opt, Some file) -> - (try !output_file file (get_module x_opt cmd.at) + (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) | Output (x_opt, None) -> - (try !output_stdout (get_module x_opt cmd.at) + (try output_stdout (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) + | Register _ | Action _ - | AssertInvalid _ - | AssertUnlinkable _ - | AssertReturn _ - | AssertReturnNaN _ - | AssertTrap _ -> () + | Assertion _ -> () + +and dry_script script = + List.iter dry_cmd script let run script = - List.iter (if !Flags.dry then dry_cmd else run_cmd) script + (if !Flags.dry then dry_script else run_script) script diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index 60e21182bf..dff1627398 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -10,20 +10,25 @@ and action' = | Invoke of var option * string * Ast.literal list | Get of var option * string -type command = command' Source.phrase -and command' = - | Define of var option * definition - | Register of string * var option - | Action of action +type assertion = assertion' Source.phrase +and assertion' = | AssertInvalid of definition * string | AssertUnlinkable of definition * string | AssertReturn of action * Ast.literal list | AssertReturnNaN of action | AssertTrap of action * string + +type command = command' Source.phrase +and command' = + | Script of var option * script + | Module of var option * definition + | Register of string * var option + | Action of action + | Assertion of assertion | Input of string | Output of var option * string option -type script = command list +and script = command list exception Abort of Source.region * string exception Syntax of Source.region * string @@ -34,7 +39,4 @@ val run : script -> unit (* raises Check.Invalid, Eval.Trap, Eval.Crash, Assert, IO *) val trace : string -> unit - -val input_file : (string -> bool) ref -val output_file : (string -> Ast.module_ -> unit) ref -val output_stdout : (Ast.module_ -> unit) ref +val input_file : (string -> (script -> unit) -> bool) ref diff --git a/ml-proto/test/binary.wast b/ml-proto/test/binary.wast index b2b7908cb3..96fb57299f 100644 --- a/ml-proto/test/binary.wast +++ b/ml-proto/test/binary.wast @@ -1,7 +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") +(module $M1 "\00asm\0c\00\00\00") +(module $M2 "\00asm" "\0c\00\00\00") (assert_invalid (module "") "unexpected end") (assert_invalid (module "\01") "unexpected end") @@ -13,4 +13,3 @@ (assert_invalid (module "\00asm\0c") "unexpected end") (assert_invalid (module "\00asm\0c\00\00") "unexpected end") (assert_invalid (module "\00asm\10\00\00\00") "unknown binary version") - diff --git a/ml-proto/test/linking.wast b/ml-proto/test/linking.wast index 0f35578962..616d62e631 100644 --- a/ml-proto/test/linking.wast +++ b/ml-proto/test/linking.wast @@ -1,53 +1,53 @@ ;; Functions -(module $M +(module $Mf (func (export "call") (result i32) (call $g)) (func $g (result i32) (i32.const 2)) ) -(register "M" $M) +(register "Mf" $Mf) -(module $N - (func $f (import "M" "call") (result i32)) - (export "M.call" (func $f)) - (func (export "call M.call") (result i32) (call $f)) +(module $Nf + (func $f (import "Mf" "call") (result i32)) + (export "Mf.call" (func $f)) + (func (export "call Mf.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)) +(assert_return (invoke $Mf "call") (i32.const 2)) +(assert_return (invoke $Nf "Mf.call") (i32.const 2)) +(assert_return (invoke $Nf "call") (i32.const 3)) +(assert_return (invoke $Nf "call Mf.call") (i32.const 2)) ;; Globals -(module $M +(module $Mg (global $glob (export "glob") i32 (i32.const 42)) (func (export "get") (result i32) (get_global $glob)) ) -(register "M" $M) +(register "Mg" $Mg) -(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)) +(module $Ng + (global $x (import "Mg" "glob") i32) + (func $f (import "Mg" "get") (result i32)) + (export "Mg.glob" (global $x)) + (export "Mg.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)) +(assert_return (get $Mg "glob") (i32.const 42)) +(assert_return (get $Ng "Mg.glob") (i32.const 42)) +(assert_return (get $Ng "glob") (i32.const 43)) +(assert_return (invoke $Mg "get") (i32.const 42)) +(assert_return (invoke $Ng "Mg.get") (i32.const 42)) +(assert_return (invoke $Ng "get") (i32.const 43)) ;; Tables -(module $M +(module $Mt (type (func (result i32))) (type (func)) @@ -60,20 +60,20 @@ (call_indirect 0 (get_local 0)) ) ) -(register "M" $M) +(register "Mt" $Mt) -(module $N +(module $Nt (type (func)) (type (func (result i32))) - (func $f (import "M" "call") (param i32) (result i32)) - (func $h (import "M" "h") (result i32)) + (func $f (import "Mt" "call") (param i32) (result i32)) + (func $h (import "Mt" "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) + (export "Mt.call" (func $f)) + (func (export "call Mt.call") (param i32) (result i32) (call $f (get_local 0)) ) (func (export "call") (param i32) (result i32) @@ -81,34 +81,34 @@ ) ) -(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 $Mt "call" (i32.const 2)) (i32.const 4)) +(assert_return (invoke $Nt "Mt.call" (i32.const 2)) (i32.const 4)) +(assert_return (invoke $Nt "call" (i32.const 2)) (i32.const 5)) +(assert_return (invoke $Nt "call Mt.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 $Mt "call" (i32.const 1)) "uninitialized") +(assert_trap (invoke $Nt "Mt.call" (i32.const 1)) "uninitialized") +(assert_return (invoke $Nt "call" (i32.const 1)) (i32.const 5)) +(assert_trap (invoke $Nt "call Mt.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 $Mt "call" (i32.const 0)) "uninitialized") +(assert_trap (invoke $Nt "Mt.call" (i32.const 0)) "uninitialized") +(assert_return (invoke $Nt "call" (i32.const 0)) (i32.const 5)) +(assert_trap (invoke $Nt "call Mt.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_trap (invoke $Mt "call" (i32.const 20)) "undefined") +(assert_trap (invoke $Nt "Mt.call" (i32.const 20)) "undefined") +(assert_trap (invoke $Nt "call" (i32.const 7)) "undefined") +(assert_trap (invoke $Nt "call Mt.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") +(assert_return (invoke $Nt "call" (i32.const 3)) (i32.const -4)) +(assert_trap (invoke $Nt "call" (i32.const 4)) "indirect call") -(module $O +(module $Ot (type (func (result i32))) - (func $h (import "M" "h") (result i32)) - (table (import "M" "tab") 5 anyfunc) + (func $h (import "Mt" "h") (result i32)) + (table (import "Mt" "tab") 5 anyfunc) (elem (i32.const 1) $i $h) (func $i (result i32) (i32.const 6)) @@ -117,47 +117,47 @@ ) ) -(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 $Mt "call" (i32.const 3)) (i32.const 4)) +(assert_return (invoke $Nt "Mt.call" (i32.const 3)) (i32.const 4)) +(assert_return (invoke $Nt "call Mt.call" (i32.const 3)) (i32.const 4)) +(assert_return (invoke $Ot "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 $Mt "call" (i32.const 2)) (i32.const -4)) +(assert_return (invoke $Nt "Mt.call" (i32.const 2)) (i32.const -4)) +(assert_return (invoke $Nt "call" (i32.const 2)) (i32.const 5)) +(assert_return (invoke $Nt "call Mt.call" (i32.const 2)) (i32.const -4)) +(assert_return (invoke $Ot "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_return (invoke $Mt "call" (i32.const 1)) (i32.const 6)) +(assert_return (invoke $Nt "Mt.call" (i32.const 1)) (i32.const 6)) +(assert_return (invoke $Nt "call" (i32.const 1)) (i32.const 5)) +(assert_return (invoke $Nt "call Mt.call" (i32.const 1)) (i32.const 6)) +(assert_return (invoke $Ot "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 $Mt "call" (i32.const 0)) "uninitialized") +(assert_trap (invoke $Nt "Mt.call" (i32.const 0)) "uninitialized") +(assert_return (invoke $Nt "call" (i32.const 0)) (i32.const 5)) +(assert_trap (invoke $Nt "call Mt.call" (i32.const 0)) "uninitialized") +(assert_trap (invoke $Ot "call" (i32.const 0)) "uninitialized") -(assert_trap (invoke $O "call" (i32.const 20)) "undefined") +(assert_trap (invoke $Ot "call" (i32.const 20)) "undefined") (assert_unlinkable - (module $Q + (module $Qt (func $host (import "spectest" "print")) - (table (import "M" "tab") 10 anyfunc) + (table (import "Mt" "tab") 10 anyfunc) (elem (i32.const 7) $own) (elem (i32.const 9) $host) (func $own (result i32) (i32.const 666)) ) "invalid use of host function" ) -(assert_trap (invoke $M "call" (i32.const 7)) "uninitialized") +(assert_trap (invoke $Mt "call" (i32.const 7)) "uninitialized") ;; Memories -(module $M +(module $Mm (memory (export "mem") 1 5) (data (i32.const 10) "\00\01\02\03\04\05\06\07\08\09") @@ -165,26 +165,26 @@ (i32.load8_u (get_local 0)) ) ) -(register "M" $M) +(register "Mm" $Mm) -(module $N - (func $loadM (import "M" "load") (param i32) (result i32)) +(module $Nm + (func $loadM (import "Mm" "load") (param i32) (result i32)) (memory 1) (data (i32.const 10) "\f0\f1\f2\f3\f4\f5") - (export "M.load" (func $loadM)) + (export "Mm.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)) +(assert_return (invoke $Mm "load" (i32.const 12)) (i32.const 2)) +(assert_return (invoke $Nm "Mm.load" (i32.const 12)) (i32.const 2)) +(assert_return (invoke $Nm "load" (i32.const 12)) (i32.const 0xf2)) -(module $O - (memory (import "M" "mem") 1) +(module $Om + (memory (import "Mm" "mem") 1) (data (i32.const 5) "\a0\a1\a2\a3\a4\a5\a6\a7") (func (export "load") (param $a i32) (result i32) @@ -192,32 +192,32 @@ ) ) -(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)) +(assert_return (invoke $Mm "load" (i32.const 12)) (i32.const 0xa7)) +(assert_return (invoke $Nm "Mm.load" (i32.const 12)) (i32.const 0xa7)) +(assert_return (invoke $Nm "load" (i32.const 12)) (i32.const 0xf2)) +(assert_return (invoke $Om "load" (i32.const 12)) (i32.const 0xa7)) -(module $P - (memory (import "M" "mem") 1 8) +(module $Pm + (memory (import "Mm" "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)) +(assert_return (invoke $Pm "grow" (i32.const 0)) (i32.const 1)) +(assert_return (invoke $Pm "grow" (i32.const 2)) (i32.const 1)) +(assert_return (invoke $Pm "grow" (i32.const 0)) (i32.const 3)) +(assert_return (invoke $Pm "grow" (i32.const 1)) (i32.const 3)) +(assert_return (invoke $Pm "grow" (i32.const 1)) (i32.const 4)) +(assert_return (invoke $Pm "grow" (i32.const 0)) (i32.const 5)) +(assert_return (invoke $Pm "grow" (i32.const 1)) (i32.const -1)) +(assert_return (invoke $Pm "grow" (i32.const 0)) (i32.const 5)) (assert_unlinkable - (module $Q + (module $Qm (func $host (import "spectest" "print")) - (memory (import "M" "mem") 1) + (memory (import "Mm" "mem") 1) (table 10 anyfunc) (data (i32.const 0) "abc") (elem (i32.const 9) $host) @@ -225,4 +225,4 @@ ) "invalid use of host function" ) -(assert_return (invoke $M "load" (i32.const 0)) (i32.const 0)) +(assert_return (invoke $Mm "load" (i32.const 0)) (i32.const 0)) From 273b2859c707c12c28fc9afa0d9e06eb78c979f3 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sat, 10 Sep 2016 13:56:15 +0200 Subject: [PATCH 02/10] Refactor script stuff --- ml-proto/host/js.ml | 82 ++++++- ml-proto/host/js.mli | 1 + ml-proto/host/run.ml | 415 +++++++++++++++++++++++++++++++--- ml-proto/host/run.mli | 6 + ml-proto/host/script.ml | 473 +-------------------------------------- ml-proto/host/script.mli | 42 ---- 6 files changed, 467 insertions(+), 552 deletions(-) create mode 100644 ml-proto/host/js.mli delete mode 100644 ml-proto/host/script.mli diff --git a/ml-proto/host/js.ml b/ml-proto/host/js.ml index 802274ff76..48a940f010 100644 --- a/ml-proto/host/js.ml +++ b/ml-proto/host/js.ml @@ -1,4 +1,10 @@ -let js_prefix = +open Script +open Source + + +(* Harness *) + +let prefix = "'use strict';\n" ^ "\n" ^ "let spectest = {\n" ^ @@ -56,3 +62,77 @@ let js_prefix = " };\n" ^ "}\n" ^ "\n" + + +(* Script conversion *) + +let of_hex n = + assert (0 <= n && n < 16); + if n < 10 + then Char.chr (n + Char.code '0') + else Char.chr (n - 10 + Char.code 'a') + +let of_bytes s = + let buf = Buffer.create (4 * String.length s) in + for i = 0 to String.length s - 1 do + Buffer.add_string buf "\\x"; + Buffer.add_char buf (of_hex (Char.code s.[i] / 16)); + Buffer.add_char buf (of_hex (Char.code s.[i] mod 16)); + done; + "\"" ^ Buffer.contents buf ^ "\"" + +let of_literal lit = + match lit.it with + | Values.I32 i -> I32.to_string i + | Values.I64 i -> I64.to_string i (* TODO *) + | Values.F32 z -> F32.to_string z + | Values.F64 z -> F64.to_string 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 = + match act.it with + | Invoke (x_opt, name, lits) -> + of_var_opt x_opt ^ ".export[\"" ^ name ^ "\"]" ^ + "(" ^ String.concat ", " (List.map of_literal lits) ^ ")" + | Get (x_opt, name) -> + of_var_opt x_opt ^ ".export[\"" ^ name ^ "\"]" + +let of_assertion ass = + match ass.it with + | AssertInvalid (def, _) -> + "assert_invalid(" ^ of_definition def ^ ")" + | AssertUnlinkable (def, _) -> + "assert_unlinkable(" ^ of_definition def ^ ")" + | AssertReturn (act, lits) -> + "assert_return(() => " ^ of_action act ^ ", " ^ + String.concat ", " (List.map of_literal lits) ^ ")" + | AssertReturnNaN act -> + "assert_return_nan(() => " ^ of_action act ^ ")" + | AssertTrap (act, _) -> + "assert_trap(() => " ^ of_action act ^ ")" + +let of_command cmd = + match cmd.it with + | Module (x_opt, def) -> + (if x_opt <> None then "let " else "") ^ + of_var_opt x_opt ^ " = module(" ^ of_definition def ^ ");\n" + | Register (name, x_opt) -> + "register(" ^ name ^ ", " ^ of_var_opt x_opt ^ ")\n" + | Action act -> + of_action act ^ ";\n" + | Assertion ass -> + of_assertion ass ^ ";\n" + | Script _ | Input _ | Output _ -> assert false + +let of_script scr = + prefix ^ String.concat "" (List.map of_command scr) diff --git a/ml-proto/host/js.mli b/ml-proto/host/js.mli new file mode 100644 index 0000000000..c60d3c501b --- /dev/null +++ b/ml-proto/host/js.mli @@ -0,0 +1 @@ +val of_script : Script.script -> string diff --git a/ml-proto/host/run.ml b/ml-proto/host/run.ml index e8a78b899e..560e85a6d6 100644 --- a/ml-proto/host/run.ml +++ b/ml-proto/host/run.ml @@ -1,86 +1,150 @@ +open Script +open Source + + +(* Errors & Tracing *) + +module Abort = Error.Make () +module Assert = Error.Make () +module IO = Error.Make () + +exception Abort = Abort.Error +exception Assert = Assert.Error +exception IO = IO.Error + +let trace name = if !Flags.trace then print_endline ("-- " ^ name) + + (* File types *) -let sexpr_ext = "wast" let binary_ext = "wasm" +let sexpr_ext = "wast" +let js_ext = "js" -let dispatch_file_ext on_sexpr on_binary file = - if Filename.check_suffix file sexpr_ext then - on_sexpr file - else if Filename.check_suffix file binary_ext then +let dispatch_file_ext on_binary on_sexpr on_js file = + if Filename.check_suffix file binary_ext then on_binary file + else if Filename.check_suffix file sexpr_ext then + on_sexpr file + else if Filename.check_suffix file js_ext then + on_js file else - raise (Sys_error (file ^ ": Unrecognized file type")) + raise (Sys_error (file ^ ": unrecognized file type")) + + +(* Output *) + +let create_binary_file file m script = + trace ("Encoding (" ^ file ^ ")..."); + let s = Encode.encode m in + let oc = open_out_bin file in + try + trace "Writing..."; + output_string oc s; + close_out oc + with exn -> close_out oc; raise exn + +let create_sexpr_file file m script = + trace ("Formatting (" ^ file ^ ")..."); + let sexpr = Arrange.module_ m in + let oc = open_out file in + try + trace "Writing..."; + Sexpr.output oc !Flags.width sexpr; + close_out oc + with exn -> close_out oc; raise exn + +let create_js_file file m script = + trace ("Converting (" ^ file ^ ")..."); + let js = Js.of_script script in + let oc = open_out file in + try + trace "Writing..."; + output_string oc js; + close_out oc + with exn -> close_out oc; raise exn + +let output_file = + dispatch_file_ext create_binary_file create_sexpr_file create_js_file + +let output_stdout m = + trace "Formatting..."; + let sexpr = Arrange.module_ m in + trace "Printing..."; + Sexpr.output stdout !Flags.width sexpr (* Input *) let error at category msg = - Script.trace ("Error: "); + trace ("Error: "); prerr_endline (Source.string_of_region at ^ ": " ^ category ^ ": " ^ msg); false -let run_from run get_script = +let input_from get_script run = try let script = get_script () in - Script.trace "Running..."; + trace "Running..."; run script; true with | Decode.Code (at, msg) -> error at "decoding error" msg | Parse.Syntax (at, msg) -> error at "syntax error" msg - | Script.Assert (at, msg) -> error at "assertion failure" msg | Check.Invalid (at, msg) -> error at "invalid module" msg | Import.Unknown (at, msg) -> error at "link failure" msg | Eval.Link (at, msg) -> error at "link failure" msg | Eval.Trap (at, msg) -> error at "runtime trap" msg | Eval.Crash (at, msg) -> error at "runtime crash" msg - | Script.IO (at, msg) -> error at "i/o error" msg - | Script.Abort _ -> false + | IO (at, msg) -> error at "i/o error" msg + | Assert (at, msg) -> error at "assertion failure" msg + | Abort _ -> false -let run_sexpr run name lexbuf start = - run_from run (fun _ -> Parse.parse name lexbuf start) +let input_sexpr name lexbuf start run = + input_from (fun _ -> Parse.parse name lexbuf start) run -let run_binary run name buf = +let input_binary name buf run = let open Source in - run_from run + input_from (fun _ -> let m = Decode.decode name buf in - [Script.Module (None, Script.Textual m @@ m.at) @@ m.at]) + [Script.Module (None, Script.Textual m @@ m.at) @@ m.at] + ) run -let run_sexpr_file file run = - Script.trace ("Loading (" ^ file ^ ")..."); +let input_sexpr_file file run = + trace ("Loading (" ^ file ^ ")..."); let ic = open_in file in try let lexbuf = Lexing.from_channel ic in - Script.trace "Parsing..."; - let success = run_sexpr run file lexbuf Parse.Script in + trace "Parsing..."; + let success = input_sexpr file lexbuf Parse.Script run in close_in ic; success with exn -> close_in ic; raise exn -let run_binary_file file run = - Script.trace ("Loading (" ^ file ^ ")..."); +let input_binary_file file run = + trace ("Loading (" ^ file ^ ")..."); let ic = open_in_bin file in try let len = in_channel_length ic in let buf = Bytes.make len '\x00' in really_input ic buf 0 len; - Script.trace "Decoding..."; - let success = run_binary run file buf in + trace "Decoding..."; + let success = input_binary file buf run in close_in ic; success with exn -> close_in ic; raise exn -let run_file file = - dispatch_file_ext run_sexpr_file run_binary_file file Script.run +let input_js_file file run = + raise (Sys_error (file ^ ": unrecognized input file type")) -let run_string string = - Script.trace ("Running (\"" ^ String.escaped string ^ "\")..."); - let lexbuf = Lexing.from_string string in - Script.trace "Parsing..."; - run_sexpr Script.run "string" lexbuf Parse.Script +let input_file file run = + dispatch_file_ext input_binary_file input_sexpr_file input_js_file file run -let () = Script.input_file := dispatch_file_ext run_sexpr_file run_binary_file +let input_string string run = + trace ("Running (\"" ^ String.escaped string ^ "\")..."); + let lexbuf = Lexing.from_string string in + trace "Parsing..."; + input_sexpr "string" lexbuf Parse.Script run (* Interactive *) @@ -98,13 +162,13 @@ let lexbuf_stdin buf len = if ch = '\n' then i + 1 else loop (i + 1) in let n = loop 0 in - if n = 1 then continuing := false else Script.trace "Parsing..."; + if n = 1 then continuing := false else trace "Parsing..."; n -let rec run_stdin () = +let rec input_stdin run = let lexbuf = Lexing.from_function lexbuf_stdin in let rec loop () = - let success = run_sexpr Script.run "stdin" lexbuf Parse.Script1 in + let success = input_sexpr "stdin" lexbuf Parse.Script1 run in if not success then Lexing.flush_input lexbuf; if Lexing.(lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len - 1) then continuing := false; @@ -112,4 +176,281 @@ let rec run_stdin () = in try loop () with End_of_file -> print_endline ""; - Script.trace "Bye." + trace "Bye." + + +(* Configuration *) + +module Map = Map.Make(String) + +let registry : Instance.instance Map.t ref = ref Map.empty +let quote : script ref = ref [] + +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 scripts : script Map.t ref = ref Map.empty +let modules : Ast.module_ Map.t ref = ref Map.empty +let instances : Instance.instance Map.t ref = ref Map.empty + +let last_script : script option ref = ref None +let last_module : Ast.module_ option ref = ref None +let last_instance : Instance.instance option ref = ref None + +let bind map x_opt y = + match x_opt with + | None -> () + | Some x -> map := Map.add x.it y !map + +let get_script x_opt at = + match x_opt, !last_script with + | None, Some m -> m + | None, None -> raise (Eval.Crash (at, "no script defined")) + | Some x, _ -> + try Map.find x.it !scripts with Not_found -> + raise (Eval.Crash (x.at, "unknown script " ^ x.it)) + +let get_module x_opt at = + match x_opt, !last_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 x_opt at = + match x_opt, !last_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)) + + +(* Quoting *) + +let quote_definition def = + match def.it with + | Textual m -> m + | Binary bs -> + trace "Decoding..."; + Decode.decode "binary" bs + +let rec quote_command cmd = + match cmd.it with + | Script (x_opt, script) -> + let save_quote = !quote in + quote := []; + quote_script script; + let script' = List.rev !quote in + last_script := Some script'; + bind scripts x_opt script'; + quote := !quote @ save_quote + + | Module (x_opt, def) -> + let m = quote_definition def in + last_script := Some [cmd]; + last_module := Some m; + bind scripts x_opt [cmd]; + bind modules x_opt m; + quote := cmd :: !quote + + | Register _ + | Action _ + | Assertion _ -> + quote := cmd :: !quote + + | Input file -> + (try if not (input_file file quote_script) then + Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, Some file) -> + (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, None) -> + (try output_stdout (get_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg) + +and quote_script cmds = + let save_scripts = !scripts in + List.iter quote_command cmds; + scripts := save_scripts + + +(* Running *) + +let run_definition def = + match def.it with + | Textual m -> m + | Binary bs -> + 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 (Instance.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 (Instance.ExternalGlobal v) -> [v] + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" + ) + +let run_assertion ass = + match ass.it with + | AssertInvalid (def, re) -> + trace "Asserting invalid..."; + (match + let m = run_definition def in + Check.check_module m + with + | exception (Decode.Code (_, msg) | Check.Invalid (_, msg)) -> + if not (Str.string_match (Str.regexp re) msg 0) then begin + print_endline ("Result: \"" ^ msg ^ "\""); + print_endline ("Expect: \"" ^ re ^ "\""); + Assert.error ass.at "wrong validation error" + end + | _ -> + Assert.error ass.at "expected validation error" + ) + + | AssertUnlinkable (def, re) -> + trace "Asserting unlinkable..."; + let m = run_definition def in + if not !Flags.unchecked then Check.check_module m; + (match + let imports = Import.link m in + ignore (Eval.init m imports) + with + | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> + if not (Str.string_match (Str.regexp re) msg 0) then begin + print_endline ("Result: \"" ^ msg ^ "\""); + print_endline ("Expect: \"" ^ re ^ "\""); + Assert.error ass.at "wrong linking error" + end + | _ -> + Assert.error ass.at "expected linking error" + ) + + | AssertReturn (act, es) -> + trace ("Asserting return..."); + let got_vs = run_action act in + let expect_vs = List.map it es in + if got_vs <> expect_vs then begin + print_string "Result: "; Print.print_result got_vs; + print_string "Expect: "; Print.print_result expect_vs; + Assert.error ass.at "wrong return values" + end + + | AssertReturnNaN act -> + trace ("Asserting return..."); + let got_vs = run_action act in + if + match got_vs with + | [Values.F32 got_f32] -> + got_f32 <> F32.pos_nan && got_f32 <> F32.neg_nan + | [Values.F64 got_f64] -> + got_f64 <> F64.pos_nan && got_f64 <> F64.neg_nan + | _ -> true + then begin + print_string "Result: "; Print.print_result got_vs; + print_string "Expect: "; print_endline "nan"; + Assert.error ass.at "wrong return value" + end + + | 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 ^ "\""); + print_endline ("Expect: \"" ^ re ^ "\""); + Assert.error ass.at "wrong runtime trap" + end + | _ -> + Assert.error ass.at "expected runtime trap" + ) + +let rec run_command cmd = + match cmd.it with + | Script (x_opt, script) -> + assert (!quote = []); + quote_script script; + let script' = List.rev !quote in + quote := []; + last_script := Some script'; + bind scripts x_opt script' + + | Module (x_opt, def) -> + let m = run_definition def in + if not !Flags.unchecked then begin + trace "Checking..."; + Check.check_module m; + if !Flags.print_sig then begin + trace "Signature:"; + Print.print_module_sig m + end + end; + last_script := Some [cmd]; + last_module := Some m; + bind scripts x_opt [cmd]; + bind modules x_opt m; + if not !Flags.dry then begin + trace "Initializing..."; + let imports = Import.link m in + let inst = Eval.init m imports in + last_instance := Some inst; + bind instances x_opt inst + end + + | Register (name, x_opt) -> + if not !Flags.dry then begin + trace ("Registering module \"" ^ name ^ "\"..."); + let inst = get_instance x_opt cmd.at in + registry := Map.add name inst !registry; + Import.register name (lookup name) + end + + | Action act -> + if not !Flags.dry then begin + let vs = run_action act in + if vs <> [] then Print.print_result vs + end + + | Assertion ass -> + if not !Flags.dry then begin + run_assertion ass + end + + | Input file -> + (try if not (input_file file run_script) then Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, Some file) -> + (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, None) -> + (try output_stdout (get_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg) + +and run_script script = + List.iter run_command script + +let run_file file = input_file file run_script +let run_string str = input_string str run_script +let run_stdin () = input_stdin run_script diff --git a/ml-proto/host/run.mli b/ml-proto/host/run.mli index 9b0869bb4a..39393d260c 100644 --- a/ml-proto/host/run.mli +++ b/ml-proto/host/run.mli @@ -1,3 +1,9 @@ +exception Abort of Source.region * string +exception Assert of Source.region * string +exception IO of Source.region * string + +val trace : string -> unit + val run_string : string -> bool val run_file : string -> bool val run_stdin : unit -> unit diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 969043f5e6..e3f8e69d6d 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -1,9 +1,3 @@ -open Source -open Instance - - -(* Script representation *) - type var = string Source.phrase type definition = definition' Source.phrase @@ -36,469 +30,4 @@ and command' = and script = command list - -(* JS conversion *) - -let hex n = - assert (0 <= n && n < 16); - if n < 10 - then Char.chr (n + Char.code '0') - else Char.chr (n - 10 + Char.code 'a') - -let js_of_bytes s = - let buf = Buffer.create (4 * String.length s) in - for i = 0 to String.length s - 1 do - Buffer.add_string buf "\\x"; - Buffer.add_char buf (hex (Char.code s.[i] / 16)); - Buffer.add_char buf (hex (Char.code s.[i] mod 16)); - done; - "\"" ^ Buffer.contents buf ^ "\"" - -let js_of_literal lit = - match lit.it with - | Values.I32 i -> I32.to_string i - | Values.I64 i -> I64.to_string i (* TODO *) - | Values.F32 z -> F32.to_string z - | Values.F64 z -> F64.to_string z - -let js_of_var_opt = function - | None -> "$$" - | Some x -> x.it - -let js_of_def def = - let bs = - match def.it with - | Textual m -> Encode.encode m - | Binary bs -> bs - in js_of_bytes bs - -let js_of_action act = - match act.it with - | Invoke (x_opt, name, lits) -> - js_of_var_opt x_opt ^ ".export[\"" ^ name ^ "\"]" ^ - "(" ^ String.concat ", " (List.map js_of_literal lits) ^ ")" - | Get (x_opt, name) -> - js_of_var_opt x_opt ^ ".export[\"" ^ name ^ "\"]" - -let js_of_assertion ass = - match ass.it with - | AssertInvalid (def, _) -> - "assert_invalid(" ^ js_of_def def ^ ")" - | AssertUnlinkable (def, _) -> - "assert_unlinkable(" ^ js_of_def def ^ ")" - | AssertReturn (act, lits) -> - "assert_return(() => " ^ js_of_action act ^ ", " ^ - String.concat ", " (List.map js_of_literal lits) ^ ")" - | AssertReturnNaN act -> - "assert_return_nan(() => " ^ js_of_action act ^ ")" - | AssertTrap (act, _) -> - "assert_trap(() => " ^ js_of_action act ^ ")" - -let js_of_cmd cmd = - match cmd.it with - | Module (x_opt, def) -> - (if x_opt <> None then "let " else "") ^ - js_of_var_opt x_opt ^ " = module(" ^ js_of_def def ^ ");\n" - | Register (name, x_opt) -> - "register(" ^ name ^ ", " ^ js_of_var_opt x_opt ^ ")\n" - | Action act -> - js_of_action act ^ ";\n" - | Assertion ass -> - js_of_assertion ass ^ ";\n" - | Script _ | Input _ | Output _ -> assert false - -let js_of_script script = - Js.js_prefix ^ String.concat "" (List.map js_of_cmd script) - - -(* Errors *) - -module Abort = Error.Make () -module Syntax = Error.Make () -module Assert = Error.Make () -module IO = Error.Make () - -exception Abort = Abort.Error -exception Syntax = Syntax.Error -exception Assert = Assert.Error -exception IO = IO.Error - - -(* Configuration *) - -module Map = Map.Make(String) - -let quote : script ref = ref [] -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 scripts : script Map.t ref = ref Map.empty -let modules : Ast.module_ Map.t ref = ref Map.empty -let instances : Instance.instance Map.t ref = ref Map.empty - -let last_script : script option ref = ref None -let last_module : Ast.module_ option ref = ref None -let last_instance : Instance.instance option ref = ref None - -let bind map x_opt y = - match x_opt with - | None -> () - | Some x -> map := Map.add x.it y !map - -let get_script x_opt at = - match x_opt, !last_script with - | None, Some m -> m - | None, None -> raise (Eval.Crash (at, "no script defined")) - | Some x, _ -> - try Map.find x.it !scripts with Not_found -> - raise (Eval.Crash (x.at, "unknown script " ^ x.it)) - -let get_module x_opt at = - match x_opt, !last_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 x_opt at = - match x_opt, !last_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)) - - -(* Input & Output *) - -let trace name = if !Flags.trace then print_endline ("-- " ^ name) - -let input_file = ref (fun _ -> assert false) - -let binary_ext = "wasm" -let sexpr_ext = "wast" -let js_ext = "js" - -let dispatch_file_ext on_binary on_sexpr on_js file = - if Filename.check_suffix file binary_ext then - on_binary file - else if Filename.check_suffix file sexpr_ext then - on_sexpr file - else if Filename.check_suffix file js_ext then - on_js file - else - raise (Sys_error (file ^ ": Unrecognized file type")) - -let create_binary_file file m script = - trace ("Encoding (" ^ file ^ ")..."); - let s = Encode.encode m in - let oc = open_out_bin file in - try - trace "Writing..."; - output_string oc s; - close_out oc - with exn -> close_out oc; raise exn - -let create_sexpr_file file m script = - trace ("Formatting (" ^ file ^ ")..."); - let sexpr = Arrange.module_ m in - let oc = open_out file in - try - trace "Writing..."; - Sexpr.output oc !Flags.width sexpr; - close_out oc - with exn -> close_out oc; raise exn - -let create_js_file file m script = - trace ("Converting (" ^ file ^ ")..."); - let js = js_of_script script in - let oc = open_out file in - try - trace "Writing..."; - output_string oc js; - close_out oc - with exn -> close_out oc; raise exn - -let output_file = - dispatch_file_ext create_binary_file create_sexpr_file create_js_file - -let output_stdout m = - trace "Formatting..."; - let sexpr = Arrange.module_ m in - trace "Printing..."; - Sexpr.output stdout !Flags.width sexpr - - -(* Quoting *) - -let quote_def def = - match def.it with - | Textual m -> m - | Binary bs -> - trace "Decoding..."; - Decode.decode "binary" bs - -let rec quote_cmd cmd = - match cmd.it with - | Script (x_opt, script) -> - let save_quote = !quote in - quote := []; - quote_script script; - let script' = List.rev !quote in - last_script := Some script'; - bind scripts x_opt script'; - quote := !quote @ save_quote - - | Module (x_opt, def) -> - let m = quote_def def in - last_script := Some [cmd]; - last_module := Some m; - bind scripts x_opt [cmd]; - bind modules x_opt m; - quote := cmd :: !quote - - | Register _ - | Action _ - | Assertion _ -> - quote := cmd :: !quote - - | Input file -> - (try if not (!input_file file quote_script) then - Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg) - - | Output (x_opt, Some file) -> - (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - - | Output (x_opt, None) -> - (try output_stdout (get_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - -and quote_script cmds = - let save_scripts = !scripts in - List.iter quote_cmd cmds; - scripts := save_scripts - - -(* Running *) - -let run_def def = - match def.it with - | Textual m -> m - | Binary bs -> - 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) -> [v] - | Some _ -> Assert.error act.at "export is not a global" - | None -> Assert.error act.at "undefined export" - ) - -let run_assertion ass = - match ass.it with - | AssertInvalid (def, re) -> - trace "Asserting invalid..."; - (match - let m = run_def def in - Check.check_module m - with - | exception (Decode.Code (_, msg) | Check.Invalid (_, msg)) -> - if not (Str.string_match (Str.regexp re) msg 0) then begin - print_endline ("Result: \"" ^ msg ^ "\""); - print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error ass.at "wrong validation error" - end - | _ -> - Assert.error ass.at "expected validation error" - ) - - | AssertUnlinkable (def, re) -> - trace "Asserting unlinkable..."; - let m = run_def def in - if not !Flags.unchecked then Check.check_module m; - (match - let imports = Import.link m in - ignore (Eval.init m imports) - with - | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> - if not (Str.string_match (Str.regexp re) msg 0) then begin - print_endline ("Result: \"" ^ msg ^ "\""); - print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error ass.at "wrong linking error" - end - | _ -> - Assert.error ass.at "expected linking error" - ) - - | AssertReturn (act, es) -> - trace ("Asserting return..."); - let got_vs = run_action act in - let expect_vs = List.map it es in - if got_vs <> expect_vs then begin - print_string "Result: "; Print.print_result got_vs; - print_string "Expect: "; Print.print_result expect_vs; - Assert.error ass.at "wrong return values" - end - - | AssertReturnNaN act -> - trace ("Asserting return..."); - let got_vs = run_action act in - if - match got_vs with - | [Values.F32 got_f32] -> - got_f32 <> F32.pos_nan && got_f32 <> F32.neg_nan - | [Values.F64 got_f64] -> - got_f64 <> F64.pos_nan && got_f64 <> F64.neg_nan - | _ -> true - then begin - print_string "Result: "; Print.print_result got_vs; - print_string "Expect: "; print_endline "nan"; - Assert.error ass.at "wrong return value" - end - - | 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 ^ "\""); - print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error ass.at "wrong runtime trap" - end - | _ -> - Assert.error ass.at "expected runtime trap" - ) - -let rec run_cmd cmd = - match cmd.it with - | Script (x_opt, script) -> - assert (!quote = []); - quote_script script; - let script' = List.rev !quote in - quote := []; - last_script := Some script'; - bind scripts x_opt script' - - | Module (x_opt, def) -> - let m = run_def def in - if not !Flags.unchecked then begin - trace "Checking..."; - Check.check_module m; - if !Flags.print_sig then begin - trace "Signature:"; - Print.print_module_sig m - end - end; - trace "Initializing..."; - let imports = Import.link m in - let inst = Eval.init m imports in - last_script := Some [cmd]; - last_module := Some m; - last_instance := Some inst; - bind scripts x_opt [cmd]; - bind modules x_opt m; - bind instances x_opt inst - - | 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 vs = run_action act in - if vs <> [] then Print.print_result vs - - | Assertion ass -> - run_assertion ass - - | Input file -> - (try if not (!input_file file run_script) then Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg) - - | Output (x_opt, Some file) -> - (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - - | Output (x_opt, None) -> - (try output_stdout (get_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - -and run_script script = - List.iter run_cmd script - - -(* Dry run *) - -let dry_def def = - match def.it with - | Textual m -> m - | Binary bs -> - trace "Decoding..."; - Decode.decode "binary" bs - -let rec dry_cmd cmd = - match cmd.it with - | Script (x_opt, script) -> - assert (!quote = []); - quote_script script; - let script' = List.rev !quote in - quote := []; - last_script := Some script'; - bind scripts x_opt script' - - | Module (x_opt, def) -> - let m = dry_def def in - if not !Flags.unchecked then begin - trace "Checking..."; - Check.check_module m; - if !Flags.print_sig then begin - trace "Signature:"; - Print.print_module_sig m - end - end; - last_script := Some [cmd]; - last_module := Some m; - bind scripts x_opt [cmd]; - bind modules x_opt m - - | Input file -> - (try if not (!input_file file dry_script) then Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg) - | Output (x_opt, Some file) -> - (try output_file file (get_module x_opt cmd.at) (get_script x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - | Output (x_opt, None) -> - (try output_stdout (get_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - - | Register _ - | Action _ - | Assertion _ -> () - -and dry_script script = - List.iter dry_cmd script - -let run script = - (if !Flags.dry then dry_script else run_script) script +exception Syntax of Source.region * string diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli deleted file mode 100644 index dff1627398..0000000000 --- a/ml-proto/host/script.mli +++ /dev/null @@ -1,42 +0,0 @@ -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 * Ast.literal list - | Get of var option * string - -type assertion = assertion' Source.phrase -and assertion' = - | AssertInvalid of definition * string - | AssertUnlinkable of definition * string - | AssertReturn of action * Ast.literal list - | AssertReturnNaN of action - | AssertTrap of action * string - -type command = command' Source.phrase -and command' = - | Script of var option * script - | Module of var option * definition - | Register of string * var option - | Action of action - | Assertion of assertion - | Input of string - | Output of var option * string option - -and script = command list - -exception Abort of Source.region * string -exception Syntax of Source.region * string -exception Assert of Source.region * string -exception IO of Source.region * string - -val run : script -> unit - (* raises Check.Invalid, Eval.Trap, Eval.Crash, Assert, IO *) - -val trace : string -> unit -val input_file : (string -> (script -> unit) -> bool) ref From 8723fcdc9fca6238409603755ce98a7aa09900c7 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sat, 10 Sep 2016 14:55:03 +0200 Subject: [PATCH 03/10] Update README --- ml-proto/README.md | 28 +++++++++++++++++++++------- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/ml-proto/README.md b/ml-proto/README.md index ee0a63e980..6116a479b3 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -84,6 +84,14 @@ In the second case, the produced script contains exactly one module definition. The `-d` option selects "dry mode" and ensures that the input module is not run, even if it has a start section. In addition, the `-u` option for "unchecked mode" can be used to convert even modules that do not validate. +The interpreter can also convert entire test script to equivalent, self-contained JavaScript test files: + +``` +wasm -s script.wast -o script.js +``` + +Note the `-s` necessary to instruct the interpreter to convert the whole script, not just the (last) module in it. + Finally, the option `-e` allows to provide arbitrary script commands directly on the command line. For example: ``` @@ -241,25 +249,31 @@ script: * cmd: ;; define, validate, and initialize module ;; perform action and print results + ;; assert result of an action ( 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 +module with given failure string + ( script ?