text.ml — Coverage report

(* SPDX-License-Identifier: AGPL-3.0-or-later *)
(* Copyright © 2021-2026 OCamlPro *)
(* Written by the Owi programmers *)

open Fmt

exception Parse_fail of string

let sp ppf () = Fmt.char ppf ' '

(* identifiers *)

type indice =
  | Text of string
  | Raw of int

let pp_id ppf id = pf ppf "$%s" id

let pp_id_opt ppf = function None -> () | Some i -> pf ppf " %a" pp_id i

let pp_indice ppf = function Raw u -> int ppf u | Text i -> pp_id ppf i

let pp_indice_not0 ppf = function
  | Text i -> pp_id ppf i
  | Raw 0 -> ()
  | Raw u -> Fmt.pf ppf " %d" u

let pp_indice_opt ppf = function None -> () | Some i -> pp_indice ppf i

let compare_indice id1 id2 =
  match (id1, id2) with
  | Text s1, Text s2 -> String.compare s1 s2
  | Raw i1, Raw i2 -> Int.compare i1 i2
  | Text _, Raw _ -> 1
  | Raw _, Text _ -> -1

type nonrec num_type =
  | I32
  | I64
  | F32
  | F64
  | V128

let pp_num_type ppf = function
  | I32 -> pf ppf "i32"
  | I64 -> pf ppf "i64"
  | F32 -> pf ppf "f32"
  | F64 -> pf ppf "f64"
  | V128 -> pf ppf "v128"

let num_type_eq t1 t2 =
  match (t1, t2) with
  | I32, I32 | I64, I64 | F32, F32 | F64, F64 | V128, V128 -> true
  | (I32 | I64 | F32 | F64 | V128), _ -> false

let compare_num_type t1 t2 =
  let to_int = function
    | I32 -> 0
    | I64 -> 1
    | F32 -> 2
    | F64 -> 3
    | V128 -> 4
  in
  compare (to_int t1) (to_int t2)

type nullable =
  | No_null
  | Null

type nonrec mut =
  | Const
  | Var

let is_mut = function Const -> false | Var -> true

let pp_mut fmt = function
  | Const -> Fmt.pf fmt "const"
  | Var -> Fmt.pf fmt "var"

type nonrec nn =
  | S32
  | S64

let pp_nn ppf = function S32 -> pf ppf "32" | S64 -> pf ppf "64"

type nonrec fshape =
  | F32x4
  | F64x8

type nonrec memarg =
  { offset : string option
  ; align : string option
  }

let pp_memarg ppf { offset; align } =
  match (offset, align) with
  | None, None -> ()
  | Some offset, Some align -> Fmt.pf ppf " offset=%s align=%s" offset align
  | Some offset, None -> Fmt.pf ppf " offset=%s" offset
  | None, Some align -> Fmt.pf ppf " align=%s" align

type nonrec limits =
  { is_i64 : bool
  ; min : string
  ; max : string option
  }

let pp_addr_type ppf is_i64 = if is_i64 then Fmt.pf ppf "i64 "

let pp_limits ppf { is_i64; min; max } =
  match max with
  | None -> pf ppf "%a%s" pp_addr_type is_i64 min
  | Some max -> pf ppf "%a%s %s" pp_addr_type is_i64 min max

(** Structure *)

(** Types *)

type heap_type =
  | TypeUse of indice
  (* abs_heap_type *)
  | Any_ht
  | Eq_ht
  | I31_ht
  | Struct_ht
  | Array_ht
  | None_ht
  | Func_ht
  | NoFunc_ht
  | Exn_ht
  | NoExn_ht
  | Extern_ht
  | NoExtern_ht

let pp_heap_type fmt = function
  | TypeUse id -> pf fmt "%a" pp_indice id
  | Any_ht -> pf fmt "any"
  | Eq_ht -> pf fmt "eq"
  | I31_ht -> pf fmt "i31"
  | Struct_ht -> pf fmt "struct"
  | Array_ht -> pf fmt "array"
  | None_ht -> pf fmt "none"
  | Func_ht -> pf fmt "func"
  | NoFunc_ht -> pf fmt "nofunc"
  | Exn_ht -> pf fmt "exn"
  | NoExn_ht -> pf fmt "noexn"
  | Extern_ht -> pf fmt "extern"
  | NoExtern_ht -> pf fmt "noextern"

let heap_type_eq t1 t2 =
  match (t1, t2) with
  | Func_ht, Func_ht
  | Extern_ht, Extern_ht
  | Any_ht, Any_ht
  | Eq_ht, Eq_ht
  | I31_ht, I31_ht
  | Struct_ht, Struct_ht
  | Array_ht, Array_ht
  | None_ht, None_ht
  | NoFunc_ht, NoFunc_ht
  | Exn_ht, Exn_ht
  | NoExn_ht, NoExn_ht
  | NoExtern_ht, NoExtern_ht ->
    true
  | TypeUse id1, TypeUse id2 -> compare_indice id1 id2 = 0
  | _, _ -> false

let is_subtype_heap_type t1 t2 =
  heap_type_eq t1 t2
  ||
  match (t1, t2) with
  | None_ht, (I31_ht | Struct_ht | Array_ht | Eq_ht | Any_ht)
  | (I31_ht | Struct_ht | Array_ht), (Eq_ht | Any_ht)
  | Eq_ht, Any_ht
  | NoFunc_ht, Func_ht
  | NoExtern_ht, Extern_ht
  | NoExn_ht, Exn_ht
  | TypeUse _, Func_ht ->
    true
  | _ -> false

let compare_heap_type t1 t2 =
  (* TODO: this is wrong *)
  match (t1, t2) with
  | Any_ht, Any_ht
  | Eq_ht, Eq_ht
  | I31_ht, I31_ht
  | Struct_ht, Struct_ht
  | Array_ht, Array_ht
  | None_ht, None_ht
  | Func_ht, Func_ht
  | NoFunc_ht, NoFunc_ht
  | Exn_ht, Exn_ht
  | NoExn_ht, NoExn_ht
  | Extern_ht, Extern_ht
  | NoExtern_ht, NoExtern_ht ->
    0
  | TypeUse id1, TypeUse id2 -> compare_indice id1 id2
  | TypeUse _, _ -> 1
  | _, TypeUse _ -> -1
  | Any_ht, _ -> 1
  | _, Any_ht -> -1
  | Eq_ht, _ -> 1
  | _, Eq_ht -> -1
  | I31_ht, _ -> 1
  | _, I31_ht -> -1
  | Struct_ht, _ -> 1
  | _, Struct_ht -> -1
  | Array_ht, _ -> 1
  | _, Array_ht -> -1
  | None_ht, _ -> 1
  | _, None_ht -> -1
  | Func_ht, _ -> 1
  | _, Func_ht -> -1
  | NoFunc_ht, _ -> 1
  | _, NoFunc_ht -> -1
  | Exn_ht, _ -> 1
  | _, Exn_ht -> -1
  | NoExn_ht, _ -> 1
  | _, NoExn_ht -> -1
  | Extern_ht, _ -> 1
  | _, Extern_ht -> -1

type nonrec ref_type = nullable * heap_type

let pp_ref_type ppf (n, ht) =
  match n with
  | No_null -> pf ppf "(ref %a)" pp_heap_type ht
  | Null -> pf ppf "(ref null %a)" pp_heap_type ht

let ref_type_eq t1 t2 =
  match (t1, t2) with
  | (Null, t1), (Null, t2) | (No_null, t1), (No_null, t2) -> heap_type_eq t1 t2
  | _ -> false

let is_subtype_ref_type t1 t2 =
  match (t1, t2) with
  | (No_null, ht1), (Null, ht2) when is_subtype_heap_type ht1 ht2 -> true
  | (No_null, TypeUse _), (Null, Func_ht)
  | (No_null, TypeUse _), (No_null, Func_ht)
  | (Null, TypeUse _), (Null, Func_ht) ->
    true
  | (Null, t1), (Null, t2) | (No_null, t1), (No_null, t2) ->
    is_subtype_heap_type t1 t2
  | _ -> false

let compare_nullable n1 n2 =
  match (n1, n2) with
  | Null, Null | No_null, No_null -> 0
  | Null, No_null -> -1
  | No_null, Null -> 1

let compare_ref_type t1 t2 =
  match (t1, t2) with
  | (Null, t1), (Null, t2) | (No_null, t1), (No_null, t2) ->
    compare_heap_type t1 t2
  | (Null, _), (No_null, _) -> -1
  | (No_null, _), (Null, _) -> 1

type nonrec val_type =
  | Num_type of num_type
  | Ref_type of ref_type

let pp_val_type fmt = function
  | Num_type t -> pp_num_type fmt t
  | Ref_type t -> pp_ref_type fmt t

let val_type_eq t1 t2 =
  match (t1, t2) with
  | Num_type t1, Num_type t2 -> num_type_eq t1 t2
  | Ref_type t1, Ref_type t2 -> ref_type_eq t1 t2
  | _, _ -> false

