interpreter/script/runner.ml

module Make (Engine : Embed.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 =
  match r.it with
  | 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 ->
      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
        Types.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