From da60f10ce0c4009e72a1bdd4a862b7072bfa8c64 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 19 Nov 2025 22:25:38 +0100 Subject: [PATCH 1/4] Abstract script runner over engine --- interpreter/exec/eval.ml | 10 +- interpreter/exec/eval.mli | 6 +- interpreter/host/env.ml | 6 +- interpreter/host/spectest.ml | 12 +- interpreter/main/main.ml | 4 +- interpreter/runtime/exn.ml | 3 +- interpreter/runtime/exn.mli | 3 +- interpreter/runtime/instance.ml | 4 +- interpreter/script/engine.ml | 56 +++ interpreter/script/import.ml | 21 - interpreter/script/import.mli | 8 - interpreter/script/run.ml | 696 +++----------------------------- interpreter/script/run.mli | 14 - interpreter/script/runner.ml | 678 +++++++++++++++++++++++++++++++ interpreter/script/runner.mli | 17 + 15 files changed, 836 insertions(+), 702 deletions(-) create mode 100644 interpreter/script/engine.ml delete mode 100644 interpreter/script/import.ml delete mode 100644 interpreter/script/import.mli delete mode 100644 interpreter/script/run.mli create mode 100644 interpreter/script/runner.ml create mode 100644 interpreter/script/runner.mli diff --git a/interpreter/exec/eval.ml b/interpreter/exec/eval.ml index dc36be500e..b5ea0e9398 100644 --- a/interpreter/exec/eval.ml +++ b/interpreter/exec/eval.ml @@ -9,16 +9,15 @@ open Instance (* Errors *) module Link = Error.Make () -module Exception = Error.Make () module Trap = Error.Make () module Crash = Error.Make () module Exhaustion = Error.Make () exception Link = Link.Error -exception Exception = Exception.Error exception Trap = Trap.Error exception Crash = Crash.Error (* failure that cannot happen in valid code *) exception Exhaustion = Exhaustion.Error +exception Exception of region * Exn.t let table_error at = function | Table.Bounds -> "out of bounds table access" @@ -1146,8 +1145,7 @@ let rec eval (c : config) : value stack = Trap.error at msg | vs, {it = Throwing (a, args); at} :: _ -> - let msg = "uncaught exception with args (" ^ string_of_values args ^ ")" in - Exception.error at msg + raise (Exception (at, Exn.Exn (a, args))) | vs, es -> eval (step c) @@ -1183,7 +1181,7 @@ let init_type (inst : moduleinst) (type_ : type_) : moduleinst = let x = Lib.List32.length inst.types in {inst with types = inst.types @ roll_deftypes x rt} -let init_import (inst : moduleinst) (ex : extern) (im : import) : moduleinst = +let init_import (inst : moduleinst) (ex : externinst) (im : import) : moduleinst = let Import (module_name, item_name, xt) = im.it in let xt = subst_externtype (subst_of inst) xt in let xt' = externtype_of inst.types ex in @@ -1305,7 +1303,7 @@ let init_list f xs (inst : moduleinst) : moduleinst = let init_list2 f xs ys (inst : moduleinst) : moduleinst = List.fold_left2 f inst xs ys -let init (m : module_) (exts : extern list) : moduleinst = +let init (m : module_) (exts : externinst list) : moduleinst = if List.length exts <> List.length m.it.imports then Link.error m.at "wrong number of imports provided for initialisation"; let inst = diff --git a/interpreter/exec/eval.mli b/interpreter/exec/eval.mli index 39b708bf7e..033f5c5e26 100644 --- a/interpreter/exec/eval.mli +++ b/interpreter/exec/eval.mli @@ -3,9 +3,9 @@ open Instance exception Link of Source.region * string exception Trap of Source.region * string -exception Exception of Source.region * string exception Crash of Source.region * string exception Exhaustion of Source.region * string +exception Exception of Source.region * Exn.t -val init : Ast.module_ -> extern list -> moduleinst (* raises Link, Trap *) -val invoke : funcinst -> value list -> value list (* raises Trap *) +val init : Ast.module_ -> externinst list -> moduleinst (* raises Link, Trap, Exception *) +val invoke : funcinst -> value list -> value list (* raises Trap, Exception *) diff --git a/interpreter/host/env.ml b/interpreter/host/env.ml index 2f92ca3487..0688131a61 100644 --- a/interpreter/host/env.ml +++ b/interpreter/host/env.ml @@ -43,7 +43,7 @@ let exit vs = let lookup name et = match Utf8.encode name, et with | "abort", ExternFuncT ut -> - ExternFunc (Func.alloc_host (deftype_of_typeuse ut) abort) + Some (ExternFunc (Func.alloc_host (deftype_of_typeuse ut) abort)) | "exit", ExternFuncT ut -> - ExternFunc (Func.alloc_host (deftype_of_typeuse ut) exit) - | _ -> raise Not_found + Some (ExternFunc (Func.alloc_host (deftype_of_typeuse ut) exit)) + | _ -> None diff --git a/interpreter/host/spectest.ml b/interpreter/host/spectest.ml index 03ad95424e..db3a44415c 100644 --- a/interpreter/host/spectest.ml +++ b/interpreter/host/spectest.ml @@ -17,23 +17,23 @@ let global (GlobalT (_, t) as gt) = | VecT V128T -> Vec (V128 (V128.I32x4.of_lanes [666l; 666l; 666l; 666l])) | RefT (_, t) -> Ref (NullRef t) | BotT -> assert false - in ExternGlobal (Global.alloc gt v) + in Some (ExternGlobal (Global.alloc gt v)) let table = let tt = TableT (I32AT, {min = 10L; max = Some 20L}, (Null, FuncHT)) in - ExternTable (Table.alloc tt (NullRef FuncHT)) + Some (ExternTable (Table.alloc tt (NullRef FuncHT))) let table64 = let tt = TableT (I64AT, {min = 10L; max = Some 20L}, (Null, FuncHT)) in - ExternTable (Table.alloc tt (NullRef FuncHT)) + Some (ExternTable (Table.alloc tt (NullRef FuncHT))) let memory = let mt = MemoryT (I32AT, {min = 1L; max = Some 2L}) in - ExternMemory (Memory.alloc mt) + Some (ExternMemory (Memory.alloc mt)) let func f ts1 ts2 = let dt = DefT (RecT [SubT (Final, [], FuncT (ts1, ts2))], 0l) in - ExternFunc (Func.alloc_host dt (f ts1 ts2)) + Some (ExternFunc (Func.alloc_host dt (f ts1 ts2))) let print_value v = Printf.printf "%s : %s\n" @@ -61,4 +61,4 @@ let lookup name t = | "table", _ -> table | "table64", _ -> table64 | "memory", _ -> memory - | _ -> raise Not_found + | _ -> None diff --git a/interpreter/main/main.ml b/interpreter/main/main.ml index 5702a51d05..cab4a56381 100644 --- a/interpreter/main/main.ml +++ b/interpreter/main/main.ml @@ -8,8 +8,8 @@ let all_handlers = [ ] let configure custom_handlers = - Import.register (Utf8.decode "spectest") Spectest.lookup; - Import.register (Utf8.decode "env") Env.lookup; + Run.register_virtual (Utf8.decode "spectest") Spectest.lookup; + Run.register_virtual (Utf8.decode "env") Env.lookup; List.iter Custom.register custom_handlers let banner () = diff --git a/interpreter/runtime/exn.ml b/interpreter/runtime/exn.ml index bd341469b2..fb1f396ab0 100644 --- a/interpreter/runtime/exn.ml +++ b/interpreter/runtime/exn.ml @@ -1,7 +1,8 @@ open Types open Value -type exn_ = Exn of Tag.t * value list +type t = exn_ +and exn_ = Exn of Tag.t * value list type ref_ += ExnRef of exn_ diff --git a/interpreter/runtime/exn.mli b/interpreter/runtime/exn.mli index 220183c02a..d0007a9eb3 100644 --- a/interpreter/runtime/exn.mli +++ b/interpreter/runtime/exn.mli @@ -1,7 +1,8 @@ open Types open Value -type exn_ = Exn of Tag.t * value list +type t = exn_ +and exn_ = Exn of Tag.t * value list type ref_ += ExnRef of exn_ diff --git a/interpreter/runtime/instance.ml b/interpreter/runtime/instance.ml index ddb1a885d0..e0f6ded69c 100644 --- a/interpreter/runtime/instance.ml +++ b/interpreter/runtime/instance.ml @@ -21,9 +21,9 @@ and tableinst = Table.t and funcinst = moduleinst Lib.Promise.t Func.t and datainst = Data.t and eleminst = Elem.t -and exportinst = Ast.name * extern +and exportinst = Ast.name * externinst -and extern = +and externinst = | ExternTag of taginst | ExternGlobal of globalinst | ExternMemory of memoryinst diff --git a/interpreter/script/engine.ml b/interpreter/script/engine.ml new file mode 100644 index 0000000000..8b5d45a58f --- /dev/null +++ b/interpreter/script/engine.ml @@ -0,0 +1,56 @@ +type module_ = Ast.module_ +type value = Value.value +type ref_ = Value.ref_ + +module type Engine = +sig + type moduleinst + type taginst + type globalinst + type memoryinst + type tableinst + type funcinst + + type externinst = + | ExternTag of taginst + | ExternGlobal of globalinst + | ExternMemory of memoryinst + | ExternTable of tableinst + | ExternFunc of funcinst + + type error = Source.region * string + type 'a return = + | Return of 'a + | Exn of Source.region * taginst * value list + | Trap of error + | Exhaustion of error + + val validate : module_ -> (Types.moduletype, error) result + val validate_with_custom : + module_ * Custom.section list -> (Types.moduletype, error) result + val instantiate : + module_ -> externinst list -> (moduleinst return, error) result + + val module_export : moduleinst -> Ast.name -> externinst option + + val tag_type : taginst -> Types.tagtype + + val global_type : globalinst -> Types.globaltype + val global_get : globalinst -> value + val global_set : globalinst -> value -> unit + + val memory_type : memoryinst -> Types.memorytype + val memory_size : memoryinst -> int64 + val memory_grow : memoryinst -> int64 -> unit option + val memory_load_byte : memoryinst -> int64 -> int option + val memory_store_byte : memoryinst -> int64 -> int -> unit option + + val table_type : tableinst -> Types.tabletype + val table_size : tableinst -> int64 + val table_grow : tableinst -> int64 -> ref_ -> unit option + val table_get : tableinst -> int64 -> ref_ option + val table_set : tableinst -> int64 -> ref_ -> unit option + + val func_type : funcinst -> Types.deftype + val func_call : funcinst -> value list -> value list return +end diff --git a/interpreter/script/import.ml b/interpreter/script/import.ml deleted file mode 100644 index 39f90fec83..0000000000 --- a/interpreter/script/import.ml +++ /dev/null @@ -1,21 +0,0 @@ -open Source -open Ast -open Types - -module Unknown = Error.Make () -exception Unknown = Unknown.Error (* indicates unknown import name *) - -module Registry = Map.Make(struct type t = Ast.name let compare = compare end) -let registry = ref Registry.empty - -let register name lookup = registry := Registry.add name lookup !registry - -let lookup (ImportT (module_name, item_name, xt)) at : Instance.extern = - try Registry.find module_name !registry item_name xt with Not_found -> - Unknown.error at - ("unknown import \"" ^ Types.string_of_name module_name ^ - "\".\"" ^ Types.string_of_name item_name ^ "\"") - -let link m = - let ModuleT (its, _) = moduletype_of m in - List.map2 lookup its (List.map Source.at m.it.imports) diff --git a/interpreter/script/import.mli b/interpreter/script/import.mli deleted file mode 100644 index 9bd5d8a8ea..0000000000 --- a/interpreter/script/import.mli +++ /dev/null @@ -1,8 +0,0 @@ -exception Unknown of Source.region * string - -val link : Ast.module_ -> Instance.extern list (* raises Unknown *) - -val register : - Ast.name -> - (Ast.name -> Types.externtype -> Instance.extern (* raises Not_found *)) -> - unit diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index e5e420355b..13a759892c 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -1,635 +1,61 @@ -open Script -open Source - - -(* Errors & Tracing *) - -module Script = Error.Make () -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 binary_ext = "wasm" -let sexpr_ext = "wat" -let script_binary_ext = "bin.wast" -let script_ext = "wast" -let js_ext = "js" - -let dispatch_file_ext on_binary on_sexpr on_script_binary on_script 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 script_binary_ext then - on_script_binary file - else if Filename.check_suffix file script_ext then - on_script file - else if Filename.check_suffix file js_ext then - on_js file - else - raise (Sys_error (file ^ ": unrecognized file type")) - - -(* Output *) - -let create_binary_file file _ get_module = - trace ("Encoding (" ^ file ^ ")..."); - let s = Encode.encode_with_custom (get_module ()) 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 _ get_module = - trace ("Writing (" ^ file ^ ")..."); - let oc = open_out file in - try - Print.module_with_custom oc !Flags.width (get_module ()); - close_out oc - with exn -> close_out oc; raise exn - -let create_script_file mode file get_script _ = - trace ("Writing (" ^ file ^ ")..."); - let oc = open_out file in - try - Print.script oc !Flags.width mode (get_script ()); - close_out oc - with exn -> close_out oc; raise exn - -let create_js_file file get_script _ = - trace ("Converting (" ^ file ^ ")..."); - let js = Js.of_script (get_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_script_file `Binary) - (create_script_file `Textual) - create_js_file - -let output_stdout get_module = - trace "Printing..."; - Print.module_with_custom stdout !Flags.width (get_module ()) - - -(* Input *) - -let error at category msg = - trace ("Error: "); - prerr_endline (Source.string_of_region at ^ ": " ^ category ^ ": " ^ msg); - false - -let input_from get_script run = - try - let script = get_script () in - trace "Running..."; - run script; - true - with - | Decode.Code (at, msg) -> error at "decoding error" msg - | Parse.Syntax (at, msg) -> error at "syntax error" msg - | Valid.Invalid (at, msg) -> error at "validation error" msg - | Custom.Code (at, msg) -> error at "custom section decoding error" msg - | Custom.Syntax (at, msg) -> error at "custom annotation syntax error" msg - | Custom.Invalid (at, msg) -> error at "custom validation error" 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.Exhaustion (at, msg) -> error at "resource exhaustion" msg - | Eval.Crash (at, msg) -> error at "runtime crash" msg - | Eval.Exception (at, msg) -> error at "uncaught exception" msg - | Encode.Code (at, msg) -> error at "encoding error" msg - | Script.Error (at, msg) -> error at "script error" msg - | IO (at, msg) -> error at "i/o error" msg - | Assert (at, msg) -> error at "assertion failure" msg - | Abort _ -> false - -let input_script name lexbuf run = - input_from (fun () -> Parse.Script.parse name lexbuf) run - -let input_script1 name lexbuf run = - input_from (fun () -> Parse.Script1.parse name lexbuf) run - -let input_sexpr name lexbuf run = - input_from (fun () -> - let var_opt, def = Parse.Module.parse name lexbuf in - [Module (var_opt, def) @@ no_region]) run - -let input_binary name buf run = - let open Source in - input_from (fun () -> - [Module (None, Encoded (name, buf @@ no_region) @@ no_region) @@ no_region] - ) run - -let input_sexpr_file input file run = - trace ("Loading (" ^ file ^ ")..."); - let ic = open_in file in - try - let lexbuf = Lexing.from_channel ic in - trace "Parsing..."; - let success = input file lexbuf run in - close_in ic; - success - with exn -> close_in ic; raise exn - -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; - trace "Decoding..."; - let success = input_binary file (Bytes.to_string buf) run in - close_in ic; - success - with exn -> close_in ic; raise exn - -let input_js_file file run = - raise (Sys_error (file ^ ": unrecognized input file type")) - -let input_file file run = - dispatch_file_ext - input_binary_file - (input_sexpr_file input_sexpr) - (input_sexpr_file input_script) - (input_sexpr_file input_script) - input_js_file - file run - -let input_string string run = - trace ("Running (\"" ^ String.escaped string ^ "\")..."); - let lexbuf = Lexing.from_string string in - trace "Parsing..."; - input_script "string" lexbuf run - - -(* Interactive *) - -let continuing = ref false - -let lexbuf_stdin buf len = - let prompt = if !continuing then " " else "> " in - print_string prompt; flush_all (); - continuing := true; - let rec loop i = - if i = len then i else - let ch = input_char stdin in - Bytes.set buf i ch; - if ch = '\n' then i + 1 else loop (i + 1) - in - let n = loop 0 in - if n = 1 then continuing := false else trace "Parsing..."; - n - -let input_stdin run = - let lexbuf = Lexing.from_function lexbuf_stdin in - let rec loop () = - let success = input_script1 "stdin" lexbuf run in - if not success then Lexing.flush_input lexbuf; - if Lexing.(lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len - 1) then - continuing := false; - loop () - in - try loop () with End_of_file -> - print_endline ""; - trace "Bye." - - -(* Printing *) - -let indent s = - let lines = List.filter ((<>) "") (String.split_on_char '\n' s) in - String.concat "\n" (List.map ((^) " ") lines) ^ "\n" - -let print_moduletype x_opt mt = - Printf.printf "module%s :\n%s%!" - (match x_opt with None -> "" | Some x -> " " ^ x.it) - (indent (Types.string_of_moduletype mt)) - -let print_values vs = - let ts = List.map Value.type_of_value vs in - Printf.printf "%s : %s\n%!" - (Value.string_of_values vs) (Types.string_of_resulttype ts) - -let string_of_nan = function - | CanonicalNan -> "nan:canonical" - | ArithmeticNan -> "nan:arithmetic" - -let string_of_num_pat (p : num_pat) = - match p with - | NumPat n -> Value.string_of_num n.it - | NanPat nanop -> - match nanop.it with - | Value.I32 _ | Value.I64 _ -> assert false - | Value.F32 n | Value.F64 n -> string_of_nan n - -let string_of_vec_pat (p : vec_pat) = - match p with - | VecPat (Value.V128 (shape, ns)) -> - String.concat " " (List.map string_of_num_pat ns) - -let string_of_ref_pat (p : ref_pat) = - match p with - | RefPat r -> Value.string_of_ref r.it - | RefTypePat t -> Types.string_of_heaptype t - | NullPat -> "null" - -let rec string_of_result r = - match r.it with - | NumResult np -> string_of_num_pat np - | VecResult vp -> string_of_vec_pat vp - | RefResult rp -> string_of_ref_pat rp - | EitherResult rs -> - "(" ^ String.concat " | " (List.map string_of_result rs) ^ ")" - -let string_of_results = function - | [r] -> string_of_result r - | rs -> "[" ^ String.concat " " (List.map string_of_result rs) ^ "]" - -let rec type_of_result r = - let open Types in - match r.it with - | NumResult (NumPat n) -> NumT (Value.type_of_num n.it) - | NumResult (NanPat n) -> NumT (Value.type_of_num n.it) - | VecResult (VecPat v) -> VecT (Value.type_of_vec v) - | RefResult (RefPat r) -> RefT (Value.type_of_ref r.it) - | RefResult (RefTypePat t) -> RefT (NoNull, t) (* assume closed *) - | RefResult (NullPat) -> RefT (Null, ExternHT) - | EitherResult rs -> - let ts = List.map type_of_result rs in - List.fold_left (fun t1 t2 -> - if Match.match_valtype [] t1 t2 then t2 else - if Match.match_valtype [] t2 t1 then t1 else - if Match.(top_of_valtype [] t1 = top_of_valtype [] t2) then - Match.top_of_valtype [] t1 - else - BotT (* should really be Top, but we don't have that :) *) - ) (List.hd ts) 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_resulttype ts) - - -(* Configuration *) - -module Map = Map.Make(String) - -let quote : script ref = ref [] -let scripts : script Map.t ref = ref Map.empty -let modules : (Ast.module_ * Custom.section list) Map.t ref = ref Map.empty -let instances : Instance.moduleinst Map.t ref = ref Map.empty -let registry : Instance.moduleinst Map.t ref = ref Map.empty - -let bind category map x_opt y = - let map' = - match x_opt with - | None -> !map - | Some x -> - if Map.mem x.it !map then - IO.error x.at (category ^ " " ^ x.it ^ " already defined"); - Map.add x.it y !map - in map := Map.add "" y map' - -let lookup category map x_opt at = - let key = match x_opt with None -> "" | Some x -> x.it in - try Map.find key !map with Not_found -> - IO.error 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 instance" instances - -let lookup_registry module_name item_name _t = - match Instance.export (Map.find module_name !registry) item_name with - | Some ext -> ext - | None -> raise Not_found - - -(* Running *) - -let rec run_definition def : Ast.module_ * Custom.section list = - match def.it with - | Textual (m, cs) -> m, cs - | Encoded (name, bs) -> - trace "Decoding..."; - Decode.decode_with_custom name bs.it - | Quoted (_, s) -> - trace "Parsing quote..."; - let _, def' = Parse.Module.parse_string ~offset:s.at s.it in - run_definition def' - -let run_action act : Value.t list = - match act.it with - | Invoke (x_opt, name, vs) -> - trace ("Invoking function \"" ^ Types.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in - (match Instance.export inst name with - | Some (Instance.ExternFunc f) -> - let (ts1, _ts2) = - Types.(functype_of_comptype (expand_deftype (Func.type_of f))) in - if List.length vs <> List.length ts1 then - Script.error act.at "wrong number of arguments"; - List.iter2 (fun v t -> - if not (Match.match_valtype [] (Value.type_of_value v.it) t) then - Script.error v.at "wrong type of argument" - ) vs ts1; - Eval.invoke f (List.map (fun v -> v.it) vs) - | Some _ -> Assert.error act.at "export is not a function" - | None -> Assert.error act.at "undefined export" - ) - - | Get (x_opt, name) -> - trace ("Getting global \"" ^ Types.string_of_name name ^ "\"..."); - let inst = lookup_instance 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" - | None -> Assert.error act.at "undefined export" - ) - -let assert_nan_pat n nan = - let open Value in - match n, nan.it with - | F32 z, F32 CanonicalNan -> z = F32.pos_nan || z = F32.neg_nan - | F64 z, F64 CanonicalNan -> z = F64.pos_nan || z = F64.neg_nan - | F32 z, F32 ArithmeticNan -> - let pos_nan = F32.to_bits F32.pos_nan in - Int32.logand (F32.to_bits z) pos_nan = pos_nan - | F64 z, F64 ArithmeticNan -> - let pos_nan = F64.to_bits F64.pos_nan in - Int64.logand (F64.to_bits z) pos_nan = pos_nan - | _, _ -> false - -let assert_num_pat n np = - match np with - | NumPat n' -> n = n'.it - | NanPat nanop -> assert_nan_pat n nanop - -let assert_vec_pat v p = - let open Value in - match v, p with - | V128 v, VecPat (V128 (shape, ps)) -> - let extract = match shape with - | V128.I8x16 () -> fun v i -> I32 (Convert.I32_.extend_i8_s (V128.I8x16.extract_lane i v)) - | V128.I16x8 () -> fun v i -> I32 (Convert.I32_.extend_i16_s (V128.I16x8.extract_lane i v)) - | V128.I32x4 () -> fun v i -> I32 (V128.I32x4.extract_lane i v) - | V128.I64x2 () -> fun v i -> I64 (V128.I64x2.extract_lane i v) - | V128.F32x4 () -> fun v i -> F32 (V128.F32x4.extract_lane i v) - | V128.F64x2 () -> fun v i -> F64 (V128.F64x2.extract_lane i v) - in - List.for_all2 assert_num_pat - (List.init (V128.num_lanes shape) (extract v)) ps - -let assert_ref_pat r p = - match p, r with - | RefPat r', r -> Value.eq_ref r r'.it - | RefTypePat Types.AnyHT, Instance.FuncRef _ -> false - | RefTypePat Types.AnyHT, _ - | RefTypePat Types.EqHT, (I31.I31Ref _ | Aggr.StructRef _ | Aggr.ArrayRef _) - | RefTypePat Types.I31HT, I31.I31Ref _ - | RefTypePat Types.StructHT, Aggr.StructRef _ - | RefTypePat Types.ArrayHT, Aggr.ArrayRef _ -> true - | RefTypePat Types.FuncHT, Instance.FuncRef _ - | RefTypePat Types.ExnHT, Exn.ExnRef _ - | RefTypePat Types.ExternHT, _ -> true - | NullPat, Value.NullRef _ -> true - | _ -> false - -let rec assert_result v r = - let open Value in - match v, r.it with - | Num n, NumResult np -> assert_num_pat n np - | Vec v, VecResult vp -> assert_vec_pat v vp - | Ref r, RefResult rp -> assert_ref_pat r rp - | _, EitherResult rs -> List.exists (assert_result v) rs - | _, _ -> false - -let assert_results at got expect = - if - List.length got <> List.length expect || - not (List.for_all2 assert_result got expect) - then begin - print_string "Result: "; print_values got; - print_string "Expect: "; print_results expect; - Assert.error at "wrong return values" - end - -let assert_message at name msg re = - if - String.length msg < String.length re || - String.sub msg 0 (String.length re) <> re - then begin - print_endline ("Result: \"" ^ msg ^ "\""); - print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error at ("wrong " ^ name ^ " error") - end - -let run_assertion ass = - match ass.it with - | AssertMalformed (def, re) -> - trace "Asserting malformed..."; - (match ignore (run_definition 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" - ) - - | AssertMalformedCustom (def, re) -> - trace "Asserting malformed custom..."; - (match ignore (run_definition def) with - | exception Custom.Syntax (_, msg) -> - assert_message ass.at "annotation parsing" msg re - | _ -> Assert.error ass.at "expected custom decoding/parsing error" - ) - - | AssertInvalid (def, re) -> - trace "Asserting invalid..."; - (match - let m, cs = run_definition def in - ignore (Valid.check_module_with_custom (m, cs)) - with - | exception Valid.Invalid (_, msg) -> - assert_message ass.at "validation" msg re - | _ -> Assert.error ass.at "expected validation error" - ) - - | AssertInvalidCustom (def, re) -> - trace "Asserting invalid custom..."; - (match - let m, cs = run_definition def in - ignore (Valid.check_module_with_custom (m, cs)) - with - | exception Custom.Invalid (_, msg) -> - assert_message ass.at "custom validation" msg re - | _ -> Assert.error ass.at "expected custom validation error" - ) - - | AssertUnlinkable (x_opt, re) -> - trace "Asserting unlinkable..."; - let m, cs = lookup_module x_opt ass.at in - if not !Flags.unchecked then ignore (Valid.check_module_with_custom (m, cs)); - (match - let imports = Import.link m in - ignore (Eval.init m imports) - with - | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> - assert_message ass.at "linking" msg re - | _ -> Assert.error ass.at "expected linking error" - ) - - | AssertUninstantiable (x_opt, re) -> - trace "Asserting trap..."; - let m, cs = lookup_module x_opt ass.at in - if not !Flags.unchecked then ignore (Valid.check_module_with_custom (m, cs)); - (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" - ) - - | AssertReturn (act, rs) -> - trace ("Asserting return..."); - let vs = run_action act in - assert_results ass.at vs rs - - | AssertException act -> - trace ("Asserting exception..."); - (match run_action act with - | exception Eval.Exception (_, msg) -> () - | _ -> Assert.error ass.at "expected exception" - ) - - | AssertTrap (act, re) -> - trace ("Asserting trap..."); - (match run_action 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 - | exception Eval.Exhaustion (_, msg) -> - assert_message ass.at "exhaustion" msg re - | _ -> Assert.error ass.at "expected exhaustion error" - ) - -let rec run_command cmd = - match cmd.it with - | Module (x_opt, def) -> - quote := cmd :: !quote; - let m, cs = run_definition def in - if not !Flags.unchecked then begin - trace "Checking..."; - let mt = Valid.check_module_with_custom (m, cs) in - if !Flags.print_sig then begin - trace "Signature:"; - print_moduletype x_opt mt - end - end; - bind "module" modules x_opt (m, cs); - bind "script" scripts x_opt [cmd] - - | Instance (x1_opt, x2_opt) -> - quote := cmd :: !quote; - let m, cs = lookup_module x2_opt cmd.at in - if not !Flags.dry then begin - trace "Initializing..."; - let imports = Import.link m in - let inst = Eval.init m imports in - bind "instance" instances x1_opt inst - end - - | Register (name, x_opt) -> - quote := cmd :: !quote; - if not !Flags.dry then begin - trace ("Registering module \"" ^ Types.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)) - end - - | Action act -> - quote := cmd :: !quote; - if not !Flags.dry then begin - let vs = run_action act in - if vs <> [] then print_values vs - end - - | Assertion ass -> - quote := cmd :: !quote; - if not !Flags.dry then begin - run_assertion ass - end - - | Meta cmd -> - run_meta cmd - -and run_meta cmd = - match cmd.it with - | Script (x_opt, script) -> - run_quote_script script; - bind "script" scripts x_opt (lookup_script None cmd.at) - - | Input (x_opt, file) -> - (try if not (input_file file run_quote_script) then - Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg); - bind "script" scripts x_opt (lookup_script None cmd.at); - if x_opt <> None then begin - bind "module" modules x_opt (lookup_module None cmd.at); - if not !Flags.dry then begin - bind "instance" instances x_opt (lookup_instance 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) - with Sys_error msg -> IO.error cmd.at msg) - - | Output (x_opt, None) -> - (try output_stdout (fun () -> lookup_module 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 "script" 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 +module Engine (* : Engine.Engine *) = +struct + include Instance + + type error = Source.region * string + type 'a return = + | Return of 'a + | Exn of Source.region * taginst * Value.t list + | Trap of error + | Exhaustion of error + + let result f x y = + try Return (f x y) with + | Eval.Trap (at, msg) -> Trap (at, msg) + | Eval.Exception (at, Exn.Exn (a, vs)) -> Exn (at, a, vs) + | Eval.Exhaustion (at, msg) -> Exhaustion (at, msg) + + let guard exns f x y = + try Some (f x y) with + | exn when List.mem exn exns -> None + + let validate m = + try Ok (Valid.check_module m) with + | Valid.Invalid (at, msg) -> Error (at, msg) + + let validate_with_custom (m, cs) = + try Ok (Valid.check_module_with_custom (m, cs)) with + | Valid.Invalid (at, msg) -> Error (at, msg) + + let instantiate m ims = + try Ok (result Eval.init m ims) with + | Eval.Link (at, msg) -> Error (at, msg) + + let module_export = Instance.export + + let tag_type = Tag.type_of + + let global_type = Global.type_of + let global_get = Global.load + let global_set = Global.store + + let memory_type = Memory.type_of + let memory_size = Memory.size + let memory_grow = + guard Memory.[SizeLimit; SizeOverflow; OutOfMemory] Memory.grow + let memory_load_byte = guard [Memory.Bounds] Memory.load_byte + let memory_store_byte m = guard [Memory.Bounds] (Memory.store_byte m) + + let table_type = Table.type_of + let table_size = Table.size + let table_grow t = + guard Table.[SizeLimit; SizeOverflow; OutOfMemory] (Table.grow t) + let table_get = guard [Table.Bounds] Table.load + let table_set t = guard [Table.Bounds] (Table.store t) + + let func_type = Func.type_of + let func_call = result Eval.invoke +end + + +include Runner.Make (Engine) diff --git a/interpreter/script/run.mli b/interpreter/script/run.mli deleted file mode 100644 index 3f6cca535c..0000000000 --- a/interpreter/script/run.mli +++ /dev/null @@ -1,14 +0,0 @@ -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 assert_results : Source.region -> - Value.value list -> Script.result list -> unit (* raises Assert *) -val assert_message : Source.region -> - string -> string -> string -> unit (* raises Assert *) diff --git a/interpreter/script/runner.ml b/interpreter/script/runner.ml new file mode 100644 index 0000000000..a598105283 --- /dev/null +++ b/interpreter/script/runner.ml @@ -0,0 +1,678 @@ +module Make (Engine : Engine.Engine) = +struct + +open Script +open Source + + +(* Errors & Tracing *) + +module Script = Error.Make () +module Abort = Error.Make () +module Assert = Error.Make () +module IO = Error.Make () +module Invalid = Error.Make () +module Link = Error.Make () +module Trap = Error.Make () +module Crash = Error.Make () +module Exception = Error.Make () +module Exhaustion = Error.Make () + +exception Abort = Abort.Error +exception Assert = Assert.Error +exception IO = IO.Error +exception Invalid = Invalid.Error +exception Link = Link.Error +exception Trap = Trap.Error +exception Crash = Crash.Error +exception Exception = Exception.Error +exception Exhaustion = Exhaustion.Error + +let trace name = if !Flags.trace then print_endline ("-- " ^ name) + + +(* File types *) + +let binary_ext = "wasm" +let sexpr_ext = "wat" +let script_binary_ext = "bin.wast" +let script_ext = "wast" +let js_ext = "js" + +let dispatch_file_ext on_binary on_sexpr on_script_binary on_script 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 script_binary_ext then + on_script_binary file + else if Filename.check_suffix file script_ext then + on_script file + else if Filename.check_suffix file js_ext then + on_js file + else + raise (Sys_error (file ^ ": unrecognized file type")) + + +(* Output *) + +let create_binary_file file _ get_module = + trace ("Encoding (" ^ file ^ ")..."); + let s = Encode.encode_with_custom (get_module ()) 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 _ get_module = + trace ("Writing (" ^ file ^ ")..."); + let oc = open_out file in + try + Print.module_with_custom oc !Flags.width (get_module ()); + close_out oc + with exn -> close_out oc; raise exn + +let create_script_file mode file get_script _ = + trace ("Writing (" ^ file ^ ")..."); + let oc = open_out file in + try + Print.script oc !Flags.width mode (get_script ()); + close_out oc + with exn -> close_out oc; raise exn + +let create_js_file file get_script _ = + trace ("Converting (" ^ file ^ ")..."); + let js = Js.of_script (get_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_script_file `Binary) + (create_script_file `Textual) + create_js_file + +let output_stdout get_module = + trace "Printing..."; + Print.module_with_custom stdout !Flags.width (get_module ()) + + +(* Input *) + +let error at category msg = + trace ("Error: "); + prerr_endline (Source.string_of_region at ^ ": " ^ category ^ ": " ^ msg); + false + +let input_from get_script run = + try + let script = get_script () in + trace "Running..."; + run script; + true + with + | Decode.Code (at, msg) -> error at "decoding error" msg + | Encode.Code (at, msg) -> error at "encoding error" msg + | Parse.Syntax (at, msg) -> error at "syntax error" msg + | Custom.Code (at, msg) -> error at "custom section decoding error" msg + | Custom.Syntax (at, msg) -> error at "custom annotation syntax error" msg + | Custom.Invalid (at, msg) -> error at "custom validation error" msg + | Script.Error (at, msg) -> error at "script error" msg + | Invalid (at, msg) -> error at "validation error" msg + | Link (at, msg) -> error at "link failure" msg + | Trap (at, msg) -> error at "runtime trap" msg + | Crash (at, msg) -> error at "runtime crash" msg + | Exception (at, msg) -> error at "uncaught exception" msg + | Exhaustion (at, msg) -> error at "resource exhaustion" msg + | Assert (at, msg) -> error at "assertion failure" msg + | IO (at, msg) -> error at "i/o error" msg + | Abort _ -> false + +let input_script name lexbuf run = + input_from (fun () -> Parse.Script.parse name lexbuf) run + +let input_script1 name lexbuf run = + input_from (fun () -> Parse.Script1.parse name lexbuf) run + +let input_sexpr name lexbuf run = + input_from (fun () -> + let var_opt, def = Parse.Module.parse name lexbuf in + [Module (var_opt, def) @@ no_region]) run + +let input_binary name buf run = + let open Source in + input_from (fun () -> + [Module (None, Encoded (name, buf @@ no_region) @@ no_region) @@ no_region] + ) run + +let input_sexpr_file input file run = + trace ("Loading (" ^ file ^ ")..."); + let ic = open_in file in + try + let lexbuf = Lexing.from_channel ic in + trace "Parsing..."; + let success = input file lexbuf run in + close_in ic; + success + with exn -> close_in ic; raise exn + +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; + trace "Decoding..."; + let success = input_binary file (Bytes.to_string buf) run in + close_in ic; + success + with exn -> close_in ic; raise exn + +let input_js_file file run = + raise (Sys_error (file ^ ": unrecognized input file type")) + +let input_file file run = + dispatch_file_ext + input_binary_file + (input_sexpr_file input_sexpr) + (input_sexpr_file input_script) + (input_sexpr_file input_script) + input_js_file + file run + +let input_string string run = + trace ("Running (\"" ^ String.escaped string ^ "\")..."); + let lexbuf = Lexing.from_string string in + trace "Parsing..."; + input_script "string" lexbuf run + + +(* Interactive *) + +let continuing = ref false + +let lexbuf_stdin buf len = + let prompt = if !continuing then " " else "> " in + print_string prompt; flush_all (); + continuing := true; + let rec loop i = + if i = len then i else + let ch = input_char stdin in + Bytes.set buf i ch; + if ch = '\n' then i + 1 else loop (i + 1) + in + let n = loop 0 in + if n = 1 then continuing := false else trace "Parsing..."; + n + +let input_stdin run = + let lexbuf = Lexing.from_function lexbuf_stdin in + let rec loop () = + let success = input_script1 "stdin" lexbuf run in + if not success then Lexing.flush_input lexbuf; + if Lexing.(lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len - 1) then + continuing := false; + loop () + in + try loop () with End_of_file -> + print_endline ""; + trace "Bye." + + +(* Printing *) + +let indent s = + let lines = List.filter ((<>) "") (String.split_on_char '\n' s) in + String.concat "\n" (List.map ((^) " ") lines) ^ "\n" + +let print_moduletype x_opt mt = + Printf.printf "module%s :\n%s%!" + (match x_opt with None -> "" | Some x -> " " ^ x.it) + (indent (Types.string_of_moduletype mt)) + +let print_values vs = + let ts = List.map Value.type_of_value vs in + Printf.printf "%s : %s\n%!" + (Value.string_of_values vs) (Types.string_of_resulttype ts) + +let string_of_nan = function + | CanonicalNan -> "nan:canonical" + | ArithmeticNan -> "nan:arithmetic" + +let string_of_num_pat (p : num_pat) = + match p with + | NumPat n -> Value.string_of_num n.it + | NanPat nanop -> + match nanop.it with + | Value.I32 _ | Value.I64 _ -> assert false + | Value.F32 n | Value.F64 n -> string_of_nan n + +let string_of_vec_pat (p : vec_pat) = + match p with + | VecPat (Value.V128 (shape, ns)) -> + String.concat " " (List.map string_of_num_pat ns) + +let string_of_ref_pat (p : ref_pat) = + match p with + | RefPat r -> Value.string_of_ref r.it + | RefTypePat t -> Types.string_of_heaptype t + | NullPat -> "null" + +let rec string_of_result r = + match r.it with + | NumResult np -> string_of_num_pat np + | VecResult vp -> string_of_vec_pat vp + | RefResult rp -> string_of_ref_pat rp + | EitherResult rs -> + "(" ^ String.concat " | " (List.map string_of_result rs) ^ ")" + +let string_of_results = function + | [r] -> string_of_result r + | rs -> "[" ^ String.concat " " (List.map string_of_result rs) ^ "]" + +let rec type_of_result r = + let open Types in + match r.it with + | NumResult (NumPat n) -> NumT (Value.type_of_num n.it) + | NumResult (NanPat n) -> NumT (Value.type_of_num n.it) + | VecResult (VecPat v) -> VecT (Value.type_of_vec v) + | RefResult (RefPat r) -> RefT (Value.type_of_ref r.it) + | RefResult (RefTypePat t) -> RefT (NoNull, t) (* assume closed *) + | RefResult (NullPat) -> RefT (Null, ExternHT) + | EitherResult rs -> + let ts = List.map type_of_result rs in + List.fold_left (fun t1 t2 -> + if Match.match_valtype [] t1 t2 then t2 else + if Match.match_valtype [] t2 t1 then t1 else + if Match.(top_of_valtype [] t1 = top_of_valtype [] t2) then + Match.top_of_valtype [] t1 + else + BotT (* should really be Top, but we don't have that :) *) + ) (List.hd ts) 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_resulttype ts) + + +(* Configuration *) + +module Map = Map.Make(String) + +let quote : script ref = ref [] +let scripts : script Map.t ref = ref Map.empty +let modules : (Ast.module_ * Custom.section list) Map.t ref = ref Map.empty +let instances : Engine.moduleinst Map.t ref = ref Map.empty +let registry : (Ast.name -> Types.externtype -> Engine.externinst option) Map.t ref = ref Map.empty + +let bind category map x_opt y = + let map' = + match x_opt with + | None -> !map + | Some x -> + if Map.mem x.it !map then + IO.error x.at (category ^ " " ^ x.it ^ " already defined"); + Map.add x.it y !map + in map := Map.add "" y map' + +let lookup category map x_opt at = + let key = match x_opt with None -> "" | Some x -> x.it in + try Map.find key !map with Not_found -> + IO.error 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 instance" instances + +let lookup_registry module_name item_name xt = + match Map.find_opt (Utf8.encode module_name) !registry with + | Some f -> f item_name xt + | None -> None + +let lookup_import (Types.ImportT (module_name, item_name, xt)) at = + match lookup_registry module_name item_name xt with + | Some ex -> ex + | None -> + Link.error at + ("unknown import \"" ^ Types.string_of_name module_name ^ + "\".\"" ^ Types.string_of_name item_name ^ "\"") + + +let register_virtual name lookup = + registry := Map.add (Utf8.encode name) lookup !registry + +let register_instance name inst = + register_virtual name + (fun item_name _xt -> Engine.module_export inst item_name) + + +(* Running *) + +let validity = function + | Ok t -> () + | Error (at, msg) -> Invalid.error at msg + +let result = function + | Engine.Return x -> x + | Engine.Exn (at, tag, vs) -> + let msg = "uncaught exception with args " ^ Value.string_of_values vs in + Exception.error at msg + | Engine.Trap (at, msg) -> Trap.error at msg + | Engine.Exhaustion (at, msg) -> Exhaustion.error at msg + +let rec run_definition def : Ast.module_ * Custom.section list = + match def.it with + | Textual (m, cs) -> m, cs + | Encoded (name, bs) -> + trace "Decoding..."; + Decode.decode_with_custom name bs.it + | Quoted (_, s) -> + trace "Parsing quote..."; + let _, def' = Parse.Module.parse_string ~offset:s.at s.it in + run_definition def' + +let run_instantiation m = + let Types.ModuleT (its, _) = Ast.moduletype_of m in + let imports = List.map2 lookup_import its (List.map Source.at m.it.Ast.imports) in + match Engine.instantiate m imports with + | Ok r -> result r + | Error (at, msg) -> Link.error at msg + +let run_action act : Value.t list = + match act.it with + | Invoke (x_opt, name, vs) -> + trace ("Invoking function \"" ^ Types.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + (match Engine.module_export inst name with + | Some (Engine.ExternFunc f) -> + let (ts1, _ts2) = + Types.(functype_of_comptype (expand_deftype (Engine.func_type f))) in + if List.length vs <> List.length ts1 then + Script.error act.at "wrong number of arguments"; + List.iter2 (fun v t -> + if not (Match.match_valtype [] (Value.type_of_value v.it) t) then + Script.error v.at "wrong type of argument" + ) vs ts1; + result (Engine.func_call f (List.map (fun v -> v.it) vs)) + | Some _ -> Assert.error act.at "export is not a function" + | None -> Assert.error act.at "undefined export" + ) + + | Get (x_opt, name) -> + trace ("Getting global \"" ^ Types.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + (match Engine.module_export inst name with + | Some (Engine.ExternGlobal g) -> [Engine.global_get g] + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" + ) + +let assert_nan_pat n nan = + let open Value in + match n, nan.it with + | F32 z, F32 CanonicalNan -> z = F32.pos_nan || z = F32.neg_nan + | F64 z, F64 CanonicalNan -> z = F64.pos_nan || z = F64.neg_nan + | F32 z, F32 ArithmeticNan -> + let pos_nan = F32.to_bits F32.pos_nan in + Int32.logand (F32.to_bits z) pos_nan = pos_nan + | F64 z, F64 ArithmeticNan -> + let pos_nan = F64.to_bits F64.pos_nan in + Int64.logand (F64.to_bits z) pos_nan = pos_nan + | _, _ -> false + +let assert_num_pat n np = + match np with + | NumPat n' -> n = n'.it + | NanPat nanop -> assert_nan_pat n nanop + +let assert_vec_pat v p = + let open Value in + match v, p with + | V128 v, VecPat (V128 (shape, ps)) -> + let extract = match shape with + | V128.I8x16 () -> fun v i -> I32 (Convert.I32_.extend_i8_s (V128.I8x16.extract_lane i v)) + | V128.I16x8 () -> fun v i -> I32 (Convert.I32_.extend_i16_s (V128.I16x8.extract_lane i v)) + | V128.I32x4 () -> fun v i -> I32 (V128.I32x4.extract_lane i v) + | V128.I64x2 () -> fun v i -> I64 (V128.I64x2.extract_lane i v) + | V128.F32x4 () -> fun v i -> F32 (V128.F32x4.extract_lane i v) + | V128.F64x2 () -> fun v i -> F64 (V128.F64x2.extract_lane i v) + in + List.for_all2 assert_num_pat + (List.init (V128.num_lanes shape) (extract v)) ps + +let assert_ref_pat r p = + match p, r with + | RefPat r', r -> Value.eq_ref r r'.it + | RefTypePat Types.AnyHT, Instance.FuncRef _ -> false + | RefTypePat Types.AnyHT, _ + | RefTypePat Types.EqHT, (I31.I31Ref _ | Aggr.StructRef _ | Aggr.ArrayRef _) + | RefTypePat Types.I31HT, I31.I31Ref _ + | RefTypePat Types.StructHT, Aggr.StructRef _ + | RefTypePat Types.ArrayHT, Aggr.ArrayRef _ -> true + | RefTypePat Types.FuncHT, Instance.FuncRef _ + | RefTypePat Types.ExnHT, Exn.ExnRef _ + | RefTypePat Types.ExternHT, _ -> true + | NullPat, Value.NullRef _ -> true + | _ -> false + +let rec assert_result v r = + let open Value in + match v, r.it with + | Num n, NumResult np -> assert_num_pat n np + | Vec v, VecResult vp -> assert_vec_pat v vp + | Ref r, RefResult rp -> assert_ref_pat r rp + | _, EitherResult rs -> List.exists (assert_result v) rs + | _, _ -> false + +let assert_results at got expect = + if + List.length got <> List.length expect || + not (List.for_all2 assert_result got expect) + then begin + print_string "Result: "; print_values got; + print_string "Expect: "; print_results expect; + Assert.error at "wrong return values" + end + +let assert_message at name msg re = + if + String.length msg < String.length re || + String.sub msg 0 (String.length re) <> re + then begin + print_endline ("Result: \"" ^ msg ^ "\""); + print_endline ("Expect: \"" ^ re ^ "\""); + Assert.error at ("wrong " ^ name ^ " error") + end + +let run_assertion ass = + match ass.it with + | AssertMalformed (def, re) -> + trace "Asserting malformed..."; + (match ignore (run_definition 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" + ) + + | AssertMalformedCustom (def, re) -> + trace "Asserting malformed custom..."; + (match ignore (run_definition def) with + | exception Custom.Syntax (_, msg) -> + assert_message ass.at "annotation parsing" msg re + | _ -> Assert.error ass.at "expected custom decoding/parsing error" + ) + + | AssertInvalid (def, re) -> + trace "Asserting invalid..."; + (match + let m, _cs = run_definition def in + validity (Engine.validate m) + with + | exception Invalid (_, msg) -> + assert_message ass.at "validation" msg re + | _ -> Assert.error ass.at "expected validation error" + ) + + | AssertInvalidCustom (def, re) -> + trace "Asserting invalid custom..."; + (match + let m, cs = run_definition def in + validity (Engine.validate_with_custom (m, cs)) + with + | exception Invalid (_, msg) -> + assert_message ass.at "custom validation" msg re + | _ -> Assert.error ass.at "expected custom validation error" + ) + + | AssertUnlinkable (x_opt, re) -> + trace "Asserting unlinkable..."; + let m, cs = lookup_module x_opt ass.at in + (match run_instantiation m with + | exception Link (_, msg) -> + assert_message ass.at "linking" msg re + | _ -> Assert.error ass.at "expected linking error" + ) + + | AssertUninstantiable (x_opt, re) -> + trace "Asserting trap..."; + let m, cs = lookup_module x_opt ass.at in + (match run_instantiation m with + | exception (Trap (_, msg) | Exception (_, msg)) -> + assert_message ass.at "instantiation" msg re + | _ -> Assert.error ass.at "expected instantiation error" + ) + + | AssertReturn (act, rs) -> + trace ("Asserting return..."); + let vs = run_action act in + assert_results ass.at vs rs + + | AssertException act -> + trace ("Asserting exception..."); + (match run_action act with + | exception Exception (_, msg) -> () + | _ -> Assert.error ass.at "expected exception" + ) + + | AssertTrap (act, re) -> + trace ("Asserting trap..."); + (match run_action act with + | exception 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 + | exception Exhaustion (_, msg) -> + assert_message ass.at "exhaustion" msg re + | _ -> Assert.error ass.at "expected exhaustion error" + ) + +let rec run_command cmd = + match cmd.it with + | Module (x_opt, def) -> + quote := cmd :: !quote; + let m, cs = run_definition def in + if not !Flags.unchecked then begin + trace "Checking..."; + match Engine.validate_with_custom (m, cs) with + | Ok mt -> + if !Flags.print_sig then begin + trace "Signature:"; + print_moduletype x_opt mt + end + | Error (at, msg) -> Invalid.error at msg + end; + bind "module" modules x_opt (m, cs); + bind "script" scripts x_opt [cmd] + + | Instance (x1_opt, x2_opt) -> + quote := cmd :: !quote; + let m, cs = lookup_module x2_opt cmd.at in + if not !Flags.dry then begin + trace "Initializing..."; + let inst = run_instantiation m in + bind "instance" instances x1_opt inst + end + + | Register (name, x_opt) -> + quote := cmd :: !quote; + if not !Flags.dry then begin + trace ("Registering module \"" ^ Types.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt cmd.at in + register_instance name inst + end + + | Action act -> + quote := cmd :: !quote; + if not !Flags.dry then begin + let vs = run_action act in + if vs <> [] then print_values vs + end + + | Assertion ass -> + quote := cmd :: !quote; + if not !Flags.dry then begin + run_assertion ass + end + + | Meta cmd -> + run_meta cmd + +and run_meta cmd = + match cmd.it with + | Script (x_opt, script) -> + run_quote_script script; + bind "script" scripts x_opt (lookup_script None cmd.at) + + | Input (x_opt, file) -> + (try if not (input_file file run_quote_script) then + Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg); + bind "script" scripts x_opt (lookup_script None cmd.at); + if x_opt <> None then begin + bind "module" modules x_opt (lookup_module None cmd.at); + if not !Flags.dry then begin + bind "instance" instances x_opt (lookup_instance 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) + with Sys_error msg -> IO.error cmd.at msg) + + | Output (x_opt, None) -> + (try output_stdout (fun () -> lookup_module 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 "script" 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 + +end diff --git a/interpreter/script/runner.mli b/interpreter/script/runner.mli new file mode 100644 index 0000000000..62cf511f08 --- /dev/null +++ b/interpreter/script/runner.mli @@ -0,0 +1,17 @@ +module Make (Engine : Engine.Engine) : +sig + exception Abort of Source.region * string + exception Assert of Source.region * string + exception IO of Source.region * string + + val trace : string -> unit + + val register_instance : Ast.name -> Engine.moduleinst -> unit + val register_virtual : Ast.name -> + (Ast.name -> Types.externtype -> Engine.externinst option) -> + unit + + val run_string : string -> bool + val run_file : string -> bool + val run_stdin : unit -> unit +end From 3dea84829f6bf83c549d2ab488cf15571ee50a51 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 19 Nov 2025 23:31:16 +0100 Subject: [PATCH 2/4] Remove obsolete interface --- interpreter/script/runner.mli | 6 ------ 1 file changed, 6 deletions(-) diff --git a/interpreter/script/runner.mli b/interpreter/script/runner.mli index 62cf511f08..9d44f3a9eb 100644 --- a/interpreter/script/runner.mli +++ b/interpreter/script/runner.mli @@ -1,11 +1,5 @@ module Make (Engine : Engine.Engine) : sig - exception Abort of Source.region * string - exception Assert of Source.region * string - exception IO of Source.region * string - - val trace : string -> unit - val register_instance : Ast.name -> Engine.moduleinst -> unit val register_virtual : Ast.name -> (Ast.name -> Types.externtype -> Engine.externinst option) -> From 27965b7b96cd496a3389972f7091a9f09f07f14e Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Thu, 20 Nov 2025 10:50:10 +0100 Subject: [PATCH 3/4] Rename engine.ml to embed.ml --- interpreter/script/{engine.ml => embed.ml} | 0 interpreter/script/runner.ml | 2 +- interpreter/script/runner.mli | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) rename interpreter/script/{engine.ml => embed.ml} (100%) diff --git a/interpreter/script/engine.ml b/interpreter/script/embed.ml similarity index 100% rename from interpreter/script/engine.ml rename to interpreter/script/embed.ml diff --git a/interpreter/script/runner.ml b/interpreter/script/runner.ml index a598105283..baca39d315 100644 --- a/interpreter/script/runner.ml +++ b/interpreter/script/runner.ml @@ -1,4 +1,4 @@ -module Make (Engine : Engine.Engine) = +module Make (Engine : Embed.Engine) = struct open Script diff --git a/interpreter/script/runner.mli b/interpreter/script/runner.mli index 9d44f3a9eb..fb16d3330a 100644 --- a/interpreter/script/runner.mli +++ b/interpreter/script/runner.mli @@ -1,4 +1,4 @@ -module Make (Engine : Engine.Engine) : +module Make (Engine : Embed.Engine) : sig val register_instance : Ast.name -> Engine.moduleinst -> unit val register_virtual : Ast.name -> From 9a22d1108034c371a69eb8eef95c8b2ca06f337a Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Sat, 22 Nov 2025 09:20:07 +0100 Subject: [PATCH 4/4] Avoid open --- interpreter/script/runner.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/interpreter/script/runner.ml b/interpreter/script/runner.ml index baca39d315..b5af67454b 100644 --- a/interpreter/script/runner.ml +++ b/interpreter/script/runner.ml @@ -280,14 +280,13 @@ let string_of_results = function | rs -> "[" ^ String.concat " " (List.map string_of_result rs) ^ "]" let rec type_of_result r = - let open Types in match r.it with - | NumResult (NumPat n) -> NumT (Value.type_of_num n.it) - | NumResult (NanPat n) -> NumT (Value.type_of_num n.it) - | VecResult (VecPat v) -> VecT (Value.type_of_vec v) - | RefResult (RefPat r) -> RefT (Value.type_of_ref r.it) - | RefResult (RefTypePat t) -> RefT (NoNull, t) (* assume closed *) - | RefResult (NullPat) -> RefT (Null, ExternHT) + | NumResult (NumPat n) -> Types.NumT (Value.type_of_num n.it) + | NumResult (NanPat n) -> Types.NumT (Value.type_of_num n.it) + | VecResult (VecPat v) -> Types.VecT (Value.type_of_vec v) + | RefResult (RefPat r) -> Types.RefT (Value.type_of_ref r.it) + | RefResult (RefTypePat t) -> Types.(RefT (NoNull, t)) (* assume closed *) + | RefResult (NullPat) -> Types.(RefT (Null, ExternHT)) | EitherResult rs -> let ts = List.map type_of_result rs in List.fold_left (fun t1 t2 -> @@ -296,7 +295,7 @@ let rec type_of_result r = if Match.(top_of_valtype [] t1 = top_of_valtype [] t2) then Match.top_of_valtype [] t1 else - BotT (* should really be Top, but we don't have that :) *) + Types.BotT (* should really be Top, but we don't have that :) *) ) (List.hd ts) ts let print_results rs =