let is_subtype_val_type t1 t2 =
  match (t1, t2) with
  | Num_type t1, Num_type t2 -> num_type_eq t1 t2
  | Ref_type t1, Ref_type t2 -> is_subtype_ref_type t1 t2
  | _, _ -> false

let compare_val_type t1 t2 =
  match (t1, t2) with
  | Num_type t1, Num_type t2 -> compare_num_type t1 t2
  | Ref_type t1, Ref_type t2 -> compare_ref_type t1 t2
  | Num_type _, _ -> 1
  | Ref_type _, _ -> -1

type pack_type =
  | I8
  | I16

type storage_type =
  | Val_type of val_type
  | Pack_type of pack_type

let pp_storage_type fmt = function
  | Val_type vt -> pp_val_type fmt vt
  | Pack_type I8 -> Fmt.pf fmt "i8"
  | Pack_type I16 -> Fmt.pf fmt "i16"

type nonrec param = string option * val_type

let pp_param ppf (id, vt) = pf ppf "(param%a %a)" pp_id_opt id pp_val_type vt

let param_eq (_, t1) (_, t2) = val_type_eq t1 t2

let compare_param (_, t1) (_, t2) = compare_val_type t1 t2

type nonrec param_type = param list

let pp_param_type ppf params = list ~sep:sp pp_param ppf params

let param_type_eq t1 t2 = List.equal param_eq t1 t2

let compare_param_type t1 t2 = List.compare compare_param t1 t2

type nonrec result_type = val_type list

let pp_result_ ppf vt = pf ppf "(result %a)" pp_val_type vt

let pp_result_type ppf results = list ~sep:sp pp_result_ ppf results

let result_type_eq t1 t2 = List.equal val_type_eq t1 t2

let compare_result_type t1 t2 = List.compare compare_val_type t1 t2

(* wrap printer to print a space before a non empty list *)
(* TODO or make it an optional arg of pp_list? *)
let with_space_list printer ppf l =
  match l with [] -> () | _l -> pf ppf " %a" printer l

type nonrec func_type = param_type * result_type

let pp_func_type ppf (params, results) =
  pf ppf "(func%a%a)"
    (with_space_list pp_param_type)
    params
    (with_space_list pp_result_type)
    results

let func_type_eq (pt1, rt1) (pt2, rt2) =
  param_type_eq pt1 pt2 && result_type_eq rt1 rt2

type field_type = mut * storage_type

let pp_field_type fmt (m, st) = Fmt.pf fmt "%a %a" pp_mut m pp_storage_type st

type field = indice option * field_type

let pp_field fmt (id_opt, ft) =
  match id_opt with
  | None -> Fmt.pf fmt "%a" pp_field_type ft
  | Some id -> Fmt.pf fmt "%a %a" pp_indice id pp_field_type ft

type comp_type =
  | Def_struct_t of field list
  | Def_array_t of field_type
  | Def_func_t of func_type

let pp_comp_type fmt = function
  | Def_struct_t fl ->
    Fmt.pf fmt "(struct %a)" (Fmt.list ~sep:Fmt.comma pp_field) fl
  | Def_array_t ft -> Fmt.pf fmt "(array %a)" pp_field_type ft
  | Def_func_t ft -> Fmt.pf fmt "%a" pp_func_type ft
(* TODO: ensure proper printing *)

let storage_type_eq st1 st2 =
  match (st1, st2) with
  | Val_type vt1, Val_type vt2 -> val_type_eq vt1 vt2
  | Pack_type I8, Pack_type I8 -> true
  | Pack_type I16, Pack_type I16 -> true
  | _, _ -> false

let field_type_eq (m1, st1) (m2, st2) =
  let mut_eq =
    match ((m1 : mut), (m2 : mut)) with
    | Const, Const | Var, Var -> true
    | _ -> false
  in
  mut_eq && storage_type_eq st1 st2

let comp_type_eq ct1 ct2 =
  match (ct1, ct2) with
  | Def_struct_t fl1, Def_struct_t fl2 ->
    List.equal (fun (_, ft1) (_, ft2) -> field_type_eq ft1 ft2) fl1 fl2
  | Def_array_t ft1, Def_array_t ft2 -> field_type_eq ft1 ft2
  | Def_func_t ft1, Def_func_t ft2 -> func_type_eq ft1 ft2
  | _, _ -> false

type sub_type =
  { final : bool
  ; ids : indice list
  ; ct : comp_type
  }

let sub_type_eq { final = f1; ct = ct1; _ } { final = f2; ct = ct2; _ } =
  Bool.equal f1 f2 && comp_type_eq ct1 ct2

let pp_sub_type fmt { final; ids; ct } =
  Fmt.pf fmt "%a%a%a"
    (fun fmt b -> if b && not (List.is_empty ids) then Fmt.pf fmt "final ")
    final
    (Fmt.list (fun fmt id -> Fmt.pf fmt "%a " pp_indice id))
    ids pp_comp_type ct

type block_type =
  | Bt_ind of indice
  | Bt_raw of (indice option * func_type)

let pp_block_type ppf = function
  | Bt_ind ind -> pf ppf "(type %a)" pp_indice ind
  | Bt_raw (_ind, (pt, rt)) ->
    pf ppf "%a%a"
      (with_space_list pp_param_type)
      pt
      (with_space_list pp_result_type)
      rt

let pp_block_type_opt ppf = function
  | None -> ()
  | Some bt -> pp_block_type ppf bt

let compare_func_type (pt1, rt1) (pt2, rt2) =
  let pt = compare_param_type pt1 pt2 in
  if pt = 0 then compare_result_type rt1 rt2 else pt

(** I32 instructions *)

type i32_instr =
  | Const of Int32.t
  | Clz
  | Ctz
  | Popcnt
  | Add
  | Sub
  | Mul
  | Div_s
  | Div_u
  | Rem_s
  | Rem_u
  | And
  | Or
  | Xor
  | Shl
  | Shr_s
  | Shr_u
  | Rotl
  | Rotr
  | Eqz
  | Eq
  | Ne
  | Lt_s
  | Lt_u
  | Gt_s
  | Gt_u
  | Le_s
  | Le_u
  | Ge_s
  | Ge_u
  | Extend8_s
  | Extend16_s
  | Wrap_i64
  | Trunc_f_s of nn
  | Trunc_f_u of nn
  | Trunc_sat_f_s of nn
  | Trunc_sat_f_u of nn
  | Reinterpret_f of nn
  | Load of indice * memarg
  | Load8_s of indice * memarg
  | Load8_u of indice * memarg
  | Load16_s of indice * memarg
  | Load16_u of indice * memarg
  | Store of indice * memarg
  | Store8 of indice * memarg
  | Store16 of indice * memarg

let pp_i32_instr ppf = function
  | Const i -> pf ppf "i32.const %ld" i
  | Clz -> pf ppf "i32.clz"
  | Ctz -> pf ppf "i32.ctz"
  | Popcnt -> pf ppf "i32.popcnt"
  | Add -> pf ppf "i32.add"
  | Sub -> pf ppf "i32.sub"
  | Mul -> pf ppf "i32.mul"
  | Div_s -> pf ppf "i32.div_s"
  | Div_u -> pf ppf "i32.div_u"
  | Rem_s -> pf ppf "i32.rem_s"
  | Rem_u -> pf ppf "i32.rem_u"
  | And -> pf ppf "i32.and"
  | Or -> pf ppf "i32.or"
  | Xor -> pf ppf "i32.xor"
  | Shl -> pf ppf "i32.shl"
  | Shr_s -> pf ppf "i32.shr_s"
  | Shr_u -> pf ppf "i32.shr_u"
  | Rotl -> pf ppf "i32.rotl"
  | Rotr -> pf ppf "i32.rotr"
  | Eqz -> pf ppf "i32.eqz"
  | Eq -> pf ppf "i32.eq"
  | Ne -> pf ppf "i32.ne"
  | Lt_s -> pf ppf "i32.lt_s"
  | Lt_u -> pf ppf "i32.lt_u"
  | Gt_s -> pf ppf "i32.gt_s"
  | Gt_u -> pf ppf "i32.gt_u"
  | Le_s -> pf ppf "i32.le_s"
  | Le_u -> pf ppf "i32.le_u"
  | Ge_s -> pf ppf "i32.ge_s"
  | Ge_u -> pf ppf "i32.ge_u"
  | Extend8_s -> pf ppf "i32.extend8_s"
  | Extend16_s -> pf ppf "i32.extend16_s"
  | Wrap_i64 -> pf ppf "i32.wrap_i64"
  | Trunc_f_s nn -> pf ppf "i32.trunc_f%a_s" pp_nn nn
  | Trunc_f_u nn -> pf ppf "i32.trunc_f%a_u" pp_nn nn
  | Trunc_sat_f_s nn -> pf ppf "i32.truc_sat_f%a_s" pp_nn nn
  | Trunc_sat_f_u nn -> pf ppf "i32.truc_sat_f%a_u" pp_nn nn
  | Reinterpret_f nn -> pf ppf "i32.reinterpret_f%a" pp_nn nn
  | Load (indice, memarg) ->
    pf ppf "i32.load%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_s (indice, memarg) ->
    pf ppf "i32.load8_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_u (indice, memarg) ->
    pf ppf "i32.load8_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_s (indice, memarg) ->
    pf ppf "i32.load16_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_u (indice, memarg) ->
    pf ppf "i32.load16_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store (indice, memarg) ->
    pf ppf "i32.store%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store8 (indice, memarg) ->
    pf ppf "i32.store8%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store16 (indice, memarg) ->
    pf ppf "i32.store16%a%a" pp_indice_not0 indice pp_memarg memarg

