From 583666ab0702a1d886610e1ff4d35512a026a6c6 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sun, 25 Jul 2021 08:09:44 +0200 Subject: [PATCH 1/9] New script constructs --- interpreter/README.md | 5 ++- interpreter/script/js.ml | 67 ++++++++++++++++++++++-------------- interpreter/script/run.ml | 63 ++++++++++++++++++--------------- interpreter/script/script.ml | 5 +-- interpreter/text/arrange.ml | 14 ++++---- interpreter/text/lexer.mll | 3 +- interpreter/text/parser.mly | 10 +++--- 7 files changed, 99 insertions(+), 68 deletions(-) diff --git a/interpreter/README.md b/interpreter/README.md index 6ec7bd3e..257b903c 100644 --- a/interpreter/README.md +++ b/interpreter/README.md @@ -374,6 +374,8 @@ binscript: * cmd: ;; define, validate, and initialize module ( register ? ) ;; register module for imports + ( thread ? cmd* ) ;; spawn thread + ( wait ) ;; join thread ;; perform action and print results ;; assert result of an action @@ -394,7 +396,8 @@ assertion: ( assert_trap ) ;; assert module traps on instantiation result: - ( .const ) + ( .const ) ;; numeric result + ( oneof result* ) ;; non-deterministic result numpat: ;; literal result diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index daa5e6e9..c19f4213 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -133,21 +133,34 @@ function assert_return(action, ...expected) { throw new Error(expected.length + " value(s) expected, got " + actual.length); } for (let i = 0; i < actual.length; ++i) { - switch (expected[i]) { - case "nan:canonical": - case "nan:arithmetic": - case "nan:any": - // Note that JS can't reliably distinguish different NaN values, - // so there's no good way to test that it's a canonical NaN. - if (!Number.isNaN(actual[i])) { - throw new Error("Wasm return value NaN expected, got " + actual[i]); - }; - return; - default: - if (!Object.is(actual[i], expected[i])) { - throw new Error("Wasm return value " + expected[i] + " expected, got " + actual[i]); - }; - } + match_result(actual[i], expected[i]); + } +} + +function match_result(actual, expected) { + switch (expected) { + case "nan:canonical": + case "nan:arithmetic": + case "nan:any": + // Note that JS can't reliably distinguish different NaN values, + // so there's no good way to test that it's a canonical NaN. + if (!Number.isNaN(actual)) { + throw new Error("Wasm return value NaN expected, got " + actual); + }; + return; + default: + if (Array.isArray(expected)) { + for (let i = 0; i < expected.length; ++i) { + try { + match_result(actual, expected[i]); + return; + } catch (e) {} + } + throw new Error("Wasm return value in " + expected + " expected, got " + actual); + } + if (!Object.is(actual, expected)) { + throw new Error("Wasm return value " + expected + " expected, got " + actual); + }; } } |} @@ -257,6 +270,9 @@ let assert_return ress ts at = Compare (eq_of t') @@ at; Test (Values.I32 I32Op.Eqz) @@ at; BrIf (0l @@ at) @@ at ] + | OneofResult ress -> + (* TODO *) + assert false in [], List.flatten (List.rev_map test ress) let wrap module_name item_name wrap_action wrap_assertion at = @@ -333,13 +349,16 @@ let of_nan = function | CanonicalNan -> "nan:canonical" | ArithmeticNan -> "nan:arithmetic" -let of_result res = +let rec of_result res = match res.it with | LitResult lit -> of_literal lit | NanResult nanop -> - match nanop.it with + (match nanop.it with | Values.I32 _ | Values.I64 _ -> assert false | Values.F32 n | Values.F64 n -> of_nan n + ) + | OneofResult ress -> + "[" ^ String.concat ", " (List.map of_result ress) ^ "]" let rec of_definition def = match def.it with @@ -374,9 +393,6 @@ let of_action mods act = Some (of_wrapper mods x_opt name (get gt), [t]) | _ -> None ) - (* TODO(binji): *) - | Join x -> - assert false let of_assertion' mods act name args wrapper_opt = let act_js, act_wrapper_opt = of_action mods act in @@ -408,9 +424,6 @@ let of_assertion mods ass = | AssertExhaustion (act, _) -> of_assertion' mods act "assert_exhaustion" [] None -(* TODO(binji): *) -let of_thread mods x_opt act = assert false - let of_command mods cmd = "\n// " ^ Filename.basename cmd.at.left.file ^ ":" ^ string_of_int cmd.at.left.line ^ "\n" ^ @@ -431,8 +444,12 @@ let of_command mods cmd = of_assertion' mods act "run" [] None ^ "\n" | Assertion ass -> of_assertion mods ass ^ "\n" - | Thread (x_opt, act) -> - of_thread mods x_opt act ^ "\n" + | Thread (x_opt, cmds) -> + (* TODO *) + assert false + | Wait x -> + (* TODO *) + assert false | Meta _ -> assert false let of_script scr = diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 25a2c4d8..6760099d 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -248,18 +248,22 @@ let string_of_nan = function | CanonicalNan -> "nan:canonical" | ArithmeticNan -> "nan:arithmetic" -let type_of_result r = - match r with +let rec type_of_result r = + match r.it with | LitResult v -> Values.type_of v.it | NanResult n -> Values.type_of n.it + | OneofResult rs -> type_of_result (List.hd rs) -let string_of_result r = - match r with +let rec string_of_result r = + match r.it with | LitResult v -> Values.string_of_value v.it | NanResult nanop -> - match nanop.it with + (match nanop.it with | Values.I32 _ | Values.I64 _ -> assert false | Values.F32 n | Values.F64 n -> string_of_nan n + ) + | OneofResult rs -> + "(" ^ String.concat " | " (List.map string_of_result rs) ^ ")" let string_of_results = function | [r] -> string_of_result r @@ -340,29 +344,28 @@ let run_action act : Values.value list = | None -> Assert.error act.at "undefined export" ) - (* TODO(binji) *) - | Join x -> - assert false +let rec match_result at v r = + let open Values in + match r.it with + | LitResult v' -> v = v'.it + | NanResult nanop -> + (match nanop.it, v with + | F32 CanonicalNan, F32 z -> z = F32.pos_nan || z = F32.neg_nan + | F64 CanonicalNan, F64 z -> z = F64.pos_nan || z = F64.neg_nan + | F32 ArithmeticNan, F32 z -> + let pos_nan = F32.to_bits F32.pos_nan in + Int32.logand (F32.to_bits z) pos_nan = pos_nan + | F64 ArithmeticNan, F64 z -> + let pos_nan = F64.to_bits F64.pos_nan in + Int64.logand (F64.to_bits z) pos_nan = pos_nan + | _, _ -> false + ) + | OneofResult rs -> List.exists (match_result at v) rs let assert_result at got expect = - let open Values in if List.length got <> List.length expect || - List.exists2 (fun v r -> - match r with - | LitResult v' -> v <> v'.it - | NanResult nanop -> - match nanop.it, v with - | F32 CanonicalNan, F32 z -> z <> F32.pos_nan && z <> F32.neg_nan - | F64 CanonicalNan, F64 z -> z <> F64.pos_nan && z <> F64.neg_nan - | F32 ArithmeticNan, F32 z -> - let pos_nan = F32.to_bits F32.pos_nan in - Int32.logand (F32.to_bits z) pos_nan <> pos_nan - | F64 ArithmeticNan, F64 z -> - let pos_nan = F64.to_bits F64.pos_nan in - Int64.logand (F64.to_bits z) pos_nan <> pos_nan - | _, _ -> false - ) got expect + not (List.for_all2 (match_result at) got expect) then begin print_string "Result: "; print_values got; print_string "Expect: "; print_results expect; @@ -429,8 +432,7 @@ let run_assertion ass = | AssertReturn (act, rs) -> trace ("Asserting return..."); let got_vs = run_action act in - let expect_rs = List.map (fun r -> r.it) rs in - assert_result ass.at got_vs expect_rs + assert_result ass.at got_vs rs | AssertTrap (act, re) -> trace ("Asserting trap..."); @@ -491,8 +493,13 @@ let rec run_command cmd = run_assertion ass end - (* TODO(binji) *) - | Thread (x_opt, act) -> assert false + | Thread (x_opt, act) -> + (* TODO *) + assert false + + | Wait x -> + (* TODO *) + assert false | Meta cmd -> run_meta cmd diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index dbcc7235..ef1cd120 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -10,7 +10,6 @@ type action = action' Source.phrase and action' = | Invoke of var option * Ast.name * Ast.literal list | Get of var option * Ast.name - | Join of var type nanop = nanop' Source.phrase and nanop' = (unit, unit, nan, nan) Values.op @@ -20,6 +19,7 @@ type result = result' Source.phrase and result' = | LitResult of Ast.literal | NanResult of nanop + | OneofResult of result list type assertion = assertion' Source.phrase and assertion' = @@ -37,7 +37,8 @@ and command' = | Register of Ast.name * var option | Action of action | Assertion of assertion - | Thread of var option * action + | Thread of var option * command list + | Wait of var | Meta of meta and meta = meta' Source.phrase diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index 9ce7c277..c5eac23b 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -490,21 +490,21 @@ let action mode act = Node ("invoke" ^ access x_opt name, List.map (literal mode) lits) | Get (x_opt, name) -> Node ("get" ^ access x_opt name, []) - | Join x -> - Node ("join " ^ x.it, []) let nan = function | CanonicalNan -> "nan:canonical" | ArithmeticNan -> "nan:arithmetic" -let result mode res = +let rec result mode res = match res.it with | LitResult lit -> literal mode lit | NanResult nanop -> - match nanop.it with + (match nanop.it with | Values.I32 _ | Values.I64 _ -> assert false | Values.F32 n -> Node ("f32.const " ^ nan n, []) | Values.F64 n -> Node ("f64.const " ^ nan n, []) + ) + | OneofResult ress -> Node ("oneof", List.map (result mode) ress) let assertion mode ass = match ass.it with @@ -527,13 +527,15 @@ let assertion mode ass = | AssertExhaustion (act, re) -> [Node ("assert_exhaustion", [action mode act; Atom (string re)])] -let command mode cmd = +let rec command mode cmd = match cmd.it with | Module (x_opt, def) -> [definition mode x_opt def] | Register (n, x_opt) -> [Node ("register " ^ name n ^ var_opt x_opt, [])] | Action act -> [action mode act] | Assertion ass -> assertion mode ass - | Thread (x_opt, act) -> [Node ("thread " ^ var_opt x_opt, [action mode act])] + | Thread (x_opt, cmds) -> + [Node ("thread " ^ var_opt x_opt, List.concat_map (command mode) cmds)] + | Wait x -> [Node ("wait " ^ x.it, [])] | Meta _ -> assert false let script mode scr = Lib.List.concat_map (command mode) scr diff --git a/interpreter/text/lexer.mll b/interpreter/text/lexer.mll index 317b4054..e2d1cb92 100644 --- a/interpreter/text/lexer.mll +++ b/interpreter/text/lexer.mll @@ -440,7 +440,7 @@ rule token = parse | "script" { SCRIPT } | "register" { REGISTER } | "thread" { THREAD } - | "join" { JOIN } + | "wait" { WAIT } | "invoke" { INVOKE } | "get" { GET } | "assert_malformed" { ASSERT_MALFORMED } @@ -451,6 +451,7 @@ rule token = parse | "assert_exhaustion" { ASSERT_EXHAUSTION } | "nan:canonical" { NAN Script.CanonicalNan } | "nan:arithmetic" { NAN Script.ArithmeticNan } + | "oneof" { ONEOF } | "input" { INPUT } | "output" { OUTPUT } diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index 20203486..173089d6 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -176,10 +176,10 @@ let inline_type_explicit (c : context) x ft at = %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL %token TABLE ELEM MEMORY DATA OFFSET IMPORT EXPORT TABLE %token MODULE BIN QUOTE -%token SCRIPT REGISTER THREAD JOIN INVOKE GET +%token SCRIPT REGISTER THREAD WAIT INVOKE GET %token ASSERT_MALFORMED ASSERT_INVALID ASSERT_SOFT_INVALID ASSERT_UNLINKABLE %token ASSERT_RETURN ASSERT_TRAP ASSERT_EXHAUSTION -%token NAN +%token NAN ONEOF %token INPUT OUTPUT %token EOF @@ -875,8 +875,6 @@ action : { Invoke ($3, $4, $5) @@ at () } | LPAR GET module_var_opt name RPAR { Get ($3, $4) @@ at() } - | LPAR JOIN thread_var RPAR - { Join $3 @@ at () } assertion : | LPAR ASSERT_MALFORMED script_module STRING RPAR @@ -900,7 +898,8 @@ cmd : | assertion { Assertion $1 @@ at () } | script_module { Module (fst $1, snd $1) @@ at () } | LPAR REGISTER name module_var_opt RPAR { Register ($3, $4) @@ at () } - | LPAR THREAD thread_var_opt action RPAR { Thread ($3, $4) @@ at () } + | LPAR THREAD thread_var_opt cmd_list RPAR { Thread ($3, $4) @@ at () } + | LPAR WAIT thread_var RPAR { Wait $3 @@ at () } | meta { Meta $1 @@ at () } cmd_list : @@ -923,6 +922,7 @@ const_list : result : | const { LitResult $1 @@ at () } | LPAR CONST NAN RPAR { NanResult (nanop $2 ($3 @@ ati 3)) @@ at () } + | LPAR ONEOF result result_list RPAR { OneofResult ($3 :: $4) @@ at () } result_list : | /* empty */ { [] } From 1dac4a62c8f7ee7bd82997bf554c22797f87c246 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sun, 25 Jul 2021 10:27:12 +0200 Subject: [PATCH 2/9] Implement script threads --- interpreter/main/main.ml | 7 +- interpreter/script/run.ml | 173 +++++++++++++++++++++-------------- interpreter/script/run.mli | 10 +- interpreter/script/script.ml | 2 +- interpreter/text/arrange.ml | 2 +- interpreter/text/parser.mly | 2 +- 6 files changed, 121 insertions(+), 75 deletions(-) diff --git a/interpreter/main/main.ml b/interpreter/main/main.ml index d7f2b44f..a445103a 100644 --- a/interpreter/main/main.ml +++ b/interpreter/main/main.ml @@ -31,6 +31,8 @@ let argspec = Arg.align "-h", Arg.Clear Flags.harness, " exclude harness for JS conversion"; "-d", Arg.Set Flags.dry, " dry, do not run program"; "-t", Arg.Set Flags.trace, " trace execution"; + "-r", Arg.Int Random.init, " set non-determinism random seed"; + "-rr", Arg.Unit Random.self_init, " randomize non-determinism random seed"; "-v", Arg.Unit banner, " show version" ] @@ -40,12 +42,13 @@ let () = configure (); Arg.parse argspec (fun file -> add_arg ("(input " ^ quote file ^ ")")) usage; - List.iter (fun arg -> if not (Run.run_string arg) then exit 1) !args; + let config = Run.config () in + List.iter (fun arg -> if not (Run.run_string config arg) then exit 1) !args; if !args = [] then Flags.interactive := true; if !Flags.interactive then begin Flags.print_sig := true; banner (); - Run.run_stdin () + Run.run_stdin config end with exn -> flush_all (); diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 6760099d..5dbb8a9d 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -280,11 +280,36 @@ let print_results rs = module Map = Map.Make(String) -let quote : script ref = ref [] -let scripts : script Map.t ref = ref Map.empty -let modules : Ast.module_ Map.t ref = ref Map.empty -let instances : Instance.module_inst Map.t ref = ref Map.empty -let registry : Instance.module_inst Map.t ref = ref Map.empty +type task = Task of (task -> unit) list ref + +type config = + { quote : script ref; + scripts : script Map.t ref; + threads : task Map.t ref; + modules : Ast.module_ Map.t ref; + instances : Instance.module_inst Map.t ref; + registry : Instance.module_inst Map.t ref; + tasks : task list ref; + } + +let config () = + { quote = ref []; + scripts = ref Map.empty; + threads = ref Map.empty; + modules = ref Map.empty; + instances = ref Map.empty; + registry = ref Map.empty; + tasks = ref []; + } + +let local c = + { (config ()) with + scripts = ref !(c.scripts); + threads = ref !(c.threads); + modules = ref !(c.modules); + instances = ref !(c.instances); + tasks = c.tasks; + } let bind map x_opt y = let map' = @@ -300,19 +325,20 @@ let lookup category map x_opt at = (if key = "" then "no " ^ category ^ " defined" else "unknown " ^ category ^ " " ^ key) -let lookup_script = lookup "script" scripts -let lookup_module = lookup "module" modules -let lookup_instance = lookup "module" instances +let lookup_script c = lookup "script" c.scripts +let lookup_thread c = lookup "thread" c.threads +let lookup_module c = lookup "module" c.modules +let lookup_instance c = lookup "module" c.instances -let lookup_registry module_name item_name _t = - match Instance.export (Map.find module_name !registry) item_name with +let lookup_registry c module_name item_name _t = + match Instance.export (Map.find module_name !(c.registry)) item_name with | Some ext -> ext | None -> raise Not_found (* Running *) -let rec run_definition def : Ast.module_ = +let rec run_definition c def : Ast.module_ = match def.it with | Textual m -> m | Encoded (name, bs) -> @@ -321,13 +347,13 @@ let rec run_definition def : Ast.module_ = | Quoted (_, s) -> trace "Parsing quote..."; let def' = Parse.string_to_module s in - run_definition def' + run_definition c def' -let run_action act : Values.value list = +let run_action c act : Values.value list = match act.it with | Invoke (x_opt, name, vs) -> trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in + let inst = lookup_instance c x_opt act.at in (match Instance.export inst name with | Some (Instance.ExternFunc f) -> Eval.invoke f (List.map (fun v -> v.it) vs) @@ -337,7 +363,7 @@ let run_action act : Values.value list = | Get (x_opt, name) -> trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in + let inst = lookup_instance c x_opt act.at in (match Instance.export inst name with | Some (Instance.ExternGlobal gl) -> [Global.load gl] | Some _ -> Assert.error act.at "export is not a global" @@ -382,11 +408,11 @@ let assert_message at name msg re = Assert.error at ("wrong " ^ name ^ " error") end -let run_assertion ass = +let run_assertion c ass = match ass.it with | AssertMalformed (def, re) -> trace "Asserting malformed..."; - (match ignore (run_definition def) with + (match ignore (run_definition c def) with | exception Decode.Code (_, msg) -> assert_message ass.at "decoding" msg re | exception Parse.Syntax (_, msg) -> assert_message ass.at "parsing" msg re | _ -> Assert.error ass.at "expected decoding/parsing error" @@ -395,7 +421,7 @@ let run_assertion ass = | AssertInvalid (def, re) -> trace "Asserting invalid..."; (match - let m = run_definition def in + let m = run_definition c def in Valid.check_module m with | exception Valid.Invalid (_, msg) -> @@ -405,7 +431,7 @@ let run_assertion ass = | AssertUnlinkable (def, re) -> trace "Asserting unlinkable..."; - let m = run_definition def in + let m = run_definition c def in if not !Flags.unchecked then Valid.check_module m; (match let imports = Import.link m in @@ -418,7 +444,7 @@ let run_assertion ass = | AssertUninstantiable (def, re) -> trace "Asserting trap..."; - let m = run_definition def in + let m = run_definition c def in if not !Flags.unchecked then Valid.check_module m; (match let imports = Import.link m in @@ -431,29 +457,29 @@ let run_assertion ass = | AssertReturn (act, rs) -> trace ("Asserting return..."); - let got_vs = run_action act in + let got_vs = run_action c act in assert_result ass.at got_vs rs | AssertTrap (act, re) -> trace ("Asserting trap..."); - (match run_action act with + (match run_action c act with | exception Eval.Trap (_, msg) -> assert_message ass.at "runtime" msg re | _ -> Assert.error ass.at "expected runtime error" ) | AssertExhaustion (act, re) -> trace ("Asserting exhaustion..."); - (match run_action act with + (match run_action c act with | exception Eval.Exhaustion (_, msg) -> assert_message ass.at "exhaustion" msg re | _ -> Assert.error ass.at "expected exhaustion error" ) -let rec run_command cmd = +let rec run_command c cmd task = match cmd.it with | Module (x_opt, def) -> - quote := cmd :: !quote; - let m = run_definition def in + c.quote := cmd :: !(c.quote); + let m = run_definition c def in if not !Flags.unchecked then begin trace "Checking..."; Valid.check_module m; @@ -462,87 +488,100 @@ let rec run_command cmd = print_module x_opt m end end; - bind scripts x_opt [cmd]; - bind modules x_opt m; + bind c.scripts x_opt [cmd]; + bind c.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 - bind instances x_opt inst + bind c.instances x_opt inst end | Register (name, x_opt) -> - quote := cmd :: !quote; + c.quote := cmd :: !(c.quote); if not !Flags.dry then begin trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt cmd.at in - registry := Map.add (Utf8.encode name) inst !registry; - Import.register name (lookup_registry (Utf8.encode name)) + let inst = lookup_instance c x_opt cmd.at in + c.registry := Map.add (Utf8.encode name) inst !(c.registry); + Import.register name (lookup_registry c (Utf8.encode name)) end | Action act -> - quote := cmd :: !quote; + c.quote := cmd :: !(c.quote); if not !Flags.dry then begin - let vs = run_action act in + let vs = run_action c act in if vs <> [] then print_values vs end | Assertion ass -> - quote := cmd :: !quote; + c.quote := cmd :: !(c.quote); if not !Flags.dry then begin - run_assertion ass + run_assertion c ass end - | Thread (x_opt, act) -> - (* TODO *) - assert false + | Thread (x_opt, cmds) -> + let task = Task (ref (List.map (run_command c) cmds)) in + c.tasks := task :: !(c.tasks); + bind c.threads x_opt task - | Wait x -> - (* TODO *) - assert false + | Wait x_opt -> + if lookup_thread c x_opt cmd.at <> Task (ref []) then begin + let Task steps = task in + steps := run_command c cmd :: !steps + end | Meta cmd -> - run_meta cmd + run_meta c cmd -and run_meta cmd = +and run_meta c cmd = match cmd.it with | Script (x_opt, script) -> - run_quote_script script; - bind scripts x_opt (lookup_script None cmd.at) + run_quote_script c script; + bind c.scripts x_opt (lookup_script c None cmd.at) | Input (x_opt, file) -> - (try if not (input_file file run_quote_script) then + (try if not (input_file file (run_quote_script c)) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg); - bind scripts x_opt (lookup_script None cmd.at); + bind c.scripts x_opt (lookup_script c None cmd.at); if x_opt <> None then begin - bind modules x_opt (lookup_module None cmd.at); + bind c.modules x_opt (lookup_module c None cmd.at); if not !Flags.dry then begin - bind instances x_opt (lookup_instance None cmd.at) + bind c.instances x_opt (lookup_instance c None cmd.at) end end | Output (x_opt, Some file) -> (try output_file file - (fun () -> lookup_script x_opt cmd.at) - (fun () -> lookup_module x_opt cmd.at) + (fun () -> lookup_script c x_opt cmd.at) + (fun () -> lookup_module c x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) | Output (x_opt, None) -> - (try output_stdout (fun () -> lookup_module x_opt cmd.at) + (try output_stdout (fun () -> lookup_module c x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) -and run_script script = - List.iter run_command script - -and run_quote_script script = - let save_quote = !quote in - quote := []; - (try run_script script with exn -> quote := save_quote; raise exn); - bind scripts None (List.rev !quote); - quote := !quote @ save_quote - -let run_file file = input_file file run_script -let run_string string = input_string string run_script -let run_stdin () = input_stdin run_script +and run_step c = + let Task steps as task = + List.nth !(c.tasks) (Random.int (List.length !(c.tasks))) in + match !steps with + | [] -> run_step c + | step::steps' -> steps := steps'; step task + +and run_script c script = + let task = Task (ref (List.map (run_command c) script)) in + c.tasks := task :: !(c.tasks); + while task <> Task (ref []) do + run_step c + done + +and run_quote_script c script = + let c' = local c in + run_script c' script; + bind c.scripts None (List.rev !(c'.quote)); + c.quote := !(c'.quote) @ !(c.quote) + +let run_file c file = input_file file (run_script c) +let run_string c string = input_string string (run_script c) +let run_stdin c = input_stdin (run_script c) diff --git a/interpreter/script/run.mli b/interpreter/script/run.mli index 39393d26..237d0c50 100644 --- a/interpreter/script/run.mli +++ b/interpreter/script/run.mli @@ -1,9 +1,13 @@ +type config + 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 +val config : unit -> config + +val run_string : config -> string -> bool +val run_file : config -> string -> bool +val run_stdin : config -> unit diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index ef1cd120..5c397f02 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -38,7 +38,7 @@ and command' = | Action of action | Assertion of assertion | Thread of var option * command list - | Wait of var + | Wait of var option | Meta of meta and meta = meta' Source.phrase diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index c5eac23b..b750a2bc 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -535,7 +535,7 @@ let rec command mode cmd = | Assertion ass -> assertion mode ass | Thread (x_opt, cmds) -> [Node ("thread " ^ var_opt x_opt, List.concat_map (command mode) cmds)] - | Wait x -> [Node ("wait " ^ x.it, [])] + | Wait x_opt -> [Node ("wait " ^ var_opt x_opt, [])] | Meta _ -> assert false let script mode scr = Lib.List.concat_map (command mode) scr diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index 173089d6..d1298f9c 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -899,7 +899,7 @@ cmd : | script_module { Module (fst $1, snd $1) @@ at () } | LPAR REGISTER name module_var_opt RPAR { Register ($3, $4) @@ at () } | LPAR THREAD thread_var_opt cmd_list RPAR { Thread ($3, $4) @@ at () } - | LPAR WAIT thread_var RPAR { Wait $3 @@ at () } + | LPAR WAIT thread_var_opt RPAR { Wait $3 @@ at () } | meta { Meta $1 @@ at () } cmd_list : From 5a1e753ee734b3bf50b8b3f9f103750c6f08e607 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sun, 25 Jul 2021 23:52:29 +0200 Subject: [PATCH 3/9] Implement Wasm threads --- interpreter/exec/eval.ml | 87 ++++++++---- interpreter/exec/eval.mli | 14 +- interpreter/main/main.ml | 6 +- interpreter/runtime/instance.ml | 7 + interpreter/script/js.ml | 14 +- interpreter/script/run.ml | 238 +++++++++++++++++++------------- interpreter/script/run.mli | 10 +- interpreter/script/script.ml | 4 +- interpreter/syntax/types.ml | 11 ++ interpreter/text/arrange.ml | 20 ++- interpreter/text/arrange.mli | 1 + interpreter/text/parser.mly | 2 +- interpreter/text/print.ml | 2 + interpreter/text/print.mli | 1 + interpreter/util/lib.ml | 22 +++ interpreter/util/lib.mli | 4 + test/core/thread.wast | 28 ++++ 17 files changed, 329 insertions(+), 142 deletions(-) create mode 100644 test/core/thread.wast diff --git a/interpreter/exec/eval.ml b/interpreter/exec/eval.ml index ea6ed72f..585bb16c 100644 --- a/interpreter/exec/eval.ml +++ b/interpreter/exec/eval.ml @@ -57,15 +57,34 @@ and admin_instr' = | Label of int32 * instr list * code | Frame of int32 * frame * code -type config = +type thread = { frame : frame; code : code; budget : int; (* to model stack overflow *) } +type config = thread list +type thread_id = int +type status = Running | Result of value list | Trap of exn + let frame inst locals = {inst; locals} -let config inst vs es = {frame = frame inst []; code = vs, es; budget = 300} +let thread inst vs es = {frame = frame inst []; code = vs, es; budget = 300} +let empty_thread = thread empty_module_inst [] [] +let empty_config = [] +let spawn (c : config) = List.length c, c @ [empty_thread] + +let status (c : config) (n : thread_id) : status = + let t = List.nth c n in + match t.code with + | vs, [] -> Result (List.rev vs) + | [], {it = Trapping msg; at} :: _ -> Trap (Trap.Error (at, msg)) + | _ -> Running + +let clear (c : config) (n : thread_id) : config = + let ts1, t, ts2 = Lib.List.extract n c in + ts1 @ [{t with code = [], []}] @ ts2 + let plain e = Plain e.it @@ e.at @@ -122,11 +141,12 @@ let check_align addr ty sz at = * v : value * es : instr list * vs : value stack + * t : thread * c : config *) -let rec step (c : config) : config = - let {frame; code = vs, es; _} = c in +let rec step_thread (t : thread) : thread = + let {frame; code = vs, es; _} = t in let e = List.hd es in let vs', es' = match e.it, vs with @@ -355,7 +375,7 @@ let rec step (c : config) : config = ) | Trapping msg, vs -> - assert false + [], [Trapping msg @@ e.at] | Returning vs', vs -> Crash.error e.at "undefined frame" @@ -379,8 +399,8 @@ let rec step (c : config) : config = vs, [Breaking (Int32.sub k 1l, vs0) @@ at] | Label (n, es0, code'), vs -> - let c' = step {c with code = code'} in - vs, [Label (n, es0, c'.code) @@ e.at] + let t' = step_thread {t with code = code'} in + vs, [Label (n, es0, t'.code) @@ e.at] | Frame (n, frame', (vs', [])), vs -> vs' @ vs, [] @@ -392,10 +412,10 @@ let rec step (c : config) : config = take n vs0 e.at @ vs, [] | Frame (n, frame', code'), vs -> - let c' = step {frame = frame'; code = code'; budget = c.budget - 1} in - vs, [Frame (n, c'.frame, c'.code) @@ e.at] + let t' = step_thread {frame = frame'; code = code'; budget = t.budget - 1} in + vs, [Frame (n, t'.frame, t'.code) @@ e.at] - | Invoke func, vs when c.budget = 0 -> + | Invoke func, vs when t.budget = 0 -> Exhaustion.error e.at "call stack exhausted" | Invoke func, vs -> @@ -413,37 +433,44 @@ let rec step (c : config) : config = try List.rev (f (List.rev args)) @ vs', [] with Crash (_, msg) -> Crash.error e.at msg ) - in {c with code = vs', es' @ List.tl es} - + in {t with code = vs', es' @ List.tl es} -let rec eval (c : config) : value stack = - match c.code with - | vs, [] -> - vs - | vs, {it = Trapping msg; at} :: _ -> - Trap.error at msg +let rec step (c : config) (n : thread_id) : config = + let ts1, t, ts2 = Lib.List.extract n c in + if snd t.code = [] then + step c n + else + let t' = try step_thread t with Stack_overflow -> + Exhaustion.error (List.hd (snd t.code)).at "call stack exhausted" + in ts1 @ [t'] @ ts2 - | vs, es -> - eval (step c) +let rec eval (c : config ref) (n : thread_id) : value list = + match status !c n with + | Result vs -> vs + | Trap e -> raise e + | Running -> + let c' = step !c n in + c := c'; eval c n (* Functions & Constants *) -let invoke (func : func_inst) (vs : value list) : value list = +let invoke c n (func : func_inst) (vs : value list) : config = let at = match func with Func.AstFunc (_,_, f) -> f.at | _ -> no_region in let FuncType (ins, out) = Func.type_of func in if List.map Values.type_of vs <> ins then Crash.error at "wrong number or types of arguments"; - let c = config empty_module_inst (List.rev vs) [Invoke func @@ at] in - try List.rev (eval c) with Stack_overflow -> - Exhaustion.error at "call stack exhausted" + let ts1, t, ts2 = Lib.List.extract n c in + let vs', es' = t.code in + let code = List.rev vs @ vs', (Invoke func @@ at) :: es' in + ts1 @ [{t with code}] @ ts2 let eval_const (inst : module_inst) (const : const) : value = - let c = config inst [] (List.map plain const.it) in - match eval c with + let t = thread inst [] (List.map plain const.it) in + match eval (ref [t]) 0 with | [v] -> v - | vs -> Crash.error const.at "wrong number of results on stack" + | _ -> Crash.error const.at "wrong number of results on stack" let i32 (v : value) at = match v with @@ -518,7 +545,7 @@ let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) | ExternMemory mem -> {inst with memories = mem :: inst.memories} | ExternGlobal glob -> {inst with globals = glob :: inst.globals} -let init (m : module_) (exts : extern list) : module_inst = +let init c n (m : module_) (exts : extern list) : module_inst * config = let { imports; tables; memories; globals; funcs; types; exports; elems; data; start @@ -545,5 +572,5 @@ let init (m : module_) (exts : extern list) : module_inst = let init_datas = List.map (init_memory inst) data in List.iter (fun f -> f ()) init_elems; List.iter (fun f -> f ()) init_datas; - Lib.Option.app (fun x -> ignore (invoke (func inst x) [])) start; - inst + let c' = Lib.Option.fold c (fun x -> invoke c n (func inst x) []) start in + inst, c' diff --git a/interpreter/exec/eval.mli b/interpreter/exec/eval.mli index 825cc74f..59c929ab 100644 --- a/interpreter/exec/eval.mli +++ b/interpreter/exec/eval.mli @@ -1,10 +1,20 @@ open Values open Instance +type config +type thread_id +type status = Running | Result of value list | Trap of exn + exception Link of Source.region * string exception Trap of Source.region * string exception Crash of Source.region * string exception Exhaustion of Source.region * string -val init : Ast.module_ -> extern list -> module_inst (* raises Link, Trap *) -val invoke : func_inst -> value list -> value list (* raises Trap *) +val empty_config : config + +val spawn : config -> thread_id * config +val clear : config -> thread_id -> config +val status : config -> thread_id -> status +val step : config -> thread_id -> config +val invoke : config -> thread_id -> func_inst -> value list -> config (* raises Trap *) +val init : config -> thread_id -> Ast.module_ -> extern list -> module_inst * config (* raises Link, Trap *) diff --git a/interpreter/main/main.ml b/interpreter/main/main.ml index a445103a..f17e8918 100644 --- a/interpreter/main/main.ml +++ b/interpreter/main/main.ml @@ -42,13 +42,13 @@ let () = configure (); Arg.parse argspec (fun file -> add_arg ("(input " ^ quote file ^ ")")) usage; - let config = Run.config () in - List.iter (fun arg -> if not (Run.run_string config arg) then exit 1) !args; + let context = Run.context () in + List.iter (fun arg -> if not (Run.run_string context arg) then exit 1) !args; if !args = [] then Flags.interactive := true; if !Flags.interactive then begin Flags.print_sig := true; banner (); - Run.run_stdin config + Run.run_stdin context end with exn -> flush_all (); diff --git a/interpreter/runtime/instance.ml b/interpreter/runtime/instance.ml index 6ac58374..bfc74074 100644 --- a/interpreter/runtime/instance.ml +++ b/interpreter/runtime/instance.ml @@ -39,3 +39,10 @@ let extern_type_of = function let export inst name = try Some (List.assoc name inst.exports) with Not_found -> None + +let shared_export (_, ex) = shared_extern_type (extern_type_of ex) +let shared_module inst = + if List.for_all (fun ex -> shared_export ex = Shared) inst.exports then + Shared + else + Unshared diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index c19f4213..ac368167 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -163,6 +163,14 @@ function match_result(actual, expected) { }; } } + +function thread(f) { + // TODO: spawn thread and run f in it; return a handle for the thread +} + +function wait(t) { + // TODO: wait for thread t to terminate +} |} @@ -393,6 +401,7 @@ let of_action mods act = Some (of_wrapper mods x_opt name (get gt), [t]) | _ -> None ) + | Eval -> assert false let of_assertion' mods act name args wrapper_opt = let act_js, act_wrapper_opt = of_action mods act in @@ -447,10 +456,11 @@ let of_command mods cmd = | Thread (x_opt, cmds) -> (* TODO *) assert false - | Wait x -> + | Wait x_opt -> (* TODO *) assert false - | Meta _ -> assert false + | Meta _ + | Implicit _ -> assert false let of_script scr = (if !Flags.harness then harness else "") ^ diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 5dbb8a9d..df5c7975 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -276,39 +276,53 @@ let print_results rs = flush_all () -(* Configuration *) +(* Tasks & contexts *) module Map = Map.Make(String) -type task = Task of (task -> unit) list ref - -type config = - { quote : script ref; - scripts : script Map.t ref; - threads : task Map.t ref; - modules : Ast.module_ Map.t ref; - instances : Instance.module_inst Map.t ref; - registry : Instance.module_inst Map.t ref; - tasks : task list ref; - } - -let config () = +type task = +{ + context : context; + script : script ref; +} + +and context = +{ + quote : script ref; + tasks : task list ref; + scripts : script Map.t ref; + threads : task Map.t ref; + modules : Ast.module_ Map.t ref; + instances : Instance.module_inst Map.t ref; + registry : Instance.module_inst Map.t ref; + config : Eval.config ref; + thread : Eval.thread_id; +} + +let context_for config thread = { quote = ref []; + tasks = ref []; scripts = ref Map.empty; threads = ref Map.empty; modules = ref Map.empty; instances = ref Map.empty; registry = ref Map.empty; - tasks = ref []; + config; + thread; } +let context () = + let t, ec = Eval.spawn Eval.empty_config in + context_for (ref ec) t + let local c = - { (config ()) with + { c with + quote = ref []; scripts = ref !(c.scripts); threads = ref !(c.threads); modules = ref !(c.modules); instances = ref !(c.instances); - tasks = c.tasks; + registry = ref Map.empty; } let bind map x_opt y = @@ -349,27 +363,42 @@ let rec run_definition c def : Ast.module_ = let def' = Parse.string_to_module s in run_definition c def' -let run_action c act : Values.value list = +let run_action c act : Values.value list option = 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 c x_opt act.at in (match Instance.export inst name with | Some (Instance.ExternFunc f) -> - Eval.invoke f (List.map (fun v -> v.it) vs) + let vs = List.map (fun v -> v.it) args in + c.config := Eval.invoke !(c.config) c.thread f vs; + None | Some _ -> Assert.error act.at "export is not a function" | None -> Assert.error act.at "undefined export" ) - | Get (x_opt, name) -> + | Get (x_opt, name) -> trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); let inst = lookup_instance c x_opt act.at in (match Instance.export inst name with - | Some (Instance.ExternGlobal gl) -> [Global.load gl] + | Some (Instance.ExternGlobal gl) -> Some [Global.load gl] | Some _ -> Assert.error act.at "export is not a global" | None -> Assert.error act.at "undefined export" ) + | Eval -> + match Eval.status !(c.config) c.thread with + | Eval.Running -> + (try c.config := Eval.step !(c.config) c.thread + with exn -> c.config := Eval.clear !(c.config) c.thread; raise exn); + None + | Eval.Result vs -> + c.config := Eval.clear !(c.config) c.thread; + Some vs + | Eval.Trap exn -> + c.config := Eval.clear !(c.config) c.thread; + raise exn + let rec match_result at v r = let open Values in match r.it with @@ -408,14 +437,16 @@ let assert_message at name msg re = Assert.error at ("wrong " ^ name ^ " error") end -let run_assertion c ass = +let run_assertion c ass : assertion option = match ass.it with | AssertMalformed (def, re) -> trace "Asserting malformed..."; (match ignore (run_definition c def) with - | exception Decode.Code (_, msg) -> assert_message ass.at "decoding" msg re - | exception Parse.Syntax (_, msg) -> assert_message ass.at "parsing" msg re - | _ -> Assert.error ass.at "expected decoding/parsing error" + | exception Decode.Code (_, msg) -> + assert_message ass.at "decoding" msg re; None + | exception Parse.Syntax (_, msg) -> + assert_message ass.at "parsing" msg re; None + | () -> Assert.error ass.at "expected decoding/parsing error" ) | AssertInvalid (def, re) -> @@ -425,8 +456,8 @@ let run_assertion c ass = Valid.check_module m with | exception Valid.Invalid (_, msg) -> - assert_message ass.at "validation" msg re - | _ -> Assert.error ass.at "expected validation error" + assert_message ass.at "validation" msg re; None + | () -> Assert.error ass.at "expected validation error" ) | AssertUnlinkable (def, re) -> @@ -435,47 +466,47 @@ let run_assertion c ass = if not !Flags.unchecked then Valid.check_module m; (match let imports = Import.link m in - ignore (Eval.init m imports) + c.config := snd (Eval.init !(c.config) c.thread m imports) with | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> - assert_message ass.at "linking" msg re - | _ -> Assert.error ass.at "expected linking error" + assert_message ass.at "linking" msg re; None + | () -> Assert.error ass.at "expected linking error" ) | AssertUninstantiable (def, re) -> trace "Asserting trap..."; let m = run_definition c def in if not !Flags.unchecked then Valid.check_module m; - (match - let imports = Import.link m in - ignore (Eval.init m imports) - with - | exception Eval.Trap (_, msg) -> - assert_message ass.at "instantiation" msg re - | _ -> Assert.error ass.at "expected instantiation error" - ) + let imports = Import.link m in + c.config := snd (Eval.init !(c.config) c.thread m imports); + Some (AssertTrap (Eval @@ ass.at, re) @@ ass.at) | AssertReturn (act, rs) -> - trace ("Asserting return..."); - let got_vs = run_action c act in - assert_result ass.at got_vs rs + if act.it <> Eval then trace ("Asserting return..."); + (match run_action c act with + | None -> Some (AssertReturn (Eval @@ ass.at, rs) @@ ass.at) + | Some got_vs -> assert_result ass.at got_vs rs; None + ) | AssertTrap (act, re) -> - trace ("Asserting trap..."); + if act.it <> Eval then trace ("Asserting trap..."); (match run_action c act with - | exception Eval.Trap (_, msg) -> assert_message ass.at "runtime" msg re - | _ -> Assert.error ass.at "expected runtime error" + | None -> Some (AssertTrap (Eval @@ ass.at, re) @@ ass.at) + | exception Eval.Trap (_, msg) -> + assert_message ass.at "runtime" msg re; None + | Some _ -> Assert.error ass.at "expected runtime error" ) | AssertExhaustion (act, re) -> - trace ("Asserting exhaustion..."); + if act.it <> Eval then trace ("Asserting exhaustion..."); (match run_action c act with + | None -> Some (AssertExhaustion (Eval @@ ass.at, re) @@ ass.at) | exception Eval.Exhaustion (_, msg) -> - assert_message ass.at "exhaustion" msg re - | _ -> Assert.error ass.at "expected exhaustion error" + assert_message ass.at "exhaustion" msg re; None + | Some _ -> Assert.error ass.at "expected exhaustion error" ) -let rec run_command c cmd task = +let rec run_command c cmd : command list = match cmd.it with | Module (x_opt, def) -> c.quote := cmd :: !(c.quote); @@ -490,98 +521,115 @@ let rec run_command c cmd task = end; bind c.scripts x_opt [cmd]; bind c.modules x_opt m; - if not !Flags.dry then begin + if !Flags.dry then [] else begin trace "Initializing..."; let imports = Import.link m in - let inst = Eval.init m imports in - bind c.instances x_opt inst + let inst, config' = Eval.init !(c.config) c.thread m imports in + bind c.instances x_opt inst; + c.config := config'; + [Implicit (Action (Eval @@ cmd.at) @@ cmd.at) @@ cmd.at] end | Register (name, x_opt) -> c.quote := cmd :: !(c.quote); - if not !Flags.dry then begin + if !Flags.dry then [] else begin trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); let inst = lookup_instance c x_opt cmd.at in c.registry := Map.add (Utf8.encode name) inst !(c.registry); - Import.register name (lookup_registry c (Utf8.encode name)) + Import.register name (lookup_registry c (Utf8.encode name)); + [] end | Action act -> c.quote := cmd :: !(c.quote); - if not !Flags.dry then begin - let vs = run_action c act in - if vs <> [] then print_values vs + if !Flags.dry then [] else begin + match run_action c act with + | None -> [Implicit (Action (Eval @@ cmd.at) @@ cmd.at) @@ cmd.at] + | Some vs -> if vs <> [] then print_values vs; [] end | Assertion ass -> c.quote := cmd :: !(c.quote); - if not !Flags.dry then begin - run_assertion c ass + if !Flags.dry then [] else begin + match run_assertion c ass with + | None -> [] + | Some ass' -> [Implicit (Assertion ass' @@ cmd.at) @@ cmd.at] end | Thread (x_opt, cmds) -> - let task = Task (ref (List.map (run_command c) cmds)) in + c.quote := cmd :: !(c.quote); + let thread, config' = Eval.spawn !(c.config) in + let is_shared _ inst = Instance.shared_module inst = Types.Shared in + let instances = ref (Map.filter is_shared !(c.instances)) in + let task = {context = {(local c) with thread; instances}; script = ref cmds} in + c.config := config'; c.tasks := task :: !(c.tasks); - bind c.threads x_opt task + bind c.threads x_opt task; + [] | Wait x_opt -> - if lookup_thread c x_opt cmd.at <> Task (ref []) then begin - let Task steps = task in - steps := run_command c cmd :: !steps - end + c.quote := cmd :: !(c.quote); + let task = lookup_thread c x_opt cmd.at in + if !(task.script) = [] then + [] + else + [Implicit (Wait x_opt @@ cmd.at) @@ cmd.at] | Meta cmd -> - run_meta c cmd + List.map (fun m -> Implicit (Meta m @@ cmd.at) @@ cmd.at) (run_meta c cmd) -and run_meta c cmd = - match cmd.it with - | Script (x_opt, script) -> - run_quote_script c script; - bind c.scripts x_opt (lookup_script c None cmd.at) + | Implicit cmd -> + run_command {c with quote = ref []} cmd - | Input (x_opt, file) -> - (try if not (input_file file (run_quote_script c)) then - Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg); +and run_meta c cmd : meta list = + match cmd.it with + | Script (x_opt, [], quote) -> + bind c.scripts None (List.rev quote); + c.quote := quote @ !(c.quote); bind c.scripts x_opt (lookup_script c None cmd.at); if x_opt <> None then begin bind c.modules x_opt (lookup_module c None cmd.at); if not !Flags.dry then begin bind c.instances x_opt (lookup_instance c None cmd.at) end - end + end; + [] + + | Script (x_opt, cmd::cmds, quote) -> + let c' = {(local c) with quote = ref quote} in + let cmds' = run_command c cmd in + [Script (x_opt, cmds' @ cmds, !(c'.quote)) @@ cmd.at] + + | Input (x_opt, file) -> + let script = ref [] in + (try if not (input_file file ((:=) script)) then + Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg); + [Script (x_opt, !script, []) @@ cmd.at] | Output (x_opt, Some file) -> (try output_file file (fun () -> lookup_script c x_opt cmd.at) (fun () -> lookup_module c x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) + with Sys_error msg -> IO.error cmd.at msg); + [] | Output (x_opt, None) -> (try output_stdout (fun () -> lookup_module c x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) - -and run_step c = - let Task steps as task = - List.nth !(c.tasks) (Random.int (List.length !(c.tasks))) in - match !steps with - | [] -> run_step c - | step::steps' -> steps := steps'; step task + with Sys_error msg -> IO.error cmd.at msg); + [] -and run_script c script = - let task = Task (ref (List.map (run_command c) script)) in +let run_script c script = + let task = {context = c; script = ref script} in c.tasks := task :: !(c.tasks); - while task <> Task (ref []) do - run_step c + while !(task.script) <> [] do + let task' = List.nth !(c.tasks) (Random.int (List.length !(c.tasks))) in + match !(task'.script) with + | [] -> () + | cmd::cmds -> task'.script := run_command task'.context cmd @ cmds done -and run_quote_script c script = - let c' = local c in - run_script c' script; - bind c.scripts None (List.rev !(c'.quote)); - c.quote := !(c'.quote) @ !(c.quote) - let run_file c file = input_file file (run_script c) let run_string c string = input_string string (run_script c) let run_stdin c = input_stdin (run_script c) diff --git a/interpreter/script/run.mli b/interpreter/script/run.mli index 237d0c50..a612030f 100644 --- a/interpreter/script/run.mli +++ b/interpreter/script/run.mli @@ -1,4 +1,4 @@ -type config +type context exception Abort of Source.region * string exception Assert of Source.region * string @@ -6,8 +6,8 @@ exception IO of Source.region * string val trace : string -> unit -val config : unit -> config +val context : unit -> context -val run_string : config -> string -> bool -val run_file : config -> string -> bool -val run_stdin : config -> unit +val run_string : context -> string -> bool +val run_file : context -> string -> bool +val run_stdin : context -> unit diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index 5c397f02..5479ee7c 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -10,6 +10,7 @@ type action = action' Source.phrase and action' = | Invoke of var option * Ast.name * Ast.literal list | Get of var option * Ast.name + | Eval type nanop = nanop' Source.phrase and nanop' = (unit, unit, nan, nan) Values.op @@ -40,12 +41,13 @@ and command' = | Thread of var option * command list | Wait of var option | Meta of meta + | Implicit of command and meta = meta' Source.phrase and meta' = | Input of var option * string | Output of var option * string option - | Script of var option * script + | Script of var option * script * command list and script = command list diff --git a/interpreter/syntax/types.ml b/interpreter/syntax/types.ml index 4e1743ad..857c8874 100644 --- a/interpreter/syntax/types.ml +++ b/interpreter/syntax/types.ml @@ -32,6 +32,17 @@ let packed_size = function | Pack16 -> 2 | Pack32 -> 4 +let shared_func_type (FuncType _) = Unshared +let shared_table_type (TableType _) = Unshared +let shared_memory_type (MemoryType (_, shared)) = shared +let shared_global_type (GlobalType _) = Unshared + +let shared_extern_type = function + | ExternFuncType ft -> shared_func_type ft + | ExternTableType tt -> shared_table_type tt + | ExternMemoryType mt -> shared_memory_type mt + | ExternGlobalType gt -> shared_global_type gt + (* Subtyping *) diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index b750a2bc..04bf60f2 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -490,6 +490,8 @@ let action mode act = Node ("invoke" ^ access x_opt name, List.map (literal mode) lits) | Get (x_opt, name) -> Node ("get" ^ access x_opt name, []) + | Eval -> + Node ("eval", []) let nan = function | CanonicalNan -> "nan:canonical" @@ -534,8 +536,20 @@ let rec command mode cmd = | Action act -> [action mode act] | Assertion ass -> assertion mode ass | Thread (x_opt, cmds) -> - [Node ("thread " ^ var_opt x_opt, List.concat_map (command mode) cmds)] - | Wait x_opt -> [Node ("wait " ^ var_opt x_opt, [])] - | Meta _ -> assert false + [Node ("thread" ^ var_opt x_opt, List.concat_map (command mode) cmds)] + | Wait x_opt -> [Node ("wait" ^ var_opt x_opt, [])] + | Meta met -> [meta mode met] + | Implicit cmd' -> [Node ("implicit", command mode cmd')] + +and meta mode met = + match met.it with + | Input (x_opt, file) -> + Node ("input" ^ var_opt x_opt, [Atom (" \"" ^ file ^ "\"")]) + | Output (x_opt, Some file) -> + Node ("output" ^ var_opt x_opt, [Atom (" \"" ^ file ^ "\"")]) + | Output (x_opt, None) -> + Node ("output" ^ var_opt x_opt, []) + | Script (x_opt, _, _) -> + Node ("script" ^ var_opt x_opt, [Atom "..."]) let script mode scr = Lib.List.concat_map (command mode) scr diff --git a/interpreter/text/arrange.mli b/interpreter/text/arrange.mli index 051686a4..2b5f5a65 100644 --- a/interpreter/text/arrange.mli +++ b/interpreter/text/arrange.mli @@ -3,4 +3,5 @@ open Sexpr val instr : Ast.instr -> sexpr val func : Ast.func -> sexpr val module_ : Ast.module_ -> sexpr +val command : [`Textual | `Binary] -> Script.command -> sexpr list val script : [`Textual | `Binary] -> Script.script -> sexpr list diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index d1298f9c..6600af43 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -907,7 +907,7 @@ cmd_list : | cmd cmd_list { $1 :: $2 } meta : - | LPAR SCRIPT script_var_opt cmd_list RPAR { Script ($3, $4) @@ at () } + | LPAR SCRIPT script_var_opt cmd_list RPAR { Script ($3, $4, []) @@ at () } | LPAR INPUT script_var_opt STRING RPAR { Input ($3, $4) @@ at () } | LPAR OUTPUT script_var_opt STRING RPAR { Output ($3, Some $4) @@ at () } | LPAR OUTPUT script_var_opt RPAR { Output ($3, None) @@ at () } diff --git a/interpreter/text/print.ml b/interpreter/text/print.ml index 94961821..1182934a 100644 --- a/interpreter/text/print.ml +++ b/interpreter/text/print.ml @@ -1,5 +1,7 @@ let instr oc width e = Sexpr.output oc width (Arrange.instr e) let func oc width f = Sexpr.output oc width (Arrange.func f) let module_ oc width m = Sexpr.output oc width (Arrange.module_ m) +let command oc width mode s = + List.iter (Sexpr.output oc width) (Arrange.command mode s) let script oc width mode s = List.iter (Sexpr.output oc width) (Arrange.script mode s) diff --git a/interpreter/text/print.mli b/interpreter/text/print.mli index 861ae40d..d353355a 100644 --- a/interpreter/text/print.mli +++ b/interpreter/text/print.mli @@ -1,4 +1,5 @@ val instr : out_channel -> int -> Ast.instr -> unit val func : out_channel -> int -> Ast.func -> unit val module_ : out_channel -> int -> Ast.module_ -> unit +val command : out_channel -> int -> [`Textual | `Binary] -> Script.command -> unit val script : out_channel -> int -> [`Textual | `Binary] -> Script.script -> unit diff --git a/interpreter/util/lib.ml b/interpreter/util/lib.ml index eb6eff25..b2139f7e 100644 --- a/interpreter/util/lib.ml +++ b/interpreter/util/lib.ml @@ -76,6 +76,17 @@ struct | n, _::xs' when n > 0 -> drop (n - 1) xs' | _ -> failwith "drop" + let rec split n xs = + match n, xs with + | 0, _ -> [], xs + | n, x::xs' when n > 0 -> let ys, zs = split (n - 1) xs' in x::ys, zs + | _ -> failwith "split" + + let extract n xs = + match split n xs with + | ys, z::zs -> ys, z, zs + | _ -> failwith "extract" + let rec last = function | x::[] -> x | _::xs -> last xs @@ -137,6 +148,13 @@ struct | 0l, _ -> xs | n, _::xs' when n > 0l -> drop (Int32.sub n 1l) xs' | _ -> failwith "drop" + + let rec split n xs = + match n, xs with + | 0l, _ -> [], xs + | n, x::xs' when n > 0l -> + let ys, zs = split (Int32.sub n 1l) xs' in x::ys, zs + | _ -> failwith "split" end module Array32 = @@ -195,4 +213,8 @@ struct let app f = function | Some x -> f x | None -> () + + let fold x f = function + | Some y -> f y + | None -> x end diff --git a/interpreter/util/lib.mli b/interpreter/util/lib.mli index f9c91826..d3eb5285 100644 --- a/interpreter/util/lib.mli +++ b/interpreter/util/lib.mli @@ -14,6 +14,8 @@ sig val table : int -> (int -> 'a) -> 'a list val take : int -> 'a list -> 'a list (* raises Failure *) val drop : int -> 'a list -> 'a list (* raises Failure *) + val split : int -> 'a list -> 'a list * 'a list (* raises Failure *) + val extract : int -> 'a list -> 'a list * 'a * 'a list (* raises Failure *) val last : 'a list -> 'a (* raises Failure *) val split_last : 'a list -> 'a list * 'a (* raises Failure *) @@ -31,6 +33,7 @@ sig val nth : 'a list -> int32 -> 'a (* raises Failure *) val take : int32 -> 'a list -> 'a list (* raises Failure *) val drop : int32 -> 'a list -> 'a list (* raises Failure *) + val split : int32 -> 'a list -> 'a list * 'a list (* raises Failure *) end module Array32 : @@ -61,6 +64,7 @@ sig val get : 'a option -> 'a -> 'a val map : ('a -> 'b) -> 'a option -> 'b option val app : ('a -> unit) -> 'a option -> unit + val fold : 'b -> ('a -> 'b) -> 'a option -> 'b end module Int : diff --git a/test/core/thread.wast b/test/core/thread.wast new file mode 100644 index 00000000..9852e062 --- /dev/null +++ b/test/core/thread.wast @@ -0,0 +1,28 @@ +(module $Mem + (memory (export "shared") 1 1 shared) +) + +(thread $T1 + (register "mem" $Mem) + (module + (memory (import "mem" "shared") 1 10 shared) + (func (export "run") + (i32.store (i32.const 0) (i32.const 42)) + ) + ) + (invoke "run") +) + +(thread $T2 + (register "mem" $Mem) + (module + (memory (import "mem" "shared") 1 1 shared) + (func (export "run") (result i32) + (i32.load (i32.const 0)) + ) + ) + (assert_return (invoke "run") (oneof (i32.const 0) (i32.const 42))) +) + +(wait $T1) +(wait $T2) From e18f7a49a932a9cf6e59da6aa8a26f6d41d56856 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 26 Jul 2021 08:15:10 +0200 Subject: [PATCH 4/9] JS threading --- interpreter/script/js.ml | 96 +++++++++++++++++++++------------------ interpreter/script/run.ml | 35 +++++++------- 2 files changed, 69 insertions(+), 62 deletions(-) diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index ac368167..c702f1e1 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -179,34 +179,37 @@ function wait(t) { module NameMap = Map.Make(struct type t = Ast.name let compare = compare end) module Map = Map.Make(String) +type 'a defs = {mutable env : 'a Map.t; mutable current : int} type exports = extern_type NameMap.t -type modules = {mutable env : exports Map.t; mutable current : int} +type context = {modules : exports defs; threads : unit defs} let exports m : exports = List.fold_left (fun map exp -> NameMap.add exp.it.name (export_type m exp) map) NameMap.empty m.it.exports -let modules () : modules = {env = Map.empty; current = 0} +let defs () : 'a defs = {env = Map.empty; current = 0} +let context () : context = {modules = defs (); threads = defs ()} -let current_var (mods : modules) = "$" ^ string_of_int mods.current -let of_var_opt (mods : modules) = function - | None -> current_var mods +let current_var (defs : 'a defs) = "$" ^ string_of_int defs.current +let of_var_opt (defs : 'a defs) = function + | None -> current_var defs | 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; - 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")) - in try NameMap.find name exports with Not_found -> +let bind (defs : 'a defs) x_opt desc = + defs.current <- defs.current + 1; + defs.env <- Map.add (of_var_opt defs x_opt) desc defs.env; + if x_opt <> None then defs.env <- Map.add (current_var defs) desc defs.env + +let lookup (defs : 'a defs) x_opt at = + try Map.find (of_var_opt defs x_opt) defs.env with Not_found -> + raise (Eval.Crash (at, + if x_opt = None then "no definition within script" + else "unknown definition " ^ of_var_opt defs x_opt ^ " within script")) + +let lookup_export (mods : exports defs) x_opt name at = + let exports = lookup mods x_opt at in + try NameMap.find name exports with Not_found -> raise (Eval.Crash (at, "unknown export \"" ^ string_of_name name ^ "\" within module")) @@ -376,35 +379,35 @@ let rec of_definition def = 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 of_wrapper c x_opt name wrap_action wrap_assertion at = + let x = of_var_opt c.modules x_opt in let bs = wrap (Utf8.decode x) name wrap_action wrap_assertion at in "call(instance(" ^ of_bytes bs ^ ", " ^ "exports(" ^ of_string x ^ ", " ^ x ^ ")), " ^ " \"run\", [])" -let of_action mods act = +let of_action c act = match act.it with | Invoke (x_opt, name, lits) -> - "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^ + "call(" ^ of_var_opt c.modules x_opt ^ ", " ^ of_name name ^ ", " ^ "[" ^ String.concat ", " (List.map of_literal lits) ^ "])", - (match lookup mods x_opt name act.at with + (match lookup_export c.modules 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 lits), out) + Some (of_wrapper c x_opt name (invoke ft lits), out) | _ -> None ) | Get (x_opt, name) -> - "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")", - (match lookup mods x_opt name act.at with + "get(" ^ of_var_opt c.modules x_opt ^ ", " ^ of_name name ^ ")", + (match lookup_export c.modules 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]) + Some (of_wrapper c x_opt name (get gt), [t]) | _ -> None ) | Eval -> assert false -let of_assertion' mods act name args wrapper_opt = - let act_js, act_wrapper_opt = of_action mods act in +let of_assertion' c act name args wrapper_opt = + let act_js, act_wrapper_opt = of_action c act in let js = name ^ "(() => " ^ act_js ^ String.concat ", " ("" :: args) ^ ")" in match act_wrapper_opt with | None -> js ^ ";" @@ -415,7 +418,7 @@ let of_assertion' mods act name args wrapper_opt = | Some wrapper -> "run", wrapper in run_name ^ "(() => " ^ act_wrapper (wrapper out) act.at ^ "); // " ^ js -let of_assertion mods ass = +let of_assertion c ass = match ass.it with | AssertMalformed (def, _) -> "assert_malformed(" ^ of_definition def ^ ");" @@ -426,14 +429,14 @@ let of_assertion mods ass = | AssertUninstantiable (def, _) -> "assert_uninstantiable(" ^ of_definition def ^ ");" | AssertReturn (act, ress) -> - of_assertion' mods act "assert_return" (List.map of_result ress) + of_assertion' c act "assert_return" (List.map of_result ress) (Some (assert_return ress)) | AssertTrap (act, _) -> - of_assertion' mods act "assert_trap" [] None + of_assertion' c act "assert_trap" [] None | AssertExhaustion (act, _) -> - of_assertion' mods act "assert_exhaustion" [] None + of_assertion' c act "assert_exhaustion" [] None -let of_command mods cmd = +let rec of_command c cmd = "\n// " ^ Filename.basename cmd.at.left.file ^ ":" ^ string_of_int cmd.at.left.line ^ "\n" ^ match cmd.it with @@ -443,25 +446,28 @@ 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" ^ + in bind c.modules x_opt (exports (unquote def)); + "let " ^ current_var c.modules ^ + " = instance(" ^ of_definition def ^ ");\n" ^ (if x_opt = None then "" else - "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n") + "let " ^ of_var_opt c.modules x_opt ^ + " = " ^ current_var c.modules ^ ";\n") | Register (name, x_opt) -> - "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n" + "register(" ^ of_name name ^ ", " ^ of_var_opt c.modules x_opt ^ ");\n" | Action act -> - of_assertion' mods act "run" [] None ^ "\n" + of_assertion' c act "run" [] None ^ "\n" | Assertion ass -> - of_assertion mods ass ^ "\n" + of_assertion c ass ^ "\n" | Thread (x_opt, cmds) -> - (* TODO *) - assert false + "let " ^ current_var c.threads ^ + " = thread(function () {" ^ + String.concat "" (List.map (of_command c) cmds) ^ + "});\n" | Wait x_opt -> - (* TODO *) - assert false + "wait(" ^ of_var_opt c.threads x_opt ^ ");\n" | Meta _ | Implicit _ -> assert false let of_script scr = (if !Flags.harness then harness else "") ^ - String.concat "" (List.map (of_command (modules ())) scr) + String.concat "" (List.map (of_command (context ())) scr) diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index df5c7975..4afc3cbd 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -288,25 +288,23 @@ type task = and context = { - quote : script ref; - tasks : task list ref; scripts : script Map.t ref; threads : task Map.t ref; modules : Ast.module_ Map.t ref; instances : Instance.module_inst Map.t ref; registry : Instance.module_inst Map.t ref; + tasks : task list ref; config : Eval.config ref; thread : Eval.thread_id; } let context_for config thread = - { quote = ref []; - tasks = ref []; - scripts = ref Map.empty; + { scripts = ref Map.empty; threads = ref Map.empty; modules = ref Map.empty; instances = ref Map.empty; registry = ref Map.empty; + tasks = ref []; config; thread; } @@ -317,7 +315,6 @@ let context () = let local c = { c with - quote = ref []; scripts = ref !(c.scripts); threads = ref !(c.threads); modules = ref !(c.modules); @@ -509,7 +506,6 @@ let run_assertion c ass : assertion option = let rec run_command c cmd : command list = match cmd.it with | Module (x_opt, def) -> - c.quote := cmd :: !(c.quote); let m = run_definition c def in if not !Flags.unchecked then begin trace "Checking..."; @@ -531,7 +527,6 @@ let rec run_command c cmd : command list = end | Register (name, x_opt) -> - c.quote := cmd :: !(c.quote); if !Flags.dry then [] else begin trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); let inst = lookup_instance c x_opt cmd.at in @@ -541,7 +536,6 @@ let rec run_command c cmd : command list = end | Action act -> - c.quote := cmd :: !(c.quote); if !Flags.dry then [] else begin match run_action c act with | None -> [Implicit (Action (Eval @@ cmd.at) @@ cmd.at) @@ cmd.at] @@ -549,7 +543,6 @@ let rec run_command c cmd : command list = end | Assertion ass -> - c.quote := cmd :: !(c.quote); if !Flags.dry then [] else begin match run_assertion c ass with | None -> [] @@ -557,7 +550,6 @@ let rec run_command c cmd : command list = end | Thread (x_opt, cmds) -> - c.quote := cmd :: !(c.quote); let thread, config' = Eval.spawn !(c.config) in let is_shared _ inst = Instance.shared_module inst = Types.Shared in let instances = ref (Map.filter is_shared !(c.instances)) in @@ -568,7 +560,6 @@ let rec run_command c cmd : command list = [] | Wait x_opt -> - c.quote := cmd :: !(c.quote); let task = lookup_thread c x_opt cmd.at in if !(task.script) = [] then [] @@ -576,16 +567,15 @@ let rec run_command c cmd : command list = [Implicit (Wait x_opt @@ cmd.at) @@ cmd.at] | Meta cmd -> - List.map (fun m -> Implicit (Meta m @@ cmd.at) @@ cmd.at) (run_meta c cmd) + List.map (fun m -> Meta m @@ cmd.at) (run_meta c cmd) | Implicit cmd -> - run_command {c with quote = ref []} cmd + run_command c cmd and run_meta c cmd : meta list = match cmd.it with | Script (x_opt, [], quote) -> bind c.scripts None (List.rev quote); - c.quote := quote @ !(c.quote); bind c.scripts x_opt (lookup_script c None cmd.at); if x_opt <> None then begin bind c.modules x_opt (lookup_module c None cmd.at); @@ -596,9 +586,9 @@ and run_meta c cmd : meta list = [] | Script (x_opt, cmd::cmds, quote) -> - let c' = {(local c) with quote = ref quote} in let cmds' = run_command c cmd in - [Script (x_opt, cmds' @ cmds, !(c'.quote)) @@ cmd.at] + let quote' = quote_command cmd in + [Script (x_opt, cmds' @ cmds, quote' @ quote) @@ cmd.at] | Input (x_opt, file) -> let script = ref [] in @@ -620,6 +610,17 @@ and run_meta c cmd : meta list = with Sys_error msg -> IO.error cmd.at msg); [] +and quote_command cmd : command list = + match cmd.it with + | Module _ | Register _ | Action _ | Assertion _ | Thread _ | Wait _ -> [cmd] + | Meta meta -> quote_meta meta + | Implicit _ -> [] + +and quote_meta cmd : command list = + match cmd.it with + | Script (_, [], quote) -> quote + | Script _ | Input _ | Output _ -> [] + let run_script c script = let task = {context = c; script = ref script} in c.tasks := task :: !(c.tasks); From 3bb2449b8f816370668ff439fbde75cea0899c84 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 26 Jul 2021 08:30:32 +0200 Subject: [PATCH 5/9] JS either --- interpreter/README.md | 2 +- interpreter/script/js.ml | 18 +++++++++++++----- interpreter/script/run.ml | 6 +++--- interpreter/script/script.ml | 2 +- interpreter/text/arrange.ml | 2 +- interpreter/text/lexer.mll | 2 +- interpreter/text/parser.mly | 8 ++------ test/core/thread.wast | 2 +- 8 files changed, 23 insertions(+), 19 deletions(-) diff --git a/interpreter/README.md b/interpreter/README.md index 257b903c..f74cf4fa 100644 --- a/interpreter/README.md +++ b/interpreter/README.md @@ -397,7 +397,7 @@ assertion: result: ( .const ) ;; numeric result - ( oneof result* ) ;; non-deterministic result + ( either result+ ) ;; non-deterministic result numpat: ;; literal result diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index c702f1e1..a1739235 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -251,7 +251,7 @@ let run ts at = [], [] let assert_return ress ts at = - let test res = + let rec test res = match res.it with | LitResult lit -> let t', reinterpret = reinterpret_of (Values.type_of lit.it) in @@ -281,9 +281,17 @@ let assert_return ress ts at = Compare (eq_of t') @@ at; Test (Values.I32 I32Op.Eqz) @@ at; BrIf (0l @@ at) @@ at ] - | OneofResult ress -> - (* TODO *) - assert false + | EitherResult ress -> + [ Block (ValBlockType None, + List.map (fun res -> + Block (ValBlockType None, + test res @ + [Br (1l @@ res.at) @@ res.at] + ) @@ res.at + ) ress @ + [Br (1l @@ at) @@ at] + ) @@ at + ] in [], List.flatten (List.rev_map test ress) let wrap module_name item_name wrap_action wrap_assertion at = @@ -368,7 +376,7 @@ let rec of_result res = | Values.I32 _ | Values.I64 _ -> assert false | Values.F32 n | Values.F64 n -> of_nan n ) - | OneofResult ress -> + | EitherResult ress -> "[" ^ String.concat ", " (List.map of_result ress) ^ "]" let rec of_definition def = diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 4afc3cbd..64d5a268 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -252,7 +252,7 @@ let rec type_of_result r = match r.it with | LitResult v -> Values.type_of v.it | NanResult n -> Values.type_of n.it - | OneofResult rs -> type_of_result (List.hd rs) + | EitherResult rs -> type_of_result (List.hd rs) let rec string_of_result r = match r.it with @@ -262,7 +262,7 @@ let rec string_of_result r = | Values.I32 _ | Values.I64 _ -> assert false | Values.F32 n | Values.F64 n -> string_of_nan n ) - | OneofResult rs -> + | EitherResult rs -> "(" ^ String.concat " | " (List.map string_of_result rs) ^ ")" let string_of_results = function @@ -412,7 +412,7 @@ let rec match_result at v r = Int64.logand (F64.to_bits z) pos_nan = pos_nan | _, _ -> false ) - | OneofResult rs -> List.exists (match_result at v) rs + | EitherResult rs -> List.exists (match_result at v) rs let assert_result at got expect = if diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index 5479ee7c..0be07441 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -20,7 +20,7 @@ type result = result' Source.phrase and result' = | LitResult of Ast.literal | NanResult of nanop - | OneofResult of result list + | EitherResult of result list type assertion = assertion' Source.phrase and assertion' = diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index 04bf60f2..edb1e96f 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -506,7 +506,7 @@ let rec result mode res = | Values.F32 n -> Node ("f32.const " ^ nan n, []) | Values.F64 n -> Node ("f64.const " ^ nan n, []) ) - | OneofResult ress -> Node ("oneof", List.map (result mode) ress) + | EitherResult ress -> Node ("either", List.map (result mode) ress) let assertion mode ass = match ass.it with diff --git a/interpreter/text/lexer.mll b/interpreter/text/lexer.mll index e2d1cb92..4be7049c 100644 --- a/interpreter/text/lexer.mll +++ b/interpreter/text/lexer.mll @@ -451,7 +451,7 @@ rule token = parse | "assert_exhaustion" { ASSERT_EXHAUSTION } | "nan:canonical" { NAN Script.CanonicalNan } | "nan:arithmetic" { NAN Script.ArithmeticNan } - | "oneof" { ONEOF } + | "either" { EITHER } | "input" { INPUT } | "output" { OUTPUT } diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index 6600af43..ff65a99e 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -179,7 +179,7 @@ let inline_type_explicit (c : context) x ft at = %token SCRIPT REGISTER THREAD WAIT INVOKE GET %token ASSERT_MALFORMED ASSERT_INVALID ASSERT_SOFT_INVALID ASSERT_UNLINKABLE %token ASSERT_RETURN ASSERT_TRAP ASSERT_EXHAUSTION -%token NAN ONEOF +%token NAN EITHER %token INPUT OUTPUT %token EOF @@ -889,10 +889,6 @@ assertion : | LPAR ASSERT_TRAP action STRING RPAR { AssertTrap ($3, $4) @@ at () } | LPAR ASSERT_EXHAUSTION action STRING RPAR { AssertExhaustion ($3, $4) @@ at () } -assertion_list : - | /* empty */ { [] } - | assertion assertion_list { $1 :: $2 } - cmd : | action { Action $1 @@ at () } | assertion { Assertion $1 @@ at () } @@ -922,7 +918,7 @@ const_list : result : | const { LitResult $1 @@ at () } | LPAR CONST NAN RPAR { NanResult (nanop $2 ($3 @@ ati 3)) @@ at () } - | LPAR ONEOF result result_list RPAR { OneofResult ($3 :: $4) @@ at () } + | LPAR EITHER result result_list RPAR { EitherResult ($3 :: $4) @@ at () } result_list : | /* empty */ { [] } diff --git a/test/core/thread.wast b/test/core/thread.wast index 9852e062..cf295fc3 100644 --- a/test/core/thread.wast +++ b/test/core/thread.wast @@ -21,7 +21,7 @@ (i32.load (i32.const 0)) ) ) - (assert_return (invoke "run") (oneof (i32.const 0) (i32.const 42))) + (assert_return (invoke "run") (either (i32.const 0) (i32.const 42))) ) (wait $T1) From 03748a81d870e8ca4677230e2a37a09118bc5ac6 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 26 Jul 2021 09:06:23 +0200 Subject: [PATCH 6/9] Explicit sharing --- interpreter/README.md | 5 ++++- interpreter/script/js.ml | 10 ++++++---- interpreter/script/run.ml | 23 ++++++++++++----------- interpreter/script/script.ml | 2 +- interpreter/text/arrange.ml | 7 +++++-- interpreter/text/parser.mly | 13 ++++++++----- test/core/thread.wast | 4 ++-- 7 files changed, 38 insertions(+), 26 deletions(-) diff --git a/interpreter/README.md b/interpreter/README.md index f74cf4fa..9c5a154f 100644 --- a/interpreter/README.md +++ b/interpreter/README.md @@ -374,11 +374,14 @@ binscript: * cmd: ;; define, validate, and initialize module ( register ? ) ;; register module for imports - ( thread ? cmd* ) ;; spawn thread + ( thread ? * cmd* ) ;; spawn thread ( wait ) ;; join thread ;; perform action and print results ;; assert result of an action +shared: + ( shared ( module ) ) + module: ( module ? binary * ) ;; module in binary format (may be malformed) diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index a1739235..759e18d3 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -164,8 +164,8 @@ function match_result(actual, expected) { } } -function thread(f) { - // TODO: spawn thread and run f in it; return a handle for the thread +function thread(shared, f) { + // TODO: spawn thread, share instances, and run f in it; return a handle for the thread } function wait(t) { @@ -466,9 +466,11 @@ let rec of_command c cmd = of_assertion' c act "run" [] None ^ "\n" | Assertion ass -> of_assertion c ass ^ "\n" - | Thread (x_opt, cmds) -> + | Thread (x_opt, xs, cmds) -> "let " ^ current_var c.threads ^ - " = thread(function () {" ^ + " = thread([" ^ + String.concat ", " (List.map (fun x -> "\"" ^ x.it ^ "\"") xs) ^ + "], function () {" ^ String.concat "" (List.map (of_command c) cmds) ^ "});\n" | Wait x_opt -> diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 64d5a268..f169aff9 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -314,13 +314,7 @@ let context () = context_for (ref ec) t let local c = - { c with - scripts = ref !(c.scripts); - threads = ref !(c.threads); - modules = ref !(c.modules); - instances = ref !(c.instances); - registry = ref Map.empty; - } + {(context_for c.config c.thread) with tasks = c.tasks} let bind map x_opt y = let map' = @@ -549,11 +543,18 @@ let rec run_command c cmd : command list = | Some ass' -> [Implicit (Assertion ass' @@ cmd.at) @@ cmd.at] end - | Thread (x_opt, cmds) -> + | Thread (x_opt, xs, cmds) -> let thread, config' = Eval.spawn !(c.config) in - let is_shared _ inst = Instance.shared_module inst = Types.Shared in - let instances = ref (Map.filter is_shared !(c.instances)) in - let task = {context = {(local c) with thread; instances}; script = ref cmds} in + let task = {context = {(local c) with thread}; script = ref cmds} in + List.iter (fun x -> + if not !Flags.dry then begin + let inst = lookup_instance c (Some x) x.at in + if Instance.shared_module inst <> Types.Shared then + IO.error x.at ("module " ^ x.it ^ " is not sharable"); + bind task.context.instances (Some x) inst + end; + bind task.context.modules (Some x) (lookup_module c (Some x) cmd.at) + ) xs; c.config := config'; c.tasks := task :: !(c.tasks); bind c.threads x_opt task; diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index 0be07441..497ee942 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -38,7 +38,7 @@ and command' = | Register of Ast.name * var option | Action of action | Assertion of assertion - | Thread of var option * command list + | Thread of var option * var list * command list | Wait of var option | Meta of meta | Implicit of command diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index edb1e96f..da31ca32 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -535,8 +535,11 @@ let rec command mode cmd = | Register (n, x_opt) -> [Node ("register " ^ name n ^ var_opt x_opt, [])] | Action act -> [action mode act] | Assertion ass -> assertion mode ass - | Thread (x_opt, cmds) -> - [Node ("thread" ^ var_opt x_opt, List.concat_map (command mode) cmds)] + | Thread (x_opt, xs, cmds) -> + [Node ("thread" ^ var_opt x_opt, + List.map (fun x -> Node ("shared", [Node ("module " ^ x.it, [])])) xs @ + List.concat_map (command mode) cmds) + ] | Wait x_opt -> [Node ("wait" ^ var_opt x_opt, [])] | Meta met -> [meta mode met] | Implicit cmd' -> [Node ("implicit", command mode cmd')] diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index ff65a99e..5722d498 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -854,10 +854,7 @@ inline_module1 : /* Sugar */ thread_var_opt : | /* empty */ { None } - | thread_var { Some $1 } - -thread_var : - | VAR { $1 @@ at () } + | VAR { Some ($1 @@ at ()) } script_var_opt : | /* empty */ { None } @@ -894,7 +891,8 @@ cmd : | assertion { Assertion $1 @@ at () } | script_module { Module (fst $1, snd $1) @@ at () } | LPAR REGISTER name module_var_opt RPAR { Register ($3, $4) @@ at () } - | LPAR THREAD thread_var_opt cmd_list RPAR { Thread ($3, $4) @@ at () } + | LPAR THREAD thread_var_opt shared_cmd_list RPAR + { let xs, cs = $4 in Thread ($3, xs, cs) @@ at () } | LPAR WAIT thread_var_opt RPAR { Wait $3 @@ at () } | meta { Meta $1 @@ at () } @@ -902,6 +900,11 @@ cmd_list : | /* empty */ { [] } | cmd cmd_list { $1 :: $2 } +shared_cmd_list : + | cmd_list { [], $1 } + | LPAR SHARED LPAR MODULE VAR RPAR RPAR shared_cmd_list + { let xs, cs = $8 in ($5 @@ ati 5) :: xs, cs } + meta : | LPAR SCRIPT script_var_opt cmd_list RPAR { Script ($3, $4, []) @@ at () } | LPAR INPUT script_var_opt STRING RPAR { Input ($3, $4) @@ at () } diff --git a/test/core/thread.wast b/test/core/thread.wast index cf295fc3..c3456a61 100644 --- a/test/core/thread.wast +++ b/test/core/thread.wast @@ -2,7 +2,7 @@ (memory (export "shared") 1 1 shared) ) -(thread $T1 +(thread $T1 (shared (module $Mem)) (register "mem" $Mem) (module (memory (import "mem" "shared") 1 10 shared) @@ -13,7 +13,7 @@ (invoke "run") ) -(thread $T2 +(thread $T2 (shared (module $Mem)) (register "mem" $Mem) (module (memory (import "mem" "shared") 1 1 shared) From 11ee26d335b2ebe531df1d3d77c97c4e6a99f434 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 26 Jul 2021 09:22:44 +0200 Subject: [PATCH 7/9] Simplify script hack --- interpreter/script/run.ml | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index f169aff9..6e7031f7 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -576,14 +576,7 @@ let rec run_command c cmd : command list = and run_meta c cmd : meta list = match cmd.it with | Script (x_opt, [], quote) -> - bind c.scripts None (List.rev quote); - bind c.scripts x_opt (lookup_script c None cmd.at); - if x_opt <> None then begin - bind c.modules x_opt (lookup_module c None cmd.at); - if not !Flags.dry then begin - bind c.instances x_opt (lookup_instance c None cmd.at) - end - end; + bind c.scripts x_opt (List.rev quote); [] | Script (x_opt, cmd::cmds, quote) -> @@ -596,6 +589,10 @@ and run_meta c cmd : meta list = (try if not (input_file file ((:=) script)) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg); + (match !script with + | [{it = Module (None, def); at}] -> script := [Module (x_opt, def) @@ at] + | _ -> () + ); [Script (x_opt, !script, []) @@ cmd.at] | Output (x_opt, Some file) -> From 1fdcd848a3384786c309d2e7e96f36fc4b9c1fca Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 26 Jul 2021 09:36:09 +0200 Subject: [PATCH 8/9] Remove Implicit --- interpreter/script/js.ml | 3 +-- interpreter/script/run.ml | 27 +++++++++++++-------------- interpreter/script/script.ml | 3 +-- interpreter/text/arrange.ml | 3 +-- interpreter/text/parser.mly | 2 +- 5 files changed, 17 insertions(+), 21 deletions(-) diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index 759e18d3..9bc2b3a3 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -475,8 +475,7 @@ let rec of_command c cmd = "});\n" | Wait x_opt -> "wait(" ^ of_var_opt c.threads x_opt ^ ");\n" - | Meta _ - | Implicit _ -> assert false + | Meta _ -> assert false let of_script scr = (if !Flags.harness then harness else "") ^ diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 6e7031f7..bf321fa3 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -517,7 +517,7 @@ let rec run_command c cmd : command list = let inst, config' = Eval.init !(c.config) c.thread m imports in bind c.instances x_opt inst; c.config := config'; - [Implicit (Action (Eval @@ cmd.at) @@ cmd.at) @@ cmd.at] + [Action (Eval @@ cmd.at) @@ cmd.at] end | Register (name, x_opt) -> @@ -532,7 +532,7 @@ let rec run_command c cmd : command list = | Action act -> if !Flags.dry then [] else begin match run_action c act with - | None -> [Implicit (Action (Eval @@ cmd.at) @@ cmd.at) @@ cmd.at] + | None -> [Action (Eval @@ cmd.at) @@ cmd.at] | Some vs -> if vs <> [] then print_values vs; [] end @@ -540,7 +540,7 @@ let rec run_command c cmd : command list = if !Flags.dry then [] else begin match run_assertion c ass with | None -> [] - | Some ass' -> [Implicit (Assertion ass' @@ cmd.at) @@ cmd.at] + | Some ass' -> [Assertion ass' @@ cmd.at] end | Thread (x_opt, xs, cmds) -> @@ -565,24 +565,24 @@ let rec run_command c cmd : command list = if !(task.script) = [] then [] else - [Implicit (Wait x_opt @@ cmd.at) @@ cmd.at] + [Wait x_opt @@ cmd.at] | Meta cmd -> List.map (fun m -> Meta m @@ cmd.at) (run_meta c cmd) - | Implicit cmd -> - run_command c cmd - and run_meta c cmd : meta list = match cmd.it with - | Script (x_opt, [], quote) -> + | Script (x_opt, [], [], quote) -> bind c.scripts x_opt (List.rev quote); [] - | Script (x_opt, cmd::cmds, quote) -> - let cmds' = run_command c cmd in + | Script (x_opt, [], cmd::cmds, quote) -> let quote' = quote_command cmd in - [Script (x_opt, cmds' @ cmds, quote' @ quote) @@ cmd.at] + [Script (x_opt, [cmd], cmds, quote' @ quote) @@ cmd.at] + + | Script (x_opt, cmd::cmds1, cmds2, quote) -> + let cmds' = run_command c cmd in + [Script (x_opt, cmds' @ cmds1, cmds2, quote) @@ cmd.at] | Input (x_opt, file) -> let script = ref [] in @@ -593,7 +593,7 @@ and run_meta c cmd : meta list = | [{it = Module (None, def); at}] -> script := [Module (x_opt, def) @@ at] | _ -> () ); - [Script (x_opt, !script, []) @@ cmd.at] + [Script (x_opt, [], !script, []) @@ cmd.at] | Output (x_opt, Some file) -> (try @@ -612,11 +612,10 @@ and quote_command cmd : command list = match cmd.it with | Module _ | Register _ | Action _ | Assertion _ | Thread _ | Wait _ -> [cmd] | Meta meta -> quote_meta meta - | Implicit _ -> [] and quote_meta cmd : command list = match cmd.it with - | Script (_, [], quote) -> quote + | Script (_, [], [], quote) -> quote | Script _ | Input _ | Output _ -> [] let run_script c script = diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index 497ee942..f215f495 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -41,13 +41,12 @@ and command' = | Thread of var option * var list * command list | Wait of var option | Meta of meta - | Implicit of command and meta = meta' Source.phrase and meta' = | Input of var option * string | Output of var option * string option - | Script of var option * script * command list + | Script of var option * script * script * command list and script = command list diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index da31ca32..ad115e70 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -542,7 +542,6 @@ let rec command mode cmd = ] | Wait x_opt -> [Node ("wait" ^ var_opt x_opt, [])] | Meta met -> [meta mode met] - | Implicit cmd' -> [Node ("implicit", command mode cmd')] and meta mode met = match met.it with @@ -552,7 +551,7 @@ and meta mode met = Node ("output" ^ var_opt x_opt, [Atom (" \"" ^ file ^ "\"")]) | Output (x_opt, None) -> Node ("output" ^ var_opt x_opt, []) - | Script (x_opt, _, _) -> + | Script (x_opt, _, _, _) -> Node ("script" ^ var_opt x_opt, [Atom "..."]) let script mode scr = Lib.List.concat_map (command mode) scr diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index 5722d498..6bc5cf2a 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -906,7 +906,7 @@ shared_cmd_list : { let xs, cs = $8 in ($5 @@ ati 5) :: xs, cs } meta : - | LPAR SCRIPT script_var_opt cmd_list RPAR { Script ($3, $4, []) @@ at () } + | LPAR SCRIPT script_var_opt cmd_list RPAR { Script ($3, [], $4, []) @@ at () } | LPAR INPUT script_var_opt STRING RPAR { Input ($3, $4) @@ at () } | LPAR OUTPUT script_var_opt STRING RPAR { Output ($3, Some $4) @@ at () } | LPAR OUTPUT script_var_opt RPAR { Output ($3, None) @@ at () } From 45fa5e5e9776204babb16f31f02426ee4c5974b7 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Thu, 5 Aug 2021 21:23:09 +0200 Subject: [PATCH 9/9] Comments --- interpreter/script/run.ml | 18 ++++++++++++++---- interpreter/script/script.ml | 7 ++++++- interpreter/text/arrange.ml | 2 +- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index bf321fa3..eb42d5d3 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -250,9 +250,11 @@ let string_of_nan = function let rec type_of_result r = match r.it with - | LitResult v -> Values.type_of v.it - | NanResult n -> Values.type_of n.it - | EitherResult rs -> type_of_result (List.hd rs) + | LitResult v -> Some (Values.type_of v.it) + | NanResult n -> Some (Values.type_of n.it) + | EitherResult rs -> + let ts = List.map type_of_result rs in + List.fold_left (fun t1 t2 -> if t1 = t2 then t1 else None) (List.hd ts) ts let rec string_of_result r = match r.it with @@ -269,10 +271,18 @@ let string_of_results = function | [r] -> string_of_result r | rs -> "[" ^ String.concat " " (List.map string_of_result rs) ^ "]" +let string_of_value_type_opt = function + | Some t -> Types.string_of_value_type t + | None -> "?" + +let string_of_value_type_opts = function + | [t] -> string_of_value_type_opt t + | ts -> "[" ^ String.concat " " (List.map string_of_value_type_opt ts) ^ "]" + let print_results rs = let ts = List.map type_of_result rs in Printf.printf "%s : %s\n" - (string_of_results rs) (Types.string_of_value_types ts); + (string_of_results rs) (string_of_value_type_opts ts); flush_all () diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml index f215f495..5c73fc05 100644 --- a/interpreter/script/script.ml +++ b/interpreter/script/script.ml @@ -46,7 +46,12 @@ and meta = meta' Source.phrase and meta' = | Input of var option * string | Output of var option * string option - | Script of var option * script * script * command list + | Script of var option * (* s1 : *) script * (* s2 : *) script * (* q : *) script + (* s1 @ s2 is remaining script to run + * q is script quote of original commands with inputs expanded (reversed) + * s1 contains reduced commands that must not be quoted + * s2 contains original commands that still need quoting + *) and script = command list diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index ad115e70..aa727a8f 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -538,7 +538,7 @@ let rec command mode cmd = | Thread (x_opt, xs, cmds) -> [Node ("thread" ^ var_opt x_opt, List.map (fun x -> Node ("shared", [Node ("module " ^ x.it, [])])) xs @ - List.concat_map (command mode) cmds) + Lib.List.concat_map (command mode) cmds) ] | Wait x_opt -> [Node ("wait" ^ var_opt x_opt, [])] | Meta met -> [meta mode met]