binary.ml — Coverage report

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

open Fmt

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

(* identifiers *)

type indice = int

let pp_indice ppf i = int ppf i

let pp_indice_not0 ppf i = if i <> 0 then Fmt.pf ppf " %d" i

let pp_str_opt ppf = function None -> () | Some i -> pf ppf " %s" i

(** 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
  | NoExn_ht, NoExn_ht
  | Exn_ht, Exn_ht
  | NoExtern_ht, NoExtern_ht ->
    true
  | TypeUse id1, TypeUse id2 -> Int.equal id1 id2
  | _, _ -> 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

type ref_type = Text.nullable * heap_type

let pp_ref_type ppf (n, ht) =
  match n with
  | Text.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
  | ((Text.Null : Text.nullable), t1), ((Text.Null : Text.nullable), t2)
  | (No_null, t1), (No_null, t2) ->
    heap_type_eq t1 t2
  | _ -> false

type val_type =
  | Num_type of Text.num_type
  | Ref_type of ref_type

let pp_val_type fmt = function
  | Num_type t -> Text.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 -> Text.num_type_eq t1 t2
  | Ref_type t1, Ref_type t2 -> ref_type_eq t1 t2
  | _, _ -> false

type storage_type =
  | Val_type of val_type
  | Pack_type of Text.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"

let is_subtype_ref_type t1 t2 =
  match (t1, t2) with
  | (Text.No_null, ht1), ((Text.Null : Text.nullable), 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 is_subtype_val_type t1 t2 =
  match (t1, t2) with
  | Num_type t1, Num_type t2 -> Text.num_type_eq t1 t2
  | Ref_type t1, Ref_type t2 -> is_subtype_ref_type t1 t2
  | _, _ -> false

type param = string option * val_type

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

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

type param_type = param list

let pp_param_type ppf (params : param_type) = list ~sep:sp pp_param ppf params

let param_type_eq t1 t2 = List.equal param_eq t1 t2

type result_type = val_type list

let result_type_eq t1 t2 = List.equal val_type_eq t1 t2

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 with_space_list printer ppf l =
  match l with [] -> () | _l -> pf ppf " %a" printer l

type 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 = Text.mut * storage_type

let pp_field_type fmt (m, st) =
  Fmt.pf fmt "%a %a" Text.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) =
  match ((m1 : Text.mut), (m2 : Text.mut)) with
  | Const, Const | Var, Var -> storage_type_eq st1 st2
  | _ -> false

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

(* Two type indices are equivalent when they occupy the same position inside two
   rec groups of the same size whose members are pairwise structurally
   equivalent. *)

module PairSet = Set.Make (struct
  type t = int * int

  let compare (a1, b1) (a2, b2) =
    let c = Int.compare a1 a2 in
    if c <> 0 then c else Int.compare b1 b2
end)

(** [iso_group_bounds types type_groups i] returns [(group_start, group_size)]
    for the rec group that contains [i]. *)
let iso_group_bounds types groups i =
  if i < Array.length groups then groups.(i)
  else if i < Array.length types then (i, 1)
  else (i, 1)

(** [is_iso_equiv_aux exp_types exp_tg imp_types imp_tg visited a b] tests
    whether the types identified by indices [a] (in [exp_types]) and [b] (in
    [imp_types]) are structurally equivalent. *)
let rec is_iso_equiv_aux exp_types exp_tg imp_types imp_tg visited a b =
  if PairSet.mem (a, b) visited then (true, visited)
  else
    let visited = PairSet.add (a, b) visited in
    let ga, gsize_a = iso_group_bounds exp_types exp_tg a in
    let gb, gsize_b = iso_group_bounds imp_types imp_tg b in
    if gsize_a <> gsize_b || a - ga <> b - gb then (false, visited)
    else iso_groups exp_types exp_tg imp_types imp_tg visited ga gb gsize_a

(** [iso_groups exp_types exp_tg imp_types imp_tg visited ga gb size] checks
    that all [size] member pairs [(ga+i, gb+i)] are pairwise equivalent via
    [iso_sub_type]. *)
and iso_groups exp_types exp_tg imp_types imp_tg visited ga gb size =
  let rec aux i visited =
    if i >= size then (true, visited)
    else
      let id_a = ga + i
      and id_b = gb + i in
      if id_a >= Array.length exp_types || id_b >= Array.length imp_types then
        (false, visited)
      else
        let ok, visited =
          iso_sub_type exp_types exp_tg imp_types imp_tg visited ga gb size
            exp_types.(id_a) imp_types.(id_b)
        in
        if ok then aux (i + 1) visited else (false, visited)
  in
  aux 0 visited

and iso_sub_type exp_types exp_tg imp_types imp_tg visited ga gb size st_a st_b
    =
  if not (Bool.equal st_a.final st_b.final) then (false, visited)
  else if List.length st_a.ids <> List.length st_b.ids then (false, visited)
  else
    let ok, visited =
      List.fold_left2
        (fun (ok, visited) id_a id_b ->
          if not ok then (false, visited)
          else
            iso_heap_type exp_types exp_tg imp_types imp_tg visited ga gb size
              (TypeUse id_a) (TypeUse id_b) )
        (true, visited) st_a.ids st_b.ids
    in
    if not ok then (false, visited)
    else
      iso_comp_type exp_types exp_tg imp_types imp_tg visited ga gb size st_a.ct
        st_b.ct

and iso_comp_type exp_types exp_tg imp_types imp_tg visited ga gb size ct_a ct_b
    =
  match (ct_a, ct_b) with
  | Def_func_t (pt_a, rt_a), Def_func_t (pt_b, rt_b) ->
    if
      List.length pt_a <> List.length pt_b
      || List.length rt_a <> List.length rt_b
    then (false, visited)
    else
      let ok, visited =
        List.fold_left2
          (fun (ok, visited) (_, vt_a) (_, vt_b) ->
            if not ok then (false, visited)
            else
              iso_val_type exp_types exp_tg imp_types imp_tg visited ga gb size
                vt_a vt_b )
          (true, visited) pt_a pt_b
      in
      if not ok then (false, visited)
      else
        List.fold_left2
          (fun (ok, visited) vt_a vt_b ->
            if not ok then (false, visited)
            else
              iso_val_type exp_types exp_tg imp_types imp_tg visited ga gb size
                vt_a vt_b )
          (true, visited) rt_a rt_b
  | Def_struct_t fl_a, Def_struct_t fl_b ->
    if List.length fl_a <> List.length fl_b then (false, visited)
    else
      List.fold_left2
        (fun (ok, visited) (_, ft_a) (_, ft_b) ->
          if not ok then (false, visited)
          else
            iso_field_type exp_types exp_tg imp_types imp_tg visited ga gb size
              ft_a ft_b )
        (true, visited) fl_a fl_b
  | Def_array_t ft_a, Def_array_t ft_b ->
    iso_field_type exp_types exp_tg imp_types imp_tg visited ga gb size ft_a
      ft_b
  | _ -> (false, visited)

and iso_field_type exp_types exp_tg imp_types imp_tg visited ga gb size
  (mut_a, st_a) (mut_b, st_b) =
  if not (Bool.equal (Text.is_mut mut_a) (Text.is_mut mut_b)) then
    (false, visited)
  else
    iso_storage_type exp_types exp_tg imp_types imp_tg visited ga gb size st_a
      st_b

and iso_storage_type exp_types exp_tg imp_types imp_tg visited ga gb size st_a
  st_b =
  match (st_a, st_b) with
  | Pack_type Text.I8, Pack_type Text.I8
  | Pack_type Text.I16, Pack_type Text.I16 ->
    (true, visited)
  | Val_type vt_a, Val_type vt_b ->
    iso_val_type exp_types exp_tg imp_types imp_tg visited ga gb size vt_a vt_b
  | _ -> (false, visited)

and iso_val_type exp_types exp_tg imp_types imp_tg visited ga gb size vt_a vt_b
    =
  match (vt_a, vt_b) with
  | Num_type nt_a, Num_type nt_b -> (Text.num_type_eq nt_a nt_b, visited)
  | Ref_type (null_a, ht_a), Ref_type (null_b, ht_b) -> (
    match (null_a, null_b) with
    | Text.Null, Text.Null | Text.No_null, Text.No_null ->
      iso_heap_type exp_types exp_tg imp_types imp_tg visited ga gb size ht_a
        ht_b
    | _ -> (false, visited) )
  | _ -> (false, visited)

and iso_heap_type exp_types exp_tg imp_types imp_tg visited ga gb size ht_a ht_b
    =
  match (ht_a, ht_b) with
  | TypeUse id_a, TypeUse id_b ->
    let a_in = id_a >= ga && id_a < ga + size in
    let b_in = id_b >= gb && id_b < gb + size in
    if a_in && b_in then (id_a - ga = id_b - gb, visited)
    else if (not a_in) && not b_in then
      is_iso_equiv_aux exp_types exp_tg imp_types imp_tg visited id_a id_b
    else (false, visited)
  | _ -> (heap_type_eq ht_a ht_b, visited)

(** iso-equivalence: checks whether type [a] in [(exp_types, exp_tg)] and type
    [b] in [(imp_types, imp_tg)] are structurally equivalent — same rec-group
    size, same relative position, pairwise equivalent members. *)
let is_iso_equiv exp_types exp_tg imp_types imp_tg a b =
  fst (is_iso_equiv_aux exp_types exp_tg imp_types imp_tg PairSet.empty a b)

(** Subtype check across modules: is [exp_types[got]] a structural subtype of
    [imp_types[expected]]? Checks iso-equivalence first, then follows the [ids]
    supertype chain in [exp_types]. *)
let is_subtype exp_types exp_tg imp_types imp_tg ~got ~expected =
  let rec aux a b =
    is_iso_equiv exp_types exp_tg imp_types imp_tg a b
    ||
    if a >= Array.length exp_types then false
    else
      List.exists
        (fun id -> (not (Int.equal id a)) && aux id b)
        exp_types.(a).ids
  in
  aux got expected

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 = indice option * func_type

type nonrec memarg =
  { offset : Int64.t
  ; align : Int32.t
  }

let pp_memarg =
  let pow_2 n =
    assert (Int32.le 0l n);
    Int32.shl 1l n
  in
  fun ppf { offset; align } ->
    let pp_offset ppf offset =
      if Int64.lt_u 0L offset then pf ppf " offset=%Ld" offset
    in
    pf ppf "%a align=%ld" pp_offset offset (pow_2 align)

(* 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

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

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

(** 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 Text.nn
  | Trunc_f_u of Text.nn
  | Trunc_sat_f_s of Text.nn
  | Trunc_sat_f_u of Text.nn
  | Reinterpret_f of Text.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" Text.pp_nn nn
  | Trunc_f_u nn -> pf ppf "i32.trunc_f%a_u" Text.pp_nn nn
  | Trunc_sat_f_s nn -> pf ppf "i32.truc_sat_f%a_s" Text.pp_nn nn
  | Trunc_sat_f_u nn -> pf ppf "i32.truc_sat_f%a_u" Text.pp_nn nn
  | Reinterpret_f nn -> pf ppf "i32.reinterpret_f%a" Text.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 Text.nn
  | Trunc_f_u of Text.nn
  | Trunc_sat_f_s of Text.nn
  | Trunc_sat_f_u of Text.nn
  | Reinterpret_f of Text.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" Text.pp_nn nn
  | Trunc_f_u nn -> pf ppf "i64.trunc_f%a_u" Text.pp_nn nn
  | Trunc_sat_f_s nn -> pf ppf "i64.trunc_sat_f%a_s" Text.pp_nn nn
  | Trunc_sat_f_u nn -> pf ppf "i64.trunc_sat_f%a_u" Text.pp_nn nn
  | Reinterpret_f nn -> pf ppf "i64.reinterpret_f%a" Text.pp_nn nn
  | Load (indice, memarg) ->
    pf ppf "i64.load_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_s (indice, memarg) ->
    pf ppf "i64.load8_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load8_u (indice, memarg) ->
    pf ppf "i64.load8_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_s (indice, memarg) ->
    pf ppf "i64.load16_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load16_u (indice, memarg) ->
    pf ppf "i64.load16_s%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32_s (indice, memarg) ->
    pf ppf "i64.load32_u%a%a" pp_indice_not0 indice pp_memarg memarg
  | Load32_u (indice, memarg) ->
    pf ppf "i64.load32_s%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 Text.nn
  | Convert_i_u of Text.nn
  | Reinterpret_i of Text.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" Text.pp_nn nn
  | Convert_i_u nn -> pf ppf "f32.convert_i%a_u" Text.pp_nn nn
  | Reinterpret_i nn -> pf ppf "f32.reinterpret_i%a" Text.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 Text.nn
  | Convert_i_u of Text.nn
  | Reinterpret_i of Text.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" Text.pp_nn nn
  | Convert_i_u nn -> pf ppf "f64.convert_i%a_u" Text.pp_nn nn
  | Reinterpret_i nn -> pf ppf "f64.reinterpret_i%a" Text.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

(** 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 (0, 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

(** 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

type simple_instruction =
  | I32 of i32_instr
  | I64 of i64_instr
  | F32 of f32_instr
  | F64 of f64_instr
  | V128 of v128_instr
  | I8x16 of Text.i8x16_instr
  | I16x8 of Text.i16x8_instr
  | I32x4 of Text.i32x4_instr
  | I64x2 of Text.i64x2_instr
  | F32x4 of Text.f32x4_instr
  | F64x2 of Text.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 Text.i31_instr
  | Struct of struct_instr
  | Array of array_instr
  | Drop
  | Select of val_type list option
  | Nop
  | Unreachable
  | Any_convert_extern
  | Extern_convert_any

(** Instructions *)
type instr =
  | Simple of simple_instruction
  (* Parametric instructions *)
  | Block of string option * block_type option * expr Annotated.t
  | Loop of string option * block_type option * expr Annotated.t
  | If_else of
      string option * block_type option * expr Annotated.t * expr Annotated.t
  | 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

and expr = instr Annotated.t list

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

let pp_simple_instruction 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 -> Text.pp_i8x16_instr ppf i
  | I16x8 i -> Text.pp_i16x8_instr ppf i
  | I32x4 i -> Text.pp_i32x4_instr ppf i
  | I64x2 i -> Text.pp_i64x2_instr ppf i
  | F32x4 i -> Text.pp_f32x4_instr ppf i
  | F64x2 i -> Text.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 -> Text.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"
  | Any_convert_extern -> pf ppf "any.convert_extern"
  | Extern_convert_any -> pf ppf "extern.convert_any"

let rec pp_instr ~short ppf = function
  | Simple i -> pp_simple_instruction ppf i
  | Block (id, bt, e) ->
    if short then pf ppf "block%a%a" Text.pp_id_opt id pp_block_type_opt bt
    else
      pf ppf "(block%a%a@\n  @[<v>%a@])" Text.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" Text.pp_id_opt id pp_block_type_opt bt
    else
      pf ppf "(loop%a%a@\n  @[<v>%a@])" Text.pp_id_opt id pp_block_type_opt bt
        (pp_expr ~short) e
  | If_else (id, bt, e1, e2) ->
    let pp_else ppf e =
      Annotated.iter
        (function
          | [] -> ()
          | _ -> pf ppf "@\n(else@\n  @[<v>%a@]@\n)" (pp_expr ~short) e )
        e
    in
    if short then pf ppf "if%a%a" Text.pp_id_opt id pp_block_type_opt bt
    else
      pf ppf "(if%a%a@\n  @[<v>(then@\n  @[<v>%a@]@\n)%a@]@\n)" Text.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

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

let rec iter_expr f (e : expr Annotated.t) =
  Annotated.iter (List.iter (iter_instr f)) e

and iter_instr f instr =
  Annotated.iter f instr;
  Annotated.iter
    (function
      | Simple _ | Br _ | Br_if _
      | Br_table (_, _)
      | Br_on_null _ | Br_on_non_null _
      | Br_on_cast (_, _, _)
      | Br_on_cast_fail (_, _, _)
      | Return | Return_call _
      | Return_call_indirect (_, _)
      | Return_call_ref _ | Call _
      | Call_indirect (_, _)
      | Call_ref _ ->
        ()
      | Block (_, _, e) | Loop (_, _, e) -> iter_expr f e
      | If_else (_, _, e1, e2) ->
        iter_expr f e1;
        iter_expr f e2 )
    instr

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

(* Modules *)

(* Tags *)
module Tag = struct
  type t =
    { id : string option
    ; typ : block_type
    }
end

(** named export *)
module Export = struct
  type t =
    { name : string
    ; id : int
    }
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)" (Fmt.option Fmt.string) 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

(** Precompute a mapping from each type index to [(group_start, group_size)] for
    its rec group. Types not in a [rec] block form singleton groups.

    TODO: use iarray? *)
let compute_type_groups (type_defs : Typedef.t array) types_len =
  let groups = Array.make types_len (0, 1) in
  let _ =
    Array.fold_left
      (fun pos typedef ->
        match typedef with
        | Typedef.SimpleType _ ->
          groups.(pos) <- (pos, 1);
          pos + 1
        | Typedef.RecType members ->
          let size = List.length members in
          List.iteri (fun i _ -> groups.(pos + i) <- (pos, size)) members;
          pos + size )
      0 type_defs
  in
  groups

module Table = struct
  module Type = struct
    type limits =
      | I32 of
          { min : Int32.t
          ; max : Int32.t option
          }
      | I64 of
          { min : Int64.t
          ; max : Int64.t option
          }

    let pp_limits ppf = function
      | I32 { min; max = None } -> pf ppf "%ld" min
      | I32 { min; max = Some max } -> pf ppf "%ld %ld" min max
      | I64 { min; max = None } -> pf ppf "i64 %Ld" min
      | I64 { min; max = Some max } -> pf ppf "i64 %Ld %Ld" min max

    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 Annotated.t option
    }
end

module Mem = struct
  module Type = struct
    type limits =
      | I32 of
          { min : Int32.t
          ; max : Int32.t option
          }
      | I64 of
          { min : int
          ; max : int option
          }

    let pp_limits ppf = function
      | I32 { min; max = None } -> pf ppf "%ld" min
      | I32 { min; max = Some max } -> pf ppf "%ld %ld" min max
      | I64 { min; max = None } -> pf ppf "i64 %d" min
      | I64 { min; max = Some max } -> pf ppf "i64 %d %d" min max
  end

  type nonrec t = string option * Type.limits

  let pp ppf (id, ty) =
    pf ppf "(memory%a %a)"
      (Fmt.option ~none:Fmt.nop (fun ppf s -> Fmt.pf ppf " %s" s))
      id Type.pp_limits ty
end

module Global = struct
  module Type = struct
    type nonrec t = Text.mut * val_type
  end

  type t =
    { typ : Type.t (* TODO: init : binary+const expr*)
    ; init : expr Annotated.t
    ; id : string option
    }
end

module Data = struct
  module Mode = struct
    type t =
      | Passive
      (* TODO: Data_active binary+const expr*)
      | Active of int * expr Annotated.t
  end

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

module Elem = struct
  module Mode = struct
    type t =
      | Passive
      | Declarative
      | Active of int * expr Annotated.t
  end

  type t =
    { id : string option
    ; typ : ref_type (* TODO: init : binary+const expr*)
    ; init : expr Annotated.t list
    ; mode : Mode.t
    ; explicit_typ : bool
    }
end

module Custom = struct
  type t = Uninterpreted of string
end

module Module = struct
  module Exports = struct
    type t =
      { global : Export.t Array.t
      ; mem : Export.t Array.t
      ; table : Export.t Array.t
      ; func : Export.t Array.t
      ; tag : Export.t Array.t
      }
  end

  type t =
    { id : string option
    ; type_defs : Typedef.t array
    ; types : sub_type array
    ; global : (Global.t, Global.Type.t) Origin.t array
    ; table : (Table.t, Table.Type.t) Origin.t array
    ; mem : (Mem.t, Mem.Type.limits) Origin.t array
    ; func : (Func.t, block_type) Origin.t array (* TODO: switch to func_type *)
    ; tag : (Tag.t, block_type) Origin.t array
    ; elem : Elem.t array
    ; data : Data.t array
    ; exports : Exports.t
    ; start : int option
    ; custom : Custom.t list
    }

  let empty =
    { id = None
    ; type_defs = [||]
    ; types = [||]
    ; global = [||]
    ; table = [||]
    ; mem = [||]
    ; func = [||]
    ; elem = [||]
    ; data = [||]
    ; tag = [||]
    ; exports =
        { global = [||]; mem = [||]; table = [||]; func = [||]; tag = [||] }
    ; start = None
    ; custom = []
    }

  (** Functions *)

  (** Insert a function [f] to a module [m] at index [i] and returns the module.
      It will update all function indices accordingly. *)
  let insert_func_at_idx ?(update_function_itself = true) f m i =
    (* TODO: we should also update elements and everything... *)
    (*
    Log.warn (fun m ->
      m "insert_func_at_idx is still incomplete and you may run into issues" );
    *)
    let update_idx idx = if idx >= i then idx + 1 else idx in

    let rec handle_instr instr =
      Annotated.map
        (function
          | Call idx -> Call (update_idx idx)
          | Return_call idx -> Return_call (update_idx idx)
          | Simple (Ref (Func idx)) -> Simple (Ref (Func (update_idx idx)))
          | Block (id, typ, body) ->
            let body = handle_expr body in
            Block (id, typ, body)
          | Loop (id, typ, body) ->
            let body = handle_expr body in
            Loop (id, typ, body)
          | If_else (id, typ, true_branch, false_branch) ->
            let true_branch = handle_expr true_branch in
            let false_branch = handle_expr false_branch in
            If_else (id, typ, true_branch, false_branch)
          | instr ->
            (* TODO: make this match non fragile *)
            instr )
        instr
    and handle_expr expr =
      Annotated.map (fun expr -> List.map handle_instr expr) expr
    in
    let update_function = function
      | Origin.Imported _ as f -> f
      | Origin.Local (f : Func.t) ->
        let body = handle_expr f.body in
        Origin.Local { f with body }
    in
    let func =
      Array.init
        (Array.length m.func + 1)
        (fun j ->
          if i = j then if update_function_itself then update_function f else f
          else begin
            update_function @@ if i < j then m.func.(j - 1) else m.func.(j)
          end )
    in
    let elem =
      Array.map
        (fun (elem : Elem.t) ->
          let init = List.map handle_expr elem.init in
          { elem with init } )
        m.elem
    in
    let global =
      Array.map
        (function
          | Origin.Imported _ as v -> v
          | Local (global : Global.t) ->
            let init = handle_expr global.init in
            Local { global with init } )
        m.global
    in

    let start = Option.map update_idx m.start in

    let exports =
      let func =
        Array.map
          (fun export ->
            let id = update_idx (export : Export.t).id in
            { export with id } )
          m.exports.func
      in
      { m.exports with func }
    in

    { m with func; elem; start; global; exports }

  (** Add a function [f] at the end of a module [m] and returns the module and
      the index of the added function. *)
  let add_func f m =
    let len = Array.length m.func in
    let func =
      Array.init
        (Array.length m.func + 1)
        (fun i -> if i = len then f else m.func.(i))
    in

    ({ m with func }, len)

  (** Return the type of the function at index [id]. *)
  let get_func_type id m =
    if id >= Array.length m.func then None
    else
      match m.func.(id) with
      | Local f -> Some f.type_f
      | Imported i -> Some i.typ

  let get_type id m =
    if id >= Array.length m.types then None else Some m.types.(id)

  (** Exports *)

  (** Return the first function exported as [name] if it exists. Return [None]
      otherwise.*)
  let find_exported_func_from_name name m =
    Array.find_opt
      (function { Export.name = name'; _ } -> String.equal name name')
      m.exports.func

  (** Imports *)

  (** Return the index of a function imported from a given [modul_name] and
      [func_name] if it exists. Return [None] otherwise. *)
  let find_imported_func_index ~modul_name ~func_name m =
    Array.find_index
      (function
        | Origin.Imported
            { Origin.modul_name = modul_name'
            ; name
            ; assigned_name = _
            ; typ = _
            } ->
          String.equal modul_name modul_name' && String.equal func_name name
        | Local _ -> false )
      m.func

  (** Finds the index of the last imported function. Will be `~-1` if there are
      no imported functions. *)
  let find_last_import_index m =
    let _i, last =
      Array.fold_left
        (fun (i, last) -> function
          | Origin.Imported _ -> (succ i, i) | Origin.Local _ -> (succ i, last) )
        (0, ~-1) m.func
    in
    last

  (** Look for an imported function index, adding it if not already imported. *)
  let add_import_if_not_present ~modul_name ~func_name ~typ m =
    match find_imported_func_index ~modul_name ~func_name m with
    | Some _i -> m
    | None ->
      let f =
        Origin.imported ~modul_name ~name:func_name ~assigned_name:None ~typ
      in

      let idx = find_last_import_index m + 1 in

      insert_func_at_idx f m idx
end
src/ir/binary.ml

52.52%