(** I64 instructions *)

type i64_instr =
  | Const of Int64.t
  | Clz
  | Ctz
  | Popcnt
  | Add
  | Sub
  | Mul
  | Div_s
  | Div_u
  | Rem_s
  | Rem_u
  | And
  | Or
  | Xor
  | Shl
  | Shr_s
  | Shr_u
  | Rotl
  | Rotr
  | Eqz
  | Eq
  | Ne
  | Lt_s
  | Lt_u
  | Gt_s
  | Gt_u
  | Le_s
  | Le_u
  | Ge_s
  | Ge_u
  | Extend8_s
  | Extend16_s
  | Extend32_s
  | Extend_i32_s
  | Extend_i32_u
  | Trunc_f_s of nn
  | Trunc_f_u of nn
  | Trunc_sat_f_s of nn
  | Trunc_sat_f_u of nn
  | Reinterpret_f of nn
  | Load of indice * memarg
  | Load8_s of indice * memarg
  | Load8_u of indice * memarg
  | Load16_s of indice * memarg
  | Load16_u of indice * memarg
  | Load32_s of indice * memarg
  | Load32_u of indice * memarg
  | Store of indice * memarg
  | Store8 of indice * memarg
  | Store16 of indice * memarg
  | Store32 of indice * memarg

let pp_i64_instr ppf = function
  | Const i -> pf ppf "i64.const %Ld" i
  | Clz -> pf ppf "i64.clz"
  | Ctz -> pf ppf "i64.ctz"
  | Popcnt -> pf ppf "i64.popcnt"
  | Add -> pf ppf "i64.add"
  | Sub -> pf ppf "i64.sub"
  | Mul -> pf ppf "i64.mul"
  | Div_s -> pf ppf "i64.div_s"
  | Div_u -> pf ppf "i64.div_u"
  | Rem_s -> pf ppf "i64.rem_s"
  | Rem_u -> pf ppf "i64.rem_u"
  | And -> pf ppf "i64.and"
  | Or -> pf ppf "i64.or"
  | Xor -> pf ppf "i64.xor"
  | Shl -> pf ppf "i64.shl"
  | Shr_s -> pf ppf "i64.shr_s"
  | Shr_u -> pf ppf "i64.shr_u"
  | Rotl -> pf ppf "i64.rotl"
  | Rotr -> pf ppf "i64.rotr"
  | Eqz -> pf ppf "i64.eqz"
  | Eq -> pf ppf "i64.eq"
  | Ne -> pf ppf "i64.ne"
  | Lt_s -> pf ppf "i64.lt_s"
  | Lt_u -> pf ppf "i64.lt_u"
  | Gt_s -> pf ppf "i64.gt_s"
  | Gt_u -> pf ppf "i64.gt_u"
  | Le_s -> pf ppf "i64.le_s"
  | Le_u -> pf ppf "i64.le_u"
  | Ge_s -> pf ppf "i64.ge_s"
  | Ge_u -> pf ppf "i64.ge_u"
  | Extend8_s -> pf ppf "i64.extend8_s"
  | Extend16_s -> pf ppf "i64.extend16_s"
  | Extend32_s -> pf ppf "i64.extend32_s"
  | Extend_i32_s -> pf ppf "i64.extend_i32_s"
  | Extend_i32_u -> pf ppf "i64.extend_i32_u"
  | Trunc_f_s nn -> pf ppf "i64.trunc_f%a_s" pp_nn nn
  | Trunc_f_u nn -> pf ppf "i64.trunc_f%a_u" pp_nn nn
  | Trunc_sat_f_s nn -> pf ppf "i64.trunc_sat_f%a_s" pp_nn nn
  | Trunc_sat_f_u nn -> pf ppf "i64.trunc_sat_f%a_u" pp_nn nn
  | Reinterpret_f nn -> pf ppf "i64.reinterpret_f%a" pp_nn nn
  | Load (indice, memarg) ->
    pf ppf "i64.load%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_s (indice, memarg) ->
    pf ppf "i64.load8_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_u (indice, memarg) ->
    pf ppf "i64.load8_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_s (indice, memarg) ->
    pf ppf "i64.load16_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_u (indice, memarg) ->
    pf ppf "i64.load16_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32_s (indice, memarg) ->
    pf ppf "i64.load32_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32_u (indice, memarg) ->
    pf ppf "i64.load32_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store (indice, memarg) ->
    pf ppf "i64.store%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store8 (indice, memarg) ->
    pf ppf "i64.store8%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store16 (indice, memarg) ->
    pf ppf "i64.store16%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store32 (indice, memarg) ->
    pf ppf "i64.store32%a%a" pp_indice_not0 indice pp_memarg memarg

(** F32 instructions *)

type f32_instr =
  | Const of Float32.t
  | Abs
  | Neg
  | Sqrt
  | Ceil
  | Floor
  | Trunc
  | Nearest
  | Add
  | Sub
  | Mul
  | Div
  | Min
  | Max
  | Copysign
  | Eq
  | Ne
  | Lt
  | Gt
  | Le
  | Ge
  | Demote_f64
  | Convert_i_s of nn
  | Convert_i_u of nn
  | Reinterpret_i of nn
  | Load of indice * memarg
  | Store of indice * memarg

let pp_f32_instr ppf = function
  | Const f -> pf ppf "f32.const %a" Float32.pp f
  | Abs -> pf ppf "f32.abs"
  | Neg -> pf ppf "f32.neg"
  | Sqrt -> pf ppf "f32.sqrt"
  | Ceil -> pf ppf "f32.ceil"
  | Floor -> pf ppf "f32.floor"
  | Trunc -> pf ppf "f32.trunc"
  | Nearest -> pf ppf "f32.nearest"
  | Add -> pf ppf "f32.add"
  | Sub -> pf ppf "f32.sub"
  | Mul -> pf ppf "f32.mul"
  | Div -> pf ppf "f32.div"
  | Min -> pf ppf "f32.min"
  | Max -> pf ppf "f32.max"
  | Copysign -> pf ppf "f32.copysign"
  | Eq -> pf ppf "f32.eq"
  | Ne -> pf ppf "f32.ne"
  | Lt -> pf ppf "f32.lt"
  | Gt -> pf ppf "f32.gt"
  | Le -> pf ppf "f32.le"
  | Ge -> pf ppf "f32.ge"
  | Demote_f64 -> pf ppf "f32.demote_f64"
  | Convert_i_s nn -> pf ppf "f32.convert_i%a_s" pp_nn nn
  | Convert_i_u nn -> pf ppf "f32.convert_i%a_u" pp_nn nn
  | Reinterpret_i nn -> pf ppf "f32.reinterpret_i%a" pp_nn nn
  | Load (indice, memarg) ->
    pf ppf "f32.load%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store (indice, memarg) ->
    pf ppf "f32.store%a%a" pp_indice_not0 indice pp_memarg memarg

(** F64 instructions *)

type f64_instr =
  | Const of Float64.t
  | Abs
  | Neg
  | Sqrt
  | Ceil
  | Floor
  | Trunc
  | Nearest
  | Add
  | Sub
  | Mul
  | Div
  | Min
  | Max
  | Copysign
  | Eq
  | Ne
  | Lt
  | Gt
  | Le
  | Ge
  | Promote_f32
  | Convert_i_s of nn
  | Convert_i_u of nn
  | Reinterpret_i of nn
  | Load of indice * memarg
  | Store of indice * memarg

