From 6033d6e473f6c7ca4ec92f050ff14d1252e3369e Mon Sep 17 00:00:00 2001 From: redianthus Date: Fri, 6 Mar 2026 14:55:13 +0100 Subject: [PATCH] add haskell subcommand --- doc/src/manpages/owi.md | 4 ++ src/bin/owi.ml | 17 ++++++++ src/cmd/cmd_haskell.ml | 63 ++++++++++++++++++++++++++++++ src/cmd/cmd_haskell.mli | 9 +++++ src/compile/binary_to_text.ml | 14 ++++++- src/compile/rewrite.ml | 17 +++++++- src/dune | 1 + src/interpret/interpret.ml | 15 +++++-- src/ir/binary.ml | 19 ++++++++- src/ir/binary.mli | 11 +++++- src/ir/binary_encoder.ml | 6 ++- src/ir/text.ml | 17 +++++++- src/ir/text.mli | 9 ++++- src/owi.ml | 1 + src/owi.mli | 26 +++++++++++- src/parser/binary_parser.ml | 36 +++++++++++------ src/validate/binary_validate.ml | 13 ++++-- test/cram/haskell/simple.t/main.hs | 2 + test/cram/haskell/simple.t/run.t | 3 ++ test/cram/help/help.t | 4 ++ test/cram/script/gc.t | 8 +--- 21 files changed, 259 insertions(+), 36 deletions(-) create mode 100644 src/cmd/cmd_haskell.ml create mode 100644 src/cmd/cmd_haskell.mli create mode 100644 test/cram/haskell/simple.t/main.hs create mode 100644 test/cram/haskell/simple.t/run.t diff --git a/doc/src/manpages/owi.md b/doc/src/manpages/owi.md index f594dde82..d5939b369 100644 --- a/doc/src/manpages/owi.md +++ b/doc/src/manpages/owi.md @@ -24,6 +24,10 @@ COMMANDS fuzz [OPTION]… FILE Run the fuzzer + haskell [OPTION]… FILE… + Compile a Haskell file to Wasm and run the symbolic interpreter on + it + instrument COMMAND … Instrument a program in various ways diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 9423b9d9c..3f3a8a76a 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -425,6 +425,22 @@ let fuzz_cmd = and+ source_file in Cmd_fuzz.cmd ~rounds ~seed ~source_file ~timeout ~timeout_instr ~unsafe +(* owi haskell *) + +let haskell_info = + let doc = + "Compile a Haskell file to Wasm and run the symbolic interpreter on it" + in + let man = [] @ shared_man in + Cmd.info "haskell" ~version ~doc ~sdocs ~man + +let haskell_cmd = + let+ files + and+ out_file + and+ () = setup_log + and+ symbolic_parameters = symbolic_parameters (Some "_start") in + Cmd_haskell.cmd ~symbolic_parameters ~files ~out_file + (* owi instrument *) let instrument_info = @@ -683,6 +699,7 @@ let cli = ; Cmd.v fuzz_info fuzz_cmd ; Cmd.group instrument_info [ Cmd.v instrument_label_info instrument_label_cmd ] + ; Cmd.v haskell_info haskell_cmd ; Cmd.v iso_info iso_cmd ; Cmd.v replay_info replay_cmd ; Cmd.v run_info run_cmd diff --git a/src/cmd/cmd_haskell.ml b/src/cmd/cmd_haskell.ml new file mode 100644 index 000000000..40c92ef85 --- /dev/null +++ b/src/cmd/cmd_haskell.ml @@ -0,0 +1,63 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + +open Bos +open Syntax + +let compile ~workspace ~out_file (files : Fpath.t list) : Fpath.t Result.t = + let* haskell_bin = + let name = "wasm32-wasi-ghc" in + match OS.Cmd.resolve @@ Cmd.v name with + | Error _ -> + Fmt.error_msg + "The `%s` binary was not found, please make sure it is in your path." + name + | Ok _ as ok -> ok + in + + let out = Option.value ~default:Fpath.(workspace / "out.wasm") out_file in + let haskell : Cmd.t = + Cmd.( + haskell_bin + (* output and input *) + % "-o" + % p out + %% Cmd.of_list (List.map p files) + (* % p libhaskell *) ) + in + + let err = + match Logs.Src.level Log.main_src with + | Some (Logs.Debug | Logs.Info) -> OS.Cmd.err_run_out + | None | Some _ -> OS.Cmd.err_null + in + + let+ () = + Log.bench_fn "compiling time" @@ fun () -> + match OS.Cmd.run ~err haskell with + | Ok _ as v -> v + | Error (`Msg e) -> + Log.debug (fun m -> m "haskell failed: %s" e); + Fmt.error_msg + "haskell failed: run with -vv to get the full error message if it was \ + not displayed above" + in + + out + +let cmd ~(symbolic_parameters : Symbolic_parameters.t) ~files ~out_file : + unit Result.t = + let* workspace = + match symbolic_parameters.workspace with + | Some path -> Ok path + | None -> OS.Dir.tmp "cmd_haskell_%s" + in + let* _did_create : bool = OS.Dir.create workspace in + + let* source_file = compile ~workspace ~out_file files in + let workspace = Some workspace in + + let parameters = { symbolic_parameters with workspace } in + + Cmd_sym.cmd ~parameters ~source_file diff --git a/src/cmd/cmd_haskell.mli b/src/cmd/cmd_haskell.mli new file mode 100644 index 000000000..e95076f63 --- /dev/null +++ b/src/cmd/cmd_haskell.mli @@ -0,0 +1,9 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + +val cmd : + symbolic_parameters:Symbolic_parameters.t + -> files:Fpath.t list + -> out_file:Fpath.t option + -> unit Result.t diff --git a/src/compile/binary_to_text.ml b/src/compile/binary_to_text.ml index d2c42aaf3..a73589aa8 100644 --- a/src/compile/binary_to_text.ml +++ b/src/compile/binary_to_text.ml @@ -232,6 +232,18 @@ let convert_f64_instr : Binary.f64_instr -> Text.f64_instr = function let memarg = convert_memarg memarg in Store (indice, memarg) +let convert_v128_instr : Binary.v128_instr -> Text.v128_instr = function + | Const n -> Const n + | And -> And + | Load (indice, memarg) -> + let indice = convert_indice indice in + let memarg = convert_memarg memarg in + Load (indice, memarg) + | Store (indice, memarg) -> + let indice = convert_indice indice in + let memarg = convert_memarg memarg in + Store (indice, memarg) + let convert_ref_instr : Binary.ref_instr -> Text.ref_instr = function | Null heap_type -> Null (convert_heap_type heap_type) | Is_null -> Is_null @@ -345,7 +357,7 @@ let rec convert_instr : Binary.instr -> Text.instr = function | I64 i -> Text.I64 (convert_i64_instr i) | F32 i -> Text.F32 (convert_f32_instr i) | F64 i -> Text.F64 (convert_f64_instr i) - | V128 i -> Text.V128 i + | V128 i -> Text.V128 (convert_v128_instr i) | I8x16 i -> Text.I8x16 i | I16x8 i -> Text.I16x8 i | I32x4 i -> Text.I32x4 i diff --git a/src/compile/rewrite.ml b/src/compile/rewrite.ml index acafee444..0a31b4a6d 100644 --- a/src/compile/rewrite.ml +++ b/src/compile/rewrite.ml @@ -273,6 +273,19 @@ let rewrite_f64_instr assigned : Text.f64_instr -> Binary.f64_instr Result.t = let+ indice = Assigned.find_memory assigned indice in (Store (indice, memarg) : Binary.f64_instr) +let rewrite_v128_instr assigned : Text.v128_instr -> Binary.v128_instr Result.t + = function + | Const f -> Ok (Const f : Binary.v128_instr) + | And -> Ok And + | Load (indice, memarg) -> + let* memarg = rewrite_memarg memarg in + let+ indice = Assigned.find_memory assigned indice in + (Load (indice, memarg) : Binary.v128_instr) + | Store (indice, memarg) -> + let* memarg = rewrite_memarg memarg in + let+ indice = Assigned.find_memory assigned indice in + (Store (indice, memarg) : Binary.v128_instr) + let rewrite_ref_instr assigned : Text.ref_instr -> Binary.ref_instr Result.t = function | Null heap_type -> @@ -458,7 +471,9 @@ let rewrite_expr (assigned : Assigned.t) (locals : Text.param list) | F64 i -> let+ i = rewrite_f64_instr assigned i in Binary.F64 i - | V128 i -> Ok (Binary.V128 i) + | V128 i -> + let+ i = rewrite_v128_instr assigned i in + Binary.V128 i | I8x16 i -> Ok (Binary.I8x16 i) | I16x8 i -> Ok (Binary.I16x8 i) | I32x4 i -> Ok (Binary.I32x4 i) diff --git a/src/dune b/src/dune index d61cf8ae2..de33545ff 100644 --- a/src/dune +++ b/src/dune @@ -22,6 +22,7 @@ cmd_cpp cmd_fmt cmd_fuzz + cmd_haskell cmd_instrument_label cmd_iso cmd_replay diff --git a/src/interpret/interpret.ml b/src/interpret/interpret.ml index 667525009..ed8206168 100644 --- a/src/interpret/interpret.ml +++ b/src/interpret/interpret.ml @@ -736,14 +736,19 @@ struct let+ () = Memory.store_64 mem ~addr (F64.to_bits n) in stack - let exec_v128_instr stack : Text.v128_instr -> _ = function + let exec_v128_instr stack : Binary.v128_instr -> _ = function | Const n -> Stack.push_concrete_v128 stack n + | And | Load _ | Store _ -> raise @@ Failure "todo" let exec_i8x16_instr _stack : Text.i8x16_instr -> _ = function - | _ -> (* TODO *) assert false + | _ -> + (* TODO *) + raise @@ Failure "todo" let exec_i16x8_instr _stack : Text.i16x8_instr -> _ = function - | _ -> (* TODO *) assert false + | _ -> + (* TODO *) + raise @@ Failure "todo" let exec_i32x4_instr stack : Text.i32x4_instr -> _ = function | Add -> @@ -764,6 +769,7 @@ struct let c = I32.sub c1 c2 in let d = I32.sub d1 d2 in Stack.push_v128 stack (V128.of_i32x4 a b c d) + | Mul -> raise @@ Failure "todo" let exec_i64x2_instr stack : Text.i64x2_instr -> _ = function | Add -> @@ -780,6 +786,7 @@ struct let a = I64.sub a1 a2 in let b = I64.sub b1 b2 in Stack.push_v128 stack (V128.of_i64x2 a b) + | Mul -> raise @@ Failure "todo" let exec_ref_instr env stack : Binary.ref_instr -> _ = function | Null t -> Stack.push_ref stack (Ref.null t) |> Choice.return @@ -1268,7 +1275,7 @@ struct let call_ref ~return:_ (_state : State.exec_state) _typ_i = (* TODO *) - assert false + raise @@ Failure "TODO" (* let fun_ref, stack = Stack.pop_as_ref state.stack in *) (* let state = { state with stack } in *) (* let func = *) diff --git a/src/ir/binary.ml b/src/ir/binary.ml index b1032bc2a..2e53b6d3e 100644 --- a/src/ir/binary.ml +++ b/src/ir/binary.ml @@ -536,6 +536,21 @@ let pp_f64_instr ppf = function | Store (indice, memarg) -> pf ppf "f64.store%a%a" pp_indice_not0 indice pp_memarg memarg +(** V128 instructions *) +type v128_instr = + | Const of Concrete_v128.t + | And + | Load of (indice * memarg) + | Store of (indice * memarg) + +let pp_v128_instr ppf = function + | Const n -> pf ppf "v128.const %a" Concrete_v128.pp n + | And -> pf ppf "v128.and" + | Load (indice, memarg) -> + pf ppf "v128.load%a%a" pp_indice_not0 indice pp_memarg memarg + | Store (indice, memarg) -> + pf ppf "v128.store%a%a" pp_indice_not0 indice pp_memarg memarg + (** Reference instructions *) type ref_instr = | Null of heap_type @@ -686,7 +701,7 @@ type instr = | I64 of i64_instr | F32 of f32_instr | F64 of f64_instr - | V128 of Text.v128_instr + | V128 of v128_instr | I8x16 of Text.i8x16_instr | I16x8 of Text.i16x8_instr | I32x4 of Text.i32x4_instr @@ -735,7 +750,7 @@ let rec pp_instr ~short ppf = function | I64 i -> pp_i64_instr ppf i | F32 i -> pp_f32_instr ppf i | F64 i -> pp_f64_instr ppf i - | V128 i -> Text.pp_v128_instr ppf i + | V128 i -> pp_v128_instr ppf i | I8x16 i -> Text.pp_i8x16_instr ppf i | I16x8 i -> Text.pp_i16x8_instr ppf i | I32x4 i -> Text.pp_i32x4_instr ppf i diff --git a/src/ir/binary.mli b/src/ir/binary.mli index 6a8cd5047..0cf52a4d5 100644 --- a/src/ir/binary.mli +++ b/src/ir/binary.mli @@ -231,6 +231,15 @@ type f64_instr = | Load of indice * memarg | Store of indice * memarg +(** V128 instructions *) +type v128_instr = + | Const of Concrete_v128.t + | And + | Load of (indice * memarg) + | Store of (indice * memarg) + +val pp_v128_instr : v128_instr Fmt.t + (** Reference instructions *) type ref_instr = | Null of heap_type @@ -308,7 +317,7 @@ type instr = | I64 of i64_instr | F32 of f32_instr | F64 of f64_instr - | V128 of Text.v128_instr + | V128 of v128_instr | I8x16 of Text.i8x16_instr | I16x8 of Text.i16x8_instr | I32x4 of Text.i32x4_instr diff --git a/src/ir/binary_encoder.ml b/src/ir/binary_encoder.ml index f6663b2ad..689f08d46 100644 --- a/src/ir/binary_encoder.ml +++ b/src/ir/binary_encoder.ml @@ -472,12 +472,13 @@ let write_f64_instr buf : Binary.f64_instr -> _ = | Reinterpret_i S32 -> (* TODO *) assert false | Reinterpret_i S64 -> add_char '\xBF' -let write_v128_instr buf : Text.v128_instr -> _ = function +let write_v128_instr buf : Binary.v128_instr -> _ = function | Const v -> write_fd buf 12; let a, b = Concrete_v128.to_i64x2 v in write_bytes_8 buf a; write_bytes_8 buf b + | And | Load _ | Store _ -> raise @@ Failure "TODO" let write_i8x16_instr buf : Text.i8x16_instr -> _ = function | Add -> write_fd buf 110 @@ -486,14 +487,17 @@ let write_i8x16_instr buf : Text.i8x16_instr -> _ = function let write_i16x8_instr buf : Text.i16x8_instr -> _ = function | Add -> write_fd buf 142 | Sub -> write_fd buf 145 + | Mul -> raise @@ Failure "TODO" let write_i32x4_instr buf : Text.i32x4_instr -> _ = function | Add -> write_fd buf 174 | Sub -> write_fd buf 177 + | Mul -> raise @@ Failure "TODO" let write_i64x2_instr buf : Text.i64x2_instr -> _ = function | Add -> write_fd buf 206 | Sub -> write_fd buf 209 + | Mul -> raise @@ Failure "TODO" let write_ref_instr buf : Binary.ref_instr -> _ = let add_char c = Buffer.add_char buf c in diff --git a/src/ir/text.ml b/src/ir/text.ml index b0c77b712..0cc34286d 100644 --- a/src/ir/text.ml +++ b/src/ir/text.ml @@ -690,10 +690,19 @@ let pp_f64_instr ppf = function pf ppf "f64.store%a%a" pp_indice_not0 indice pp_memarg memarg (** V128 instructions *) -type v128_instr = Const of Concrete_v128.t +type v128_instr = + | Const of Concrete_v128.t + | And + | Load of (indice * memarg) + | Store of (indice * memarg) let pp_v128_instr ppf = function | Const n -> pf ppf "v128.const %a" Concrete_v128.pp n + | And -> pf ppf "v128.and" + | Load (indice, memarg) -> + pf ppf "v128.load%a%a" pp_indice_not0 indice pp_memarg memarg + | Store (indice, memarg) -> + pf ppf "v128.store%a%a" pp_indice_not0 indice pp_memarg memarg (** I8x16 instructions *) type i8x16_instr = @@ -708,28 +717,34 @@ let pp_i8x16_instr ppf = function type i16x8_instr = | Add | Sub + | Mul let pp_i16x8_instr ppf = function | Add -> pf ppf "i16x8.add" | Sub -> pf ppf "i16x8.sub" + | Mul -> pf ppf "i16x8.mul" (* I32x4 instructions *) type i32x4_instr = | Add | Sub + | Mul let pp_i32x4_instr ppf = function | Add -> pf ppf "i32x4.add" | Sub -> pf ppf "i32x4.sub" + | Mul -> pf ppf "i32x4.mul" (** I64x2 instructions *) type i64x2_instr = | Add | Sub + | Mul let pp_i64x2_instr ppf = function | Add -> pf ppf "i64x2.add" | Sub -> pf ppf "i64x2.sub" + | Mul -> pf ppf "i64x2.mul" (** Reference instructions *) type ref_instr = diff --git a/src/ir/text.mli b/src/ir/text.mli index 9697863f2..5f139f137 100644 --- a/src/ir/text.mli +++ b/src/ir/text.mli @@ -317,7 +317,11 @@ type f64_instr = | Store of indice * memarg (** V128 instructions *) -type v128_instr = Const of Concrete_v128.t +type v128_instr = + | Const of Concrete_v128.t + | And + | Load of (indice * memarg) + | Store of (indice * memarg) val pp_v128_instr : v128_instr Fmt.t @@ -332,6 +336,7 @@ val pp_i8x16_instr : i8x16_instr Fmt.t type i16x8_instr = | Add | Sub + | Mul val pp_i16x8_instr : i16x8_instr Fmt.t @@ -339,6 +344,7 @@ val pp_i16x8_instr : i16x8_instr Fmt.t type i32x4_instr = | Add | Sub + | Mul val pp_i32x4_instr : i32x4_instr Fmt.t @@ -346,6 +352,7 @@ val pp_i32x4_instr : i32x4_instr Fmt.t type i64x2_instr = | Add | Sub + | Mul val pp_i64x2_instr : i64x2_instr Fmt.t diff --git a/src/owi.ml b/src/owi.ml index 6a526748f..f27fb4221 100644 --- a/src/owi.ml +++ b/src/owi.ml @@ -9,6 +9,7 @@ module Cmd_cfg = Cmd_cfg module Cmd_cpp = Cmd_cpp module Cmd_fmt = Cmd_fmt module Cmd_fuzz = Cmd_fuzz +module Cmd_haskell = Cmd_haskell module Cmd_instrument_label = Cmd_instrument_label module Cmd_iso = Cmd_iso module Cmd_replay = Cmd_replay diff --git a/src/owi.mli b/src/owi.mli index 498ceba65..7340a6334 100644 --- a/src/owi.mli +++ b/src/owi.mli @@ -457,7 +457,11 @@ module Text : sig | Store of indice * memarg (** V128 instructions *) - type v128_instr = Const of Concrete_v128.t + type v128_instr = + | Const of Concrete_v128.t + | And + | Load of (indice * memarg) + | Store of (indice * memarg) (** I8x16 instructions *) type i8x16_instr = @@ -468,16 +472,19 @@ module Text : sig type i16x8_instr = | Add | Sub + | Mul (* I32x4 instructions *) type i32x4_instr = | Add | Sub + | Mul (** I64x2 instructions *) type i64x2_instr = | Add | Sub + | Mul (** Reference instructions *) type ref_instr = @@ -970,6 +977,13 @@ module Binary : sig | Load of indice * memarg | Store of indice * memarg + (** V128 instructions *) + type v128_instr = + | Const of Concrete_v128.t + | And + | Load of (indice * memarg) + | Store of (indice * memarg) + (** Reference instructions *) type ref_instr = | Null of heap_type @@ -1047,7 +1061,7 @@ module Binary : sig | I64 of i64_instr | F32 of f32_instr | F64 of f64_instr - | V128 of Text.v128_instr + | V128 of v128_instr | I8x16 of Text.i8x16_instr | I16x8 of Text.i16x8_instr | I32x4 of Text.i32x4_instr @@ -1704,6 +1718,14 @@ module Cmd_fuzz : sig -> unit Result.t end +module Cmd_haskell : sig + val cmd : + symbolic_parameters:Symbolic_parameters.t + -> files:Fpath.t list + -> out_file:Fpath.t option + -> unit Result.t +end + module Cmd_instrument_label : sig val cmd : unsafe:bool diff --git a/src/parser/binary_parser.ml b/src/parser/binary_parser.ml index 7cfaf53ff..8c189292b 100644 --- a/src/parser/binary_parser.ml +++ b/src/parser/binary_parser.ml @@ -501,12 +501,18 @@ let read_FC input = | 17 -> let+ tableidx, input = read_indice input in (Table (Fill tableidx), input) - | i -> parse_fail "illegal opcode (1) %i" i + | i -> parse_fail "illegal opcode (read_FC) %i" i let read_FD input = let* i, input = read_U32 input in match i with - | 12 -> + | 0x00 -> + let+ idx, memarg, input = read_memarg 128 input in + (V128 (Load (idx, memarg)), input) + | 0x0b -> + let+ idx, memarg, input = read_memarg 128 input in + (V128 (Store (idx, memarg)), input) + | 0x0C -> let* data = Input.sub_prefix 16 input in let+ input = Input.sub_suffix 16 input in let data = Input.as_string data in @@ -514,15 +520,19 @@ let read_FD input = let low = String.get_int64_le data 8 in let v128 = Concrete_v128.of_i64x2 high low in (V128 (Const v128), input) - | 110 -> Ok (I8x16 Add, input) - | 113 -> Ok (I8x16 Sub, input) - | 142 -> Ok (I16x8 Add, input) - | 145 -> Ok (I16x8 Sub, input) - | 174 -> Ok (I32x4 Add, input) - | 177 -> Ok (I32x4 Sub, input) - | 206 -> Ok (I64x2 Add, input) - | 209 -> Ok (I64x2 Sub, input) - | i -> parse_fail "illegal opcode (1) %i" i + | 0x4E -> Ok (V128 And, input) + | 0x6E -> Ok (I8x16 Add, input) + | 0x71 -> Ok (I8x16 Sub, input) + | 0x8E -> Ok (I16x8 Add, input) + | 0x91 -> Ok (I16x8 Sub, input) + | 0x95 -> Ok (I16x8 Mul, input) + | 0xAE -> Ok (I32x4 Add, input) + | 0xB1 -> Ok (I32x4 Sub, input) + | 0xB5 -> Ok (I32x4 Mul, input) + | 0xCE -> Ok (I64x2 Add, input) + | 0xD1 -> Ok (I64x2 Sub, input) + | 0xD5 -> Ok (I64x2 Mul, input) + | i -> parse_fail "illegal opcode (read_FD) 0x%02X" i let block_type_of_type_def ty = (* TODO: this is a ugly hack, it is necessary for now and should be removed at some point... *) @@ -867,7 +877,9 @@ let rec read_instr types input = | '\xFB' -> read_FB input | '\xFC' -> read_FC input | '\xFD' -> read_FD input - | c -> parse_fail "illegal opcode %2x" (Char.code c) + | c -> + Log.debug (fun m -> m "while parsing in read_instr"); + parse_fail "illegal opcode %2x" (Char.code c) and read_expr types input = let rec aux acc input = diff --git a/src/validate/binary_validate.ml b/src/validate/binary_validate.ml index 5fd5302ae..2b89c6454 100644 --- a/src/validate/binary_validate.ml +++ b/src/validate/binary_validate.ml @@ -587,10 +587,15 @@ let typecheck_f64_instr (env : Env.t) stack = function let+ stack = Stack.push [ f64 ] stack in (env, stack) -let typecheck_v128_instr env stack : Text.v128_instr -> _ = function +let typecheck_v128_instr (env : Env.t) stack : Binary.v128_instr -> _ = function | Const _ -> let+ stack = Stack.push [ v128 ] stack in (env, stack) + | And -> + let* stack = Stack.pop env.modul [ v128; v128 ] stack in + let+ stack = Stack.push [ v128 ] stack in + (env, stack) + | _ -> raise @@ Failure "TODO" let typecheck_i8x16_instr (env : Env.t) stack = function | (Add : Text.i8x16_instr) | Sub -> @@ -599,19 +604,19 @@ let typecheck_i8x16_instr (env : Env.t) stack = function (env, stack) let typecheck_i16x8_instr (env : Env.t) stack = function - | (Add : Text.i16x8_instr) | Sub -> + | (Add : Text.i16x8_instr) | Sub | Mul -> let* stack = Stack.pop env.modul [ v128; v128 ] stack in let+ stack = Stack.push [ v128 ] stack in (env, stack) let typecheck_i32x4_instr (env : Env.t) stack = function - | (Add : Text.i32x4_instr) | Sub -> + | (Add : Text.i32x4_instr) | Sub | Mul -> let* stack = Stack.pop env.modul [ v128; v128 ] stack in let+ stack = Stack.push [ v128 ] stack in (env, stack) let typecheck_i64x2_instr (env : Env.t) stack = function - | (Add : Text.i64x2_instr) | Sub -> + | (Add : Text.i64x2_instr) | Sub | Mul -> let* stack = Stack.pop env.modul [ v128; v128 ] stack in let+ stack = Stack.push [ v128 ] stack in (env, stack) diff --git a/test/cram/haskell/simple.t/main.hs b/test/cram/haskell/simple.t/main.hs new file mode 100644 index 000000000..06931f30e --- /dev/null +++ b/test/cram/haskell/simple.t/main.hs @@ -0,0 +1,2 @@ +main :: IO () +main = print (1 `div` 0) diff --git a/test/cram/haskell/simple.t/run.t b/test/cram/haskell/simple.t/run.t new file mode 100644 index 000000000..e725f1184 --- /dev/null +++ b/test/cram/haskell/simple.t/run.t @@ -0,0 +1,3 @@ + $ owi haskell main.hs + owi: [ERROR] The `wasm32-wasi-ghc` binary was not found, please make sure it is in your path. + [26] diff --git a/test/cram/help/help.t b/test/cram/help/help.t index d1be3fb0c..3eaf27674 100644 --- a/test/cram/help/help.t +++ b/test/cram/help/help.t @@ -22,6 +22,10 @@ no subcommand should print help fuzz [OPTION]… FILE Run the fuzzer + haskell [OPTION]… FILE… + Compile a Haskell file to Wasm and run the symbolic interpreter on + it + instrument COMMAND … Instrument a program in various ways diff --git a/test/cram/script/gc.t b/test/cram/script/gc.t index ca64b7ac1..edbc40bee 100644 --- a/test/cram/script/gc.t +++ b/test/cram/script/gc.t @@ -19,7 +19,7 @@ owi: [ERROR] unexpected token "$l" in line 30, character 18-20 [40] $ owi script --no-exhaustion reference/call_ref.wast 2>&1 | grep -oE "Failure.*" - [1] + Failure("TODO") $ owi script --no-exhaustion reference/extern.wast 2>&1 | grep -oE "Failure.*" Failure("Assigned: unimplemented for rec and sub types") $ owi script --no-exhaustion reference/i31.wast 2>&1 | grep -oE "Failure.*" @@ -30,11 +30,7 @@ $ owi script --no-exhaustion reference/ref_test.wast 2>&1 | grep -oE "Failure.*" Failure("Assigned: unimplemented for rec and sub types") $ owi script --no-exhaustion reference/return_call_ref.wast 2>&1 | grep -oE ".*Assertion failed" - File "src/interpret/interpret.ml", line 1271, characters 4-10: Assertion failed - $ owi script --no-exhaustion reference/struct.wast 2>&1 | grep -oE ".*Failure.*" - Failure("Assigned: unimplemented for rec and sub types") - $ owi script --no-exhaustion reference/type-subtyping.wast 2>&1 | grep -oE ".*Failure.*" - Failure("Assigned: unimplemented for rec and sub types") + [1] $ owi script --no-exhaustion reference/struct.wast 2>&1 | grep -oE "Failure.*" Failure("Assigned: unimplemented for rec and sub types") $ owi script --no-exhaustion reference/type-subtyping.wast 2>&1 | grep -oE "Failure.*"