let pp_f64_instr ppf = function
  | Const f -> pf ppf "f64.const %a" Float64.pp f
  | Abs -> pf ppf "f64.abs"
  | Neg -> pf ppf "f64.neg"
  | Sqrt -> pf ppf "f64.sqrt"
  | Ceil -> pf ppf "f64.ceil"
  | Floor -> pf ppf "f64.floor"
  | Trunc -> pf ppf "f64.trunc"
  | Nearest -> pf ppf "f64.nearest"
  | Add -> pf ppf "f64.add"
  | Sub -> pf ppf "f64.sub"
  | Mul -> pf ppf "f64.mul"
  | Div -> pf ppf "f64.div"
  | Min -> pf ppf "f64.min"
  | Max -> pf ppf "f64.max"
  | Copysign -> pf ppf "f64.copysign"
  | Eq -> pf ppf "f64.eq"
  | Ne -> pf ppf "f64.ne"
  | Lt -> pf ppf "f64.lt"
  | Gt -> pf ppf "f64.gt"
  | Le -> pf ppf "f64.le"
  | Ge -> pf ppf "f64.ge"
  | Promote_f32 -> pf ppf "f64.promote_f32"
  | Convert_i_s nn -> pf ppf "f64.convert_i%a_s" pp_nn nn
  | Convert_i_u nn -> pf ppf "f64.convert_i%a_u" pp_nn nn
  | Reinterpret_i nn -> pf ppf "f64.reinterpret_i%a" pp_nn nn
  | Load (indice, memarg) ->
    pf ppf "f64.load%a%a" pp_indice_not0 indice pp_memarg memarg
  | 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
  | Not
  | And
  | Or
  | Any_true
  | Load8_splat of (indice * memarg)
  | Load8_lane of (indice * memarg * int)
  | Load8x8_s of (indice * memarg)
  | Load8x8_u of (indice * memarg)
  | Load16_splat of (indice * memarg)
  | Load16_lane of (indice * memarg * int)
  | Load16x4_s of (indice * memarg)
  | Load16x4_u of (indice * memarg)
  | Load32_splat of (indice * memarg)
  | Load32_lane of (indice * memarg * int)
  | Load32_zero of (indice * memarg)
  | Load64_splat of (indice * memarg)
  | Load64_lane of (indice * memarg * int)
  | Load64_zero of (indice * memarg)
  | Load of (indice * memarg)
  | Store of (indice * memarg)
  | Store8_lane of (indice * memarg * int)
  | Store64_lane of (indice * memarg * int)
  | Store32_zero of (indice * memarg)
  | Store32_lane of (indice * memarg * int)
  | Store16_lane of (indice * memarg * int)
  | Bitselect
  | Xor
  | Load32x2_s of (indice * memarg)
  | Load32x2_u of (indice * memarg)
  | Andnot

let pp_v128_instr ppf = function
  | Const n -> pf ppf "v128.const %a" Concrete_v128.pp n
  | Not -> pf ppf "v128.not"
  | And -> pf ppf "v128.and"
  | Or -> pf ppf "v128.or"
  | Any_true -> pf ppf "v128.any_true"
  | Load16x4_s (indice, memarg) ->
    pf ppf "v128.load16x4_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16x4_u (indice, memarg) ->
    pf ppf "v128.load16x4_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32_lane (indice, memarg, n) ->
    pf ppf "v128.load32_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Load64_zero (indice, memarg) ->
    pf ppf "v128.load64_zero%a%a" pp_indice_not0 indice pp_memarg memarg
  | 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
  | Bitselect -> pf ppf "v128.bitselect"
  | Xor -> pf ppf "v128.xor"
  | Andnot -> pf ppf "v128.andnot"
  | Load8_splat (indice, memarg) ->
    pf ppf "v128.load8_splat%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_lane (indice, memarg, n) ->
    pf ppf "v128.load8_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Load8x8_s (indice, memarg) ->
    pf ppf "v128.load8x8_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8x8_u (indice, memarg) ->
    pf ppf "v128.load8x8_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_splat (indice, memarg) ->
    pf ppf "v128.load16_splat%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_lane (indice, memarg, n) ->
    pf ppf "v128.load16_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Load32_splat (indice, memarg) ->
    pf ppf "v128.load32_splat%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32_zero (indice, memarg) ->
    pf ppf "v128.load32_zero%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load64_splat (indice, memarg) ->
    pf ppf "v128.load64_splat%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load64_lane (indice, memarg, n) ->
    pf ppf "v128.load64_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Store8_lane (indice, memarg, n) ->
    pf ppf "v128.store8_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Store64_lane (indice, memarg, n) ->
    pf ppf "v128.store64_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Store32_zero (indice, memarg) ->
    pf ppf "v128.store32_zero%a%a" pp_indice_not0 indice pp_memarg memarg
  | Store32_lane (indice, memarg, n) ->
    pf ppf "v128.store32_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Store16_lane (indice, memarg, n) ->
    pf ppf "v128.store16_lane%a%a %d" pp_indice_not0 indice pp_memarg memarg n
  | Load32x2_s (indice, memarg) ->
    pf ppf "v128.load32x2_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32x2_u (indice, memarg) ->
    pf ppf "v128.load32x2_u%a%a" pp_indice_not0 indice pp_memarg memarg

(** I8x16 instructions *)
type i8x16_instr =
  | Add
  | Sub
  | Eq
  | Ne
  | Lt_s
  | Lt_u
  | Gt_s
  | Gt_u
  | Le_s
  | Le_u
  | Ge_s
  | Ge_u
  | Abs
  | Neg
  | Popcnt
  | All_true
  | Bitmask
  | Shuffle of int array (* TODO: make this immutable at some point *)
  | Swizzle
  | Splat
  | Shl
  | Shr_s
  | Shr_u
  | Min_s
  | Min_u
  | Extract_lane_s of int
  | Extract_lane_u of int
  | Add_sat_s
  | Add_sat_u
  | Sub_sat_s
  | Sub_sat_u
  | Max_s
  | Max_u
  | Narrow_i16x8_s
  | Narrow_i16x8_u
  | Avgr_u
  | Replace_lane of int

let pp_i8x16_instr ppf = function
  | Add -> pf ppf "i8x16.add"
  | Sub -> pf ppf "i8x16.sub"
  | Eq -> pf ppf "i8x16.eq"
  | Ne -> pf ppf "i8x16.ne"
  | Lt_s -> pf ppf "i8x16.lt_s"
  | Lt_u -> pf ppf "i8x16.lt_u"
  | Gt_s -> pf ppf "i8x16.gt_s"
  | Gt_u -> pf ppf "i8x16.gt_u"
  | Le_s -> pf ppf "i8x16.le_s"
  | Le_u -> pf ppf "i8x16.le_u"
  | Ge_s -> pf ppf "i8x16.ge_s"
  | Ge_u -> pf ppf "i8x16.ge_u"
  | Abs -> pf ppf "i8x16.abs"
  | Neg -> pf ppf "i8x16.neg"
  | Popcnt -> pf ppf "i8x16.popcnt"
  | All_true -> pf ppf "i8x16.all_true"
  | Bitmask -> pf ppf "i8x16.bitmask"
  | Shuffle is -> pf ppf "i8x16.suffle %a" (Fmt.array ~sep:Fmt.sp Fmt.int) is
  | Swizzle -> pf ppf "i8x16.swizzle"
  | Splat -> pf ppf "i8x16.splat"
  | Shl -> pf ppf "i8x16.shl"
  | Shr_s -> pf ppf "i8x16.shr_s"
  | Shr_u -> pf ppf "i8x16.shr_u"
  | Add_sat_s -> pf ppf "i8x16.add_sat_s"
  | Add_sat_u -> pf ppf "i8x16.add_sat_u"
  | Min_s -> pf ppf "i8x16.min_s"
  | Min_u -> pf ppf "i8x16.min_u"
  | Sub_sat_s -> pf ppf "i8x16.sub_sat_s"
  | Sub_sat_u -> pf ppf "i8x16.sub_sat_u"
  | Max_s -> pf ppf "i8x16.max_s"
  | Max_u -> pf ppf "i8x16.max_u"
  | Narrow_i16x8_s -> pf ppf "i8x16.narrow_i16x8_s"
  | Narrow_i16x8_u -> pf ppf "i8x16.narrow_i16x8_u"
  | Avgr_u -> pf ppf "i8x16.avgr_u"
  | Extract_lane_s lane_index -> pf ppf "i8x16.extract_lane_s %d" lane_index
  | Extract_lane_u lane_index -> pf ppf "i8x16.extract_lane_u %d" lane_index
  | Replace_lane lane_index -> pf ppf "i8x16.replace_lane %d" lane_index

(** I16x8 instructions *)
type i16x8_instr =
  | Add
  | Sub
  | Mul
  | Eq
  | Ne
  | Lt_s
  | Lt_u
  | Gt_s
  | Gt_u
  | Le_s
  | Le_u
  | Ge_s
  | Ge_u
  | Splat
  | Extract_lane_s of int
  | Extract_lane_u of int
  | Q15mulr_sat_s
  | Min_s
  | Min_u
  | Extmul_low_i8x16_s
  | Extmul_low_i8x16_u
  | Extmul_high_i8x16_s
  | Extmul_high_i8x16_u
  | Extend_low_i8x16_s
  | Extend_low_i8x16_u
  | Extend_high_i8x16_s
  | Extend_high_i8x16_u
  | Extadd_pairwise_i8x16_s
  | Extadd_pairwise_i8x16_u
  | Add_sat_s
  | Add_sat_u
  | Sub_sat_s
  | Sub_sat_u
  | Max_s
  | Max_u
  | Shl
  | Neg
  | All_true
  | Shr_s
  | Shr_u
  | Bitmask
  | Avgr_u
  | Abs
  | Replace_lane of int
  | Narrow_i32x4_s
  | Narrow_i32x4_u

let pp_i16x8_instr ppf = function
  | Add -> pf ppf "i16x8.add"
  | Sub -> pf ppf "i16x8.sub"
  | Mul -> pf ppf "i16x8.mul"
  | Eq -> pf ppf "i16x8.eq"
  | Ne -> pf ppf "i16x8.ne"
  | Lt_s -> pf ppf "i16x8.lt_s"
  | Lt_u -> pf ppf "i16x8.lt_u"
  | Gt_s -> pf ppf "i16x8.gt_s"
  | Gt_u -> pf ppf "i16x8.gt_u"
  | Le_s -> pf ppf "i16x8.le_s"
  | Le_u -> pf ppf "i16x8.le_u"
  | Ge_s -> pf ppf "i16x8.ge_s"
  | Ge_u -> pf ppf "i16x8.ge_u"
  | Splat -> pf ppf "i16x8.splat"
  | Extract_lane_s n -> pf ppf "i16x8.extract_lane_s %d" n
  | Extract_lane_u n -> pf ppf "i16x8.extract_lane_u %d" n
  | Q15mulr_sat_s -> pf ppf "i16x8.q15mulr_sat_s"
  | Min_s -> pf ppf "i16x8.min_s"
  | Min_u -> pf ppf "i16x8.min_u"
  | Extmul_low_i8x16_s -> pf ppf "i16x8.extmul_low_i8x16_s"
  | Extmul_low_i8x16_u -> pf ppf "i16x8.extmul_low_i8x16_u"
  | Extmul_high_i8x16_s -> pf ppf "i16x8.extmul_high_i8x16_s"
  | Extmul_high_i8x16_u -> pf ppf "i16x8.extmul_high_i8x16_u"
  | Extend_low_i8x16_s -> pf ppf "i16x8.extend_low_i8x16_s"
  | Extend_low_i8x16_u -> pf ppf "i16x8.extend_low_i8x16_u"
  | Extend_high_i8x16_s -> pf ppf "i16x8.extend_high_i8x16_s"
  | Extend_high_i8x16_u -> pf ppf "i16x8.extend_high_i8x16_u"
  | Extadd_pairwise_i8x16_s -> pf ppf "i16x8.extadd_pairwise_i8x16_s"
  | Extadd_pairwise_i8x16_u -> pf ppf "i16x8.extadd_pairwise_i8x16_u"
  | Add_sat_s -> pf ppf "i16x8.add_sat_s"
  | Add_sat_u -> pf ppf "i16x8.add_sat_u"
  | Sub_sat_s -> pf ppf "i16x8.sub_sat_s"
  | Sub_sat_u -> pf ppf "i16x8.sub_sat_u"
  | Max_s -> pf ppf "i16x8.max_s"
  | Max_u -> pf ppf "i16x8.max_u"
  | Shl -> pf ppf "i16x8.shl"
  | Neg -> pf ppf "i16x8.neg"
  | All_true -> pf ppf "i16x8.all_true"
  | Shr_s -> pf ppf "i16x8.shr_s"
  | Shr_u -> pf ppf "i16x8.shr_u"
  | Bitmask -> pf ppf "i16x8.bitmask"
  | Avgr_u -> pf ppf "i16x8.avgr_u"
  | Abs -> pf ppf "i16x8.abs"
  | Narrow_i32x4_s -> pf ppf "i16x8.narrow_i32x4_s"
  | Narrow_i32x4_u -> pf ppf "i16x8.narrow_i32x4_u"
  | Replace_lane lane_index -> pf ppf "i16x8.replace_lane %d" lane_index

(* I32x4 instructions *)
type i32x4_instr =
  | Add
  | Sub
  | Mul
  | Shl
  | Shr_s
  | Shr_u
  | Eq
  | Ne
  | Lt_s
  | Lt_u
  | Gt_s
  | Gt_u
  | Le_s
  | Le_u
  | Ge_s
  | Ge_u
  | Splat
  | Extract_lane of int
  | Replace_lane of int
  | Extend_low_i16x8_s
  | Extend_high_i16x8_s
  | Extend_low_i16x8_u
  | Extend_high_i16x8_u
  | Trunc_sat_f64x2_s_zero
  | Trunc_sat_f64x2_u_zero
  | Trunc_sat_f32x4_s
  | Trunc_sat_f32x4_u
  | Min_s
  | Min_u
  | Extmul_low_i16x8_s
  | Extmul_low_i16x8_u
  | Extmul_high_i16x8_s
  | Extmul_high_i16x8_u
  | Extadd_pairwise_i16x8_s
  | Extadd_pairwise_i16x8_u
  | Dot_i16x8_s
  | Neg
  | Max_s
  | Max_u
  | Abs
  | All_true
  | Bitmask

let pp_i32x4_instr ppf = function
  | Add -> pf ppf "i32x4.add"
  | Sub -> pf ppf "i32x4.sub"
  | Mul -> pf ppf "i32x4.mul"
  | Shl -> pf ppf "i32x4.shl"
  | Shr_s -> pf ppf "i32x4.shr_s"
  | Shr_u -> pf ppf "i32x4.shr_u"
  | Eq -> pf ppf "i32x4.eq"
  | Ne -> pf ppf "i32x4.ne"
  | Lt_s -> pf ppf "i32x4.lt_s"
  | Lt_u -> pf ppf "i32x4.lt_u"
  | Gt_s -> pf ppf "i32x4.gt_s"
  | Gt_u -> pf ppf "i32x4.gt_u"
  | Le_s -> pf ppf "i32x4.le_s"
  | Le_u -> pf ppf "i32x4.le_u"
  | Ge_s -> pf ppf "i32x4.ge_s"
  | Ge_u -> pf ppf "i32x4.ge_u"
  | Splat -> pf ppf "i32x4.splat"
  | Extract_lane n -> pf ppf "i32x4.extract_lane %d" n
  | Replace_lane n -> pf ppf "i32x4.replace_lane %d" n
  | Extend_low_i16x8_s -> pf ppf "i32x4.extend_low_i16x8_s"
  | Extend_high_i16x8_s -> pf ppf "i32x4.extend_high_i16x8_s"
  | Extend_low_i16x8_u -> pf ppf "i32x4.extend_low_i16x8_u"
  | Extend_high_i16x8_u -> pf ppf "i32x4.extend_high_i16x8_u"
  | Trunc_sat_f64x2_s_zero -> pf ppf "i32x4.trunc_sat_f64x2_s_zero"
  | Trunc_sat_f64x2_u_zero -> pf ppf "i32x4.trunc_sat_f64x2_u_zero"
  | Trunc_sat_f32x4_s -> pf ppf "i32x4.trunc_sat_f32x4_s"
  | Trunc_sat_f32x4_u -> pf ppf "i32x4.trunc_sat_f32x4_u"
  | Min_s -> pf ppf "i32x4.min_s"
  | Min_u -> pf ppf "i32x4.min_u"
  | Extmul_low_i16x8_s -> pf ppf "i32x4.extmul_low_i16x8_s"
  | Extmul_low_i16x8_u -> pf ppf "i32x4.extmul_low_i16x8_u"
  | Extmul_high_i16x8_s -> pf ppf "i32x4.extmul_high_i16x8_s"
  | Extmul_high_i16x8_u -> pf ppf "i32x4.extmul_high_i16x8_u"
  | Extadd_pairwise_i16x8_s -> pf ppf "i32x4.extadd_pairwise_i16x8_s"
  | Extadd_pairwise_i16x8_u -> pf ppf "i32x4.extadd_pairwise_i16x8_u"
  | Dot_i16x8_s -> pf ppf "i32x4.dot_i16x8_s"
  | Neg -> pf ppf "i32x4.neg"
  | Max_s -> pf ppf "i32x4.max_s"
  | Max_u -> pf ppf "i32x4.max_u"
  | Abs -> pf ppf "i32x4.abs"
  | All_true -> pf ppf "i32x4.all_true"
  | Bitmask -> pf ppf "i32x4.bitmask"

(** I64x2 instructions *)
type i64x2_instr =
  | Add
  | Sub
  | Mul
  | Eq
  | Ne
  | Lt_s
  | Gt_s
  | Le_s
  | Ge_s
  | Splat
  | Extend_low_i32x4_s
  | Extend_low_i32x4_u
  | Extend_high_i32x4_s
  | Extend_high_i32x4_u
  | Extmul_low_i32x4_s
  | Extmul_low_i32x4_u
  | Extmul_high_i32x4_s
  | Extmul_high_i32x4_u
  | Abs
  | Neg
  | Extract_lane of int
  | All_true
  | Bitmask
  | Shl
  | Replace_lane of int
  | Shr_s
  | Shr_u

let pp_i64x2_instr ppf = function
  | Add -> pf ppf "i64x2.add"
  | Sub -> pf ppf "i64x2.sub"
  | Mul -> pf ppf "i64x2.mul"
  | Eq -> pf ppf "i64x2.eq"
  | Ne -> pf ppf "i64x2.ne"
  | Lt_s -> pf ppf "i64x2.lt_s"
  | Gt_s -> pf ppf "i64x2.gt_s"
  | Le_s -> pf ppf "i64x2.le_s"
  | Ge_s -> pf ppf "i64x2.ge_s"
  | Splat -> pf ppf "i64x2.splat"
  | Extend_low_i32x4_s -> pf ppf "i64x2.extend_low_i32x4_s"
  | Extend_low_i32x4_u -> pf ppf "i64x2.extend_low_i32x4_u"
  | Extend_high_i32x4_s -> pf ppf "i64x2.extend_high_i32x4_s"
  | Extend_high_i32x4_u -> pf ppf "i64x2.extend_high_i32x4_u"
  | Extmul_low_i32x4_s -> pf ppf "i64x2.extmul_low_i32x4_s"
  | Extmul_low_i32x4_u -> pf ppf "i64x2.extmul_low_i32x4_u"
  | Extmul_high_i32x4_s -> pf ppf "i64x2.extmul_high_i32x4_s"
  | Extmul_high_i32x4_u -> pf ppf "i64x2.extmul_high_i32x4_u"
  | Abs -> pf ppf "i64x2.abs"
  | Neg -> pf ppf "i64x2.neg"
  | All_true -> pf ppf "i64x2.all_true"
  | Bitmask -> pf ppf "i64x2.bitmask"
  | Shl -> pf ppf "i64x2.shl"
  | Shr_s -> pf ppf "i64x2.shr_s"
  | Shr_u -> pf ppf "i64x2.shr_u"
  | Extract_lane lane_index -> pf ppf "i64x2.extract_lane %d" lane_index
  | Replace_lane lane_index -> pf ppf "i64x2.replace_lane %d" lane_index

type f32x4_instr =
  | Pmin
  | Min
  | Eq
  | Convert_i32x4_s
  | Convert_i32x4_u
  | Ceil
  | Add
  | Max
  | Floor
  | Pmax
  | Ne
  | Sub
  | Abs
  | Trunc
  | Lt
  | Gt
  | Le
  | Ge
  | Mul
  | Convert_low_i32x4_s
  | Convert_low_i32x4_u
  | Convert_high_i32x4_s
  | Convert_high_i32x4_u
  | Splat
  | Nearest
  | Div
  | Neg
  | Extract_lane of int
  | Sqrt
  | Replace_lane of int
  | Demote_f64x2_zero

let pp_f32x4_instr ppf : f32x4_instr -> _ = function
  | Pmin -> pf ppf "f32x4.pmin"
  | Min -> pf ppf "f32x4.min"
  | Eq -> pf ppf "f32x4.eq"
  | Convert_i32x4_s -> pf ppf "f32x4.convert_i32x4_s"
  | Convert_i32x4_u -> pf ppf "f32x4.convert_i32x4_u"
  | Ceil -> pf ppf "f32x4.ceil"
  | Add -> pf ppf "f32x4.dd"
  | Max -> pf ppf "f32x4.max"
  | Floor -> pf ppf "f32x4.floor"
  | Pmax -> pf ppf "f32x4.pmax"
  | Ne -> pf ppf "f32x4.ne"
  | Sub -> pf ppf "f32x4.sub"
  | Abs -> pf ppf "f32x4.abs"
  | Trunc -> pf ppf "f32x4.trunc"
  | Lt -> pf ppf "f32x4.lt"
  | Gt -> pf ppf "f32x4.gt"
  | Le -> pf ppf "f32x4.le"
  | Ge -> pf ppf "f32x4.ge"
  | Mul -> pf ppf "f32x4.mul"
  | Convert_low_i32x4_s -> pf ppf "f32x4.convert_low_i32x4_s"
  | Convert_low_i32x4_u -> pf ppf "f32x4.convert_low_i32x4_u"
  | Convert_high_i32x4_s -> pf ppf "f32x4.convert_high_i32x4_s"
  | Convert_high_i32x4_u -> pf ppf "f32x4.convert_high_i32x4_u"
  | Splat -> pf ppf "f32x4.splat"
  | Nearest -> pf ppf "f32x4.nearest"
  | Div -> pf ppf "f32x4.div"
  | Neg -> pf ppf "f32x4.neg"
  | Sqrt -> pf ppf "f32x4.sqrt"
  | Demote_f64x2_zero -> pf ppf "f32x4.demote_f64x2_zero"
  | Extract_lane lane_index -> pf ppf "f32x4.extract_lane %d" lane_index
  | Replace_lane lane_index -> pf ppf "f32x4.replace_lane %d" lane_index

type f64x2_instr =
  | Pmin
  | Min
  | Eq
  | Ceil
  | Add
  | Max
  | Floor
  | Pmax
  | Ne
  | Sub
  | Abs
  | Trunc
  | Lt
  | Gt
  | Le
  | Ge
  | Mul
  | Convert_low_i32x4_s
  | Convert_low_i32x4_u
  | Convert_high_i32x4_s
  | Convert_high_i32x4_u
  | Nearest
  | Div
  | Neg
  | Sqrt
  | Splat
  | Extract_lane of int
  | Promote_low_f32x4
  | Replace_lane of int

let pp_f64x2_instr ppf : f64x2_instr -> _ = function
  | Pmin -> pf ppf "f64x2.pmin"
  | Min -> pf ppf "f64x2.min"
  | Eq -> pf ppf "f64x2.eq"
  | Ceil -> pf ppf "f64x2.ceil"
  | Add -> pf ppf "f64x2.add"
  | Max -> pf ppf "f64x2.max"
  | Floor -> pf ppf "f64x2.floor"
  | Pmax -> pf ppf "f64x2.pmax"
  | Ne -> pf ppf "f64x2.ne"
  | Sub -> pf ppf "f64x2.sub"
  | Abs -> pf ppf "f64x2.abs"
  | Trunc -> pf ppf "f64x2.trunc"
  | Lt -> pf ppf "f64x2.lt"
  | Gt -> pf ppf "f64x2.gt"
  | Le -> pf ppf "f64x2.le"
  | Ge -> pf ppf "f64x2.ge"
  | Mul -> pf ppf "f64x2.mul"
  | Convert_low_i32x4_s -> pf ppf "f64x2.convert_low_i32x4_s"
  | Convert_low_i32x4_u -> pf ppf "f64x2.convert_low_i32x4_u"
  | Convert_high_i32x4_s -> pf ppf "f64x2.convert_high_i32x4_s"
  | Convert_high_i32x4_u -> pf ppf "f64x2.convert_high_i32x4_u"
  | Nearest -> pf ppf "f64x2.nearest"
  | Div -> pf ppf "f64x2.div"
  | Neg -> pf ppf "f64x2.neg"
  | Sqrt -> pf ppf "f64x2.sqrt"
  | Splat -> pf ppf "f64x2.splat"
  | Promote_low_f32x4 -> pf ppf "f64x2.promote_low_f32x4"
  | Extract_lane lane_index -> pf ppf "f64x2.extract_lane %d" lane_index
  | Replace_lane lane_index -> pf ppf "f64x2.replace_lane %d" lane_index

(** Reference instructions *)
type ref_instr =
  | Null of heap_type
  | Is_null
  | As_non_null
  | Func of indice
  | Eq
  | Test of ref_type
  | Cast of ref_type

let pp_ref_instr ppf = function
  | Null t -> pf ppf "ref.null %a" pp_heap_type t
  | Is_null -> pf ppf "ref.is_null"
  | As_non_null -> pf ppf "ref.as_non_null"
  | Func indice -> pf ppf "ref.func %a" pp_indice indice
  | Eq -> pf ppf "ref.eq"
  | Test rt -> pf ppf "ref.test %a" pp_ref_type rt
  | Cast rt -> pf ppf "ref.cast %a" pp_ref_type rt

(* Local instructions *)
type local_instr =
  | Get of indice
  | Set of indice
  | Tee of indice

let pp_local_instr ppf = function
  | Get indice -> pf ppf "local.get %a" pp_indice indice
  | Set indice -> pf ppf "local.set %a" pp_indice indice
  | Tee indice -> pf ppf "local.tee %a" pp_indice indice

(** Global instructions *)
type global_instr =
  | Get of indice
  | Set of indice

let pp_global_instr ppf = function
  | Get indice -> pf ppf "global.get %a" pp_indice indice
  | Set indice -> pf ppf "global.set %a" pp_indice indice

(** Table instructions *)
type table_instr =
  | Get of indice
  | Set of indice
  | Size of indice
  | Grow of indice
  | Fill of indice
  | Copy of indice * indice
  | Init of indice * indice

let pp_table_instr ppf = function
  | Get indice -> pf ppf "table.get %a" pp_indice indice
  | Set indice -> pf ppf "table.set %a" pp_indice indice
  | Size indice -> pf ppf "table.size %a" pp_indice indice
  | Grow indice -> pf ppf "table.grow %a" pp_indice indice
  | Fill indice -> pf ppf "table.fill %a" pp_indice indice
  | Copy (indice, indice') ->
    pf ppf "table.copy %a %a" pp_indice indice pp_indice indice'
  | Init (table_indice, elem_indice) ->
    pf ppf "table.init %a %a" pp_indice table_indice pp_indice elem_indice

(** Elem instructions *)
type elem_instr = Drop of indice

let pp_elem_instr ppf = function
  | Drop indice -> pf ppf "elem.drop %a" pp_indice indice

(** Memory instructions *)
type memory_instr =
  | Size of indice
  | Grow of indice
  | Fill of indice
  | Copy of indice * indice
  | Init of indice * indice

let pp_memory_instr ppf = function
  | Size indice -> pf ppf "memory.size%a" pp_indice_not0 indice
  | Grow indice -> pf ppf "memory.grow%a" pp_indice_not0 indice
  | Fill indice -> pf ppf "memory.fill%a" pp_indice_not0 indice
  | Copy (Raw 0, Raw 0) -> pf ppf "memory.copy"
  | Copy (indice1, indice2) ->
    pf ppf "memory.copy %a %a" pp_indice indice1 pp_indice indice2
  | Init (mem_indice, data_indice) ->
    pf ppf "memory.init%a %a" pp_indice_not0 mem_indice pp_indice data_indice

(** Data instructions *)
type data_instr = Drop of indice

let pp_data_instr ppf = function
  | Drop indice -> pf ppf "data.drop %a" pp_indice indice

(** I31 instructions *)
type i31_instr =
  | Ref
  | Get_s
  | Get_u

let pp_i31_instr ppf = function
  | Ref -> pf ppf "ref.i31"
  | Get_s -> pf ppf "i31.get_s"
  | Get_u -> pf ppf "i31.get_u"

(** Struct instructions *)
type struct_instr =
  | New of indice
  | New_default of indice
  | Get of indice * indice
  | Get_s of indice * indice
  | Get_u of indice * indice
  | Set of indice * indice

let pp_struct_instr ppf = function
  | New id -> pf ppf "struct.new %a" pp_indice id
  | New_default id -> pf ppf "struct.new_default %a" pp_indice id
  | Get (id1, id2) -> pf ppf "struct.get %a %a" pp_indice id1 pp_indice id2
  | Get_s (id1, id2) -> pf ppf "struct.get_s %a %a" pp_indice id1 pp_indice id2
  | Get_u (id1, id2) -> pf ppf "struct.get_u %a %a" pp_indice id1 pp_indice id2
  | Set (id1, id2) -> pf ppf "struct.set %a %a" pp_indice id1 pp_indice id2

(** Array instructions *)
type array_instr =
  | New of indice
  | New_default of indice
  | New_fixed of indice * Int32.t
  | New_data of indice * indice
  | New_elem of indice * indice
  | Get of indice
  | Get_s of indice
  | Get_u of indice
  | Set of indice
  | Len
  | Fill of indice
  | Copy of indice * indice
  | Init_data of indice * indice
  | Init_elem of indice * indice

let pp_array_instr ppf = function
  | New id -> pf ppf "array.new %a" pp_indice id
  | New_default id -> pf ppf "array.new_default %a" pp_indice id
  | New_fixed (id, n) -> pf ppf "array.new_fixed %a %ld" pp_indice id n
  | New_data (id1, id2) ->
    pf ppf "array.new_data %a %a" pp_indice id1 pp_indice id2
  | New_elem (id1, id2) ->
    pf ppf "array.new_elem %a %a" pp_indice id1 pp_indice id2
  | Get id -> pf ppf "array.get %a" pp_indice id
  | Get_s id -> pf ppf "array.get_s %a" pp_indice id
  | Get_u id -> pf ppf "array.get_u %a" pp_indice id
  | Set id -> pf ppf "array.set %a" pp_indice id
  | Len -> pf ppf "array.len"
  | Fill id -> pf ppf "array.fill %a" pp_indice id
  | Copy (id1, id2) -> pf ppf "array.copy %a %a" pp_indice id1 pp_indice id2
  | Init_data (id1, id2) ->
    pf ppf "array.init_data %a %a" pp_indice id1 pp_indice id2
  | Init_elem (id1, id2) ->
    pf ppf "array.init_elem %a %a" pp_indice id1 pp_indice id2

(** Instructions *)

type instr =
  | I32 of i32_instr
  | I64 of i64_instr
  | F32 of f32_instr
  | F64 of f64_instr
  | V128 of v128_instr
  | I8x16 of i8x16_instr
  | I16x8 of i16x8_instr
  | I32x4 of i32x4_instr
  | I64x2 of i64x2_instr
  | F32x4 of f32x4_instr
  | F64x2 of f64x2_instr
  | Ref of ref_instr
  | Local of local_instr
  | Global of global_instr
  | Table of table_instr
  | Elem of elem_instr
  | Memory of memory_instr
  | Data of data_instr
  | I31 of i31_instr
  | Struct of struct_instr
  | Array of array_instr
  (* Parametric instructions *)
  | Drop
  | Select of val_type list option
  | Nop
  | Unreachable
  | Block of string option * block_type option * expr
  | Loop of string option * block_type option * expr
  | If_else of string option * block_type option * expr * expr
  | Br of indice
  | Br_if of indice
  | Br_table of indice array * indice
  | Br_on_null of indice
  | Br_on_non_null of indice
  | Br_on_cast of indice * ref_type * ref_type
  | Br_on_cast_fail of indice * ref_type * ref_type
  | Return
  | Return_call of indice
  | Return_call_indirect of indice * block_type
  | Return_call_ref of block_type
  | Call of indice
  | Call_indirect of indice * block_type
  | Call_ref of indice
  (* GC convesion instructions *)
  | Any_convert_extern
  | Extern_convert_any

and expr = instr list

let pp_newline ppf () = pf ppf "@\n"

let rec pp_instr ~short ppf = function
  | I32 i -> pp_i32_instr ppf i
  | I64 i -> pp_i64_instr ppf i
  | F32 i -> pp_f32_instr ppf i
  | F64 i -> pp_f64_instr ppf i
  | V128 i -> pp_v128_instr ppf i
  | I8x16 i -> pp_i8x16_instr ppf i
  | I16x8 i -> pp_i16x8_instr ppf i
  | I32x4 i -> pp_i32x4_instr ppf i
  | I64x2 i -> pp_i64x2_instr ppf i
  | F32x4 i -> pp_f32x4_instr ppf i
  | F64x2 i -> pp_f64x2_instr ppf i
  | Ref i -> pp_ref_instr ppf i
  | Local i -> pp_local_instr ppf i
  | Global i -> pp_global_instr ppf i
  | Table i -> pp_table_instr ppf i
  | Elem i -> pp_elem_instr ppf i
  | Memory i -> pp_memory_instr ppf i
  | Data i -> pp_data_instr ppf i
  | I31 i -> pp_i31_instr ppf i
  | Struct i -> pp_struct_instr ppf i
  | Array i -> pp_array_instr ppf i
  | Drop -> pf ppf "drop"
  | Select vt ->
    begin match vt with
    | None -> pf ppf "select"
    | Some vt -> pf ppf "select (%a)" pp_result_type vt
    (* TODO: are the parens needed ? *)
    end
  | Nop -> pf ppf "nop"
  | Unreachable -> pf ppf "unreachable"
  | Block (id, bt, e) ->
    if short then pf ppf "block%a%a" pp_id_opt id pp_block_type_opt bt
    else
      pf ppf "(block%a%a@\n  @[<v>%a@])" pp_id_opt id pp_block_type_opt bt
        (pp_expr ~short) e
  | Loop (id, bt, e) ->
    if short then pf ppf "loop%a%a" pp_id_opt id pp_block_type_opt bt
    else
      pf ppf "(loop%a%a@\n  @[<v>%a@])" pp_id_opt id pp_block_type_opt bt
        (pp_expr ~short) e
  | If_else (id, bt, e1, e2) ->
    let pp_else ppf =
     (function
     | [] -> ()
     | e -> pf ppf "@\n(else@\n  @[<v>%a@]@\n)" (pp_expr ~short) e )
    in
    if short then pf ppf "if%a%a" pp_id_opt id pp_block_type_opt bt
    else
      pf ppf "(if%a%a@\n  @[<v>(then@\n  @[<v>%a@]@\n)%a@]@\n)" pp_id_opt id
        pp_block_type_opt bt (pp_expr ~short) e1 pp_else e2
  | Br id -> pf ppf "br %a" pp_indice id
  | Br_if id -> pf ppf "br_if %a" pp_indice id
  | Br_table (ids, id) ->
    pf ppf "br_table %a %a" (array ~sep:sp pp_indice) ids pp_indice id
  | Br_on_null id -> pf ppf "br_on_null %a" pp_indice id
  | Br_on_non_null id -> pf ppf "br_on_non_null %a" pp_indice id
  | Br_on_cast (id, rt1, rt2) ->
    pf ppf "br_on_cast %a %a %a" pp_indice id pp_ref_type rt1 pp_ref_type rt2
  | Br_on_cast_fail (id, rt1, rt2) ->
    pf ppf "br_on_cast_fail %a %a %a" pp_indice id pp_ref_type rt1 pp_ref_type
      rt2
  | Return -> pf ppf "return"
  | Return_call id -> pf ppf "return_call %a" pp_indice id
  | Return_call_indirect (tbl_id, ty_id) ->
    pf ppf "return_call_indirect %a %a" pp_indice tbl_id pp_block_type ty_id
  | Return_call_ref ty_id -> pf ppf "return_call_ref %a" pp_block_type ty_id
  | Call id -> pf ppf "call %a" pp_indice id
  | Call_indirect (tbl_id, ty_id) ->
    pf ppf "call_indirect %a %a" pp_indice tbl_id pp_block_type ty_id
  | Call_ref ty_id -> pf ppf "call_ref %a" pp_indice ty_id
  (* convesion *)
  | Any_convert_extern -> pf ppf "any.convert_extern"
  | Extern_convert_any -> pf ppf "extern.convert_any"

and pp_expr ~short ppf instrs =
  list ~sep:pp_newline (fun ppf i -> (pp_instr ~short ppf) i) ppf instrs

module Func = struct
  type t =
    { type_f : block_type
    ; locals : param list
    ; body : expr
    ; id : string option
    }

  let pp_local ppf (id, t) = pf ppf "(local%a %a)" pp_id_opt id pp_val_type t

  let pp_locals ppf locals = list ~sep:sp pp_local ppf locals

  let pp ppf f =
    (* TODO: type_use ? *)
    pf ppf "(func%a%a%a@\n  @[<v>%a@]@\n)" pp_id_opt f.id pp_block_type f.type_f
      (with_space_list pp_locals)
      f.locals (pp_expr ~short:false) f.body
end

module Typedef = struct
  type t =
    | SimpleType of (string option * sub_type)
    | RecType of (string option * sub_type) list

  let pp_ty fmt (id, ty) = pf fmt "(type%a %a)" pp_id_opt id pp_sub_type ty

  let pp fmt t =
    match t with
    | SimpleType (id, ty) -> Fmt.pf fmt "%a" pp_ty (id, ty)
    | RecType tyl -> Fmt.pf fmt "(rec %a)" (Fmt.list ~sep:Fmt.sp pp_ty) tyl
end

module Table = struct
  module Type = struct
    type nonrec t = limits * ref_type

    let pp ppf (limits, ref_type) =
      pf ppf "%a %a" pp_limits limits pp_ref_type ref_type
  end

  type t =
    { id : string option
    ; typ : Type.t
    ; init : expr option
    }

  let pp ppf { id; typ; init } =
    pf ppf "(table%a %a%a)" pp_id_opt id Type.pp typ
      (fun ppf e ->
        match e with
        | None -> ()
        | Some e -> Fmt.pf ppf " %a" (pp_expr ~short:true) e )
      init
end

module Global = struct
  module Type = struct
    type nonrec t = mut * val_type

    let pp ppf (mut, val_type) =
      match mut with
      | Var -> pf ppf "(mut %a)" pp_val_type val_type
      | Const -> pf ppf "%a" pp_val_type val_type
  end

  type t =
    { typ : Type.t
    ; init : expr
    ; id : string option
    }

  let pp ppf (g : t) =
    pf ppf "(global%a %a %a)" pp_id_opt g.id Type.pp g.typ
      (pp_expr ~short:false) g.init
end

module Data = struct
  module Mode = struct
    type t =
      | Passive
      | Active of indice option * expr

    let pp ppf = function
      | Passive -> ()
      | Active (i, e) ->
        pf ppf "(memory %a) (offset %a)" pp_indice_opt i (pp_expr ~short:false)
          e
  end

  type t =
    { id : string option
    ; init : string
    ; mode : Mode.t
    }

  let pp ppf (d : t) =
    pf ppf {|(data%a %a %S)|} pp_id_opt d.id Mode.pp d.mode d.init
end

module Tag = struct
  type t =
    { id : string option
    ; typ : block_type
    }

  let pp ppf { id; typ } = pf ppf {|(tag%a %a)|} pp_id_opt id pp_block_type typ
end

module Elem = struct
  module Mode = struct
    type t =
      | Passive
      | Declarative
      | Active of indice option * expr

    let pp ppf = function
      | Passive -> ()
      | Declarative -> pf ppf "declare"
      | Active (i, e) -> (
        match i with
        | None -> pf ppf "(offset %a)" (pp_expr ~short:false) e
        | Some i ->
          pf ppf "(table %a) (offset %a)" pp_indice i (pp_expr ~short:false) e )
  end

  type t =
    { id : string option
    ; typ : ref_type
    ; init : expr list
    ; mode : Mode.t
    ; explicit_typ : bool
    }

  let pp_items ppf e = pf ppf "(item %a)" (pp_expr ~short:false) e

  let pp ppf (e : t) =
    pf ppf "@[<hov 2>(elem%a %a %a %a)@]" pp_id_opt e.id Mode.pp e.mode
      pp_ref_type e.typ
      (list ~sep:pp_newline pp_items)
      e.init
end

module Mem = struct
  type nonrec t = string option * limits

  let pp ppf (id, ty) = pf ppf "(memory%a %a)" pp_id_opt id pp_limits ty
end

module Import = struct
  module Type = struct
    type t =
      | Func of string option * block_type
      | Table of string option * Table.Type.t
      | Mem of string option * limits
      | Global of string option * Global.Type.t
      | Tag of string option * block_type

    let pp ppf = function
      | Func (id, t) -> pf ppf "(func%a %a)" pp_id_opt id pp_block_type t
      | Table (id, t) -> pf ppf "(table%a %a)" pp_id_opt id Table.Type.pp t
      | Mem (id, t) -> pf ppf "(memory%a %a)" pp_id_opt id pp_limits t
      | Global (id, t) -> pf ppf "(global%a %a)" pp_id_opt id Global.Type.pp t
      | Tag (id, t) -> pf ppf "(tag%a %a)" pp_id_opt id pp_block_type t
  end

  type t =
    { modul_name : string
        (** The name of the module from which the import is done *)
    ; name : string  (** The name of the importee in its module of origin *)
    ; typ : Type.t
    }

  let pp ppf i =
    pf ppf {|(import "%a" "%a" %a)|} string i.modul_name string i.name Type.pp
      i.typ
end

module Export = struct
  module Type = struct
    type t =
      | Func of indice option
      | Table of indice option
      | Mem of indice option
      | Global of indice option
      | Tag of indice option

    let pp ppf = function
      | Func id -> pf ppf "(func %a)" pp_indice_opt id
      | Table id -> pf ppf "(table %a)" pp_indice_opt id
      | Mem id -> pf ppf "(memory %a)" pp_indice_opt id
      | Global id -> pf ppf "(global %a)" pp_indice_opt id
      | Tag id -> pf ppf "(tag %a)" pp_indice_opt id
  end

  type t =
    { name : string
    ; typ : Type.t
    }

  let pp ppf (e : t) = pf ppf {|(export "%s" %a)|} e.name Type.pp e.typ
end

module Module = struct
  module Field = struct
    type t =
      | Typedef of Typedef.t
      | Global of Global.t
      | Table of Table.t
      | Mem of Mem.t
      | Func of Func.t
      | Elem of Elem.t
      | Data of Data.t
      | Tag of Tag.t
      | Start of indice
      | Import of Import.t
      | Export of Export.t

    let pp_start ppf start = pf ppf "(start %a)" pp_indice start

    let pp ppf = function
      | Typedef t -> Typedef.pp ppf t
      | Global g -> Global.pp ppf g
      | Table t -> Table.pp ppf t
      | Mem m -> Mem.pp ppf m
      | Func f -> Func.pp ppf f
      | Elem e -> Elem.pp ppf e
      | Data d -> Data.pp ppf d
      | Tag t -> Tag.pp ppf t
      | Start s -> pp_start ppf s
      | Import i -> Import.pp ppf i
      | Export e -> Export.pp ppf e
  end

  type t =
    { id : string option
    ; fields : Field.t list
    }

  let pp_fields ppf fields =
    Fmt.pf ppf "%a" (list ~sep:pp_newline Field.pp) fields

  let pp ppf m =
    pf ppf "(module%a@\n  @[<v>%a@]@\n)" pp_id_opt m.id pp_fields m.fields
end
src/ir/text.ml

29.08%
