binary_to_text.ml — Coverage report

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

let convert_indice : Binary.indice -> Text.indice = function i -> Text.Raw i

let convert_heap_type : Binary.heap_type -> Text.heap_type = function
  | TypeUse id -> TypeUse (Raw id)
  | Any_ht -> Any_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

let convert_ref_type ((n, ht) : Binary.ref_type) : Text.ref_type =
  (n, convert_heap_type ht)

let convert_val_type : Binary.val_type -> Text.val_type = function
  | Num_type nt -> Num_type nt
  | Ref_type rt -> Ref_type (convert_ref_type rt)

let convert_func_type ((pt, rt) : Binary.func_type) : Text.func_type =
  ( List.map (fun (id, vt) -> (id, convert_val_type vt)) pt
  , List.map convert_val_type rt )

let convert_block_type : Binary.block_type -> Text.block_type = function
  | Binary.Bt_raw (opt, ft) ->
    let opt = Option.map convert_indice opt in
    Text.Bt_raw (opt, convert_func_type ft)

let convert_memarg ({ offset; align } : Binary.memarg) : Text.memarg =
  let offset =
    if Int64.lt 0L offset then Some (Int64.to_string_u offset) else None
  in
  let align =
    assert (Int32.le 0l align);
    Some (Int32.to_string_u (Int32.shl 1l align))
  in
  { offset; align }

let rec convert_instr : Binary.instr -> Text.instr = function
  | Binary.Br_table (ids, id) ->
    let ids = Array.map convert_indice ids in
    let id = convert_indice id in
    Text.Br_table (ids, id)
  | Br_if id ->
    let id = convert_indice id in
    Br_if id
  | Br id ->
    let id = convert_indice id in
    Br id
  | Br_on_null id ->
    let id = convert_indice id in
    Br_on_null id
  | Br_on_non_null id ->
    let id = convert_indice id in
    Br_on_non_null id
  | Call id ->
    let id = convert_indice id in
    Call id
  | Return_call id ->
    let id = convert_indice id in
    Return_call id
  | Local_set id ->
    let id = convert_indice id in
    Local_set id
  | Local_get id ->
    let id = convert_indice id in
    Local_get id
  | Local_tee id ->
    let id = convert_indice id in
    Local_tee id
  | If_else (id, bt, e1, e2) ->
    let bt = Option.map convert_block_type bt in
    let e1 = convert_expr e1 in
    let e2 = convert_expr e2 in
    If_else (id, bt, e1, e2)
  | Loop (id, bt, e) ->
    let bt = Option.map convert_block_type bt in
    let e = convert_expr e in
    Loop (id, bt, e)
  | Block (id, bt, e) ->
    let bt = Option.map convert_block_type bt in
    let e = convert_expr e in
    Block (id, bt, e)
  | Call_indirect (tbl_i, bt) ->
    let tbl_i = convert_indice tbl_i in
    let bt = convert_block_type bt in
    Call_indirect (tbl_i, bt)
  | Return_call_indirect (tbl_i, bt) ->
    let tbl_i = convert_indice tbl_i in
    let bt = convert_block_type bt in
    Return_call_indirect (tbl_i, bt)
  | Call_ref t ->
    let t = convert_indice t in
    Call_ref t
  | Return_call_ref bt ->
    let bt = convert_block_type bt in
    Return_call_ref bt
  | Global_set id ->
    let id = convert_indice id in
    Global_set id
  | Global_get id ->
    let id = convert_indice id in
    Global_get id
  | Ref_func id ->
    let id = convert_indice id in
    Ref_func id
  | Table_size id ->
    let id = convert_indice id in
    Table_size id
  | Table_get id ->
    let id = convert_indice id in
    Table_get id
  | Table_set id ->
    let id = convert_indice id in
    Table_set id
  | Table_grow id ->
    let id = convert_indice id in
    Table_grow id
  | Table_init (i, i') ->
    let table = convert_indice i in
    let elem = convert_indice i' in
    Table_init (table, elem)
  | Table_fill id ->
    let id = convert_indice id in
    Table_fill id
  | Table_copy (i, i') ->
    let table = convert_indice i in
    let table' = convert_indice i' in
    Table_copy (table, table')
  | Memory_init (memidx, dataidx) ->
    let memidx = convert_indice memidx in
    let dataidx = convert_indice dataidx in
    Memory_init (memidx, dataidx)
  | Data_drop id ->
    let id = convert_indice id in
    Data_drop id
  | Elem_drop id ->
    let id = convert_indice id in
    Elem_drop id
  | Select typ -> begin
    match typ with
    | None -> Select None
    | Some [ t ] -> Select (Some [ convert_val_type t ])
    | Some [] | Some (_ :: _ :: _) ->
      (* invalid result arity *)
      (* TODO: maybe we could change the type of Binary.Select to prevent this from happening? *)
      assert false
  end
  | I_unop (nn, op) -> I_unop (nn, op)
  | I_binop (nn, op) -> I_binop (nn, op)
  | I_testop (nn, op) -> I_testop (nn, op)
  | I_relop (nn, op) -> I_relop (nn, op)
  | F_unop (nn, op) -> F_unop (nn, op)
  | F_relop (nn, op) -> F_relop (nn, op)
  | I32_wrap_i64 -> I32_wrap_i64
  | F_reinterpret_i (nn1, nn2) -> F_reinterpret_i (nn1, nn2)
  | I_reinterpret_f (nn1, nn2) -> I_reinterpret_f (nn1, nn2)
  | I64_extend_i32 sx -> I64_extend_i32 sx
  | I64_extend32_s -> I64_extend32_s
  | F32_demote_f64 -> F32_demote_f64
  | I_extend8_s nn -> I_extend8_s nn
  | I_extend16_s nn -> I_extend16_s nn
  | F64_promote_f32 -> F64_promote_f32
  | F_convert_i (nn1, nn2, sx) -> F_convert_i (nn1, nn2, sx)
  | I_trunc_f (nn1, nn2, sx) -> I_trunc_f (nn1, nn2, sx)
  | I_trunc_sat_f (nn1, nn2, sx) -> I_trunc_sat_f (nn1, nn2, sx)
  | Ref_as_non_null -> Ref_as_non_null
  | Ref_is_null -> Ref_is_null
  | F_binop (nn, op) -> F_binop (nn, op)
  | F32_const v -> F32_const v
  | F64_const v -> F64_const v
  | I32_const v -> I32_const v
  | I64_const v -> I64_const v
  | V128_const v -> V128_const v
  | Unreachable -> Unreachable
  | Drop -> Drop
  | Nop -> Nop
  | Return -> Return
  | Extern_externalize -> Extern_externalize
  | Extern_internalize -> Extern_internalize
  | I_load8 (id, nn, sx, memarg) ->
    I_load8 (convert_indice id, nn, sx, convert_memarg memarg)
  | I_store8 (id, nn, memarg) ->
    I_store8 (convert_indice id, nn, convert_memarg memarg)
  | I_load16 (id, nn, sx, memarg) ->
    I_load16 (convert_indice id, nn, sx, convert_memarg memarg)
  | I_store16 (id, nn, memarg) ->
    I_store16 (convert_indice id, nn, convert_memarg memarg)
  | I64_load32 (id, sx, memarg) ->
    I64_load32 (convert_indice id, sx, convert_memarg memarg)
  | I64_store32 (id, memarg) ->
    I64_store32 (convert_indice id, convert_memarg memarg)
  | I_load (id, nn, memarg) ->
    I_load (convert_indice id, nn, convert_memarg memarg)
  | F_load (id, nn, memarg) ->
    F_load (convert_indice id, nn, convert_memarg memarg)
  | F_store (id, nn, memarg) ->
    F_store (convert_indice id, nn, convert_memarg memarg)
  | I_store (id, nn, memarg) ->
    I_store (convert_indice id, nn, convert_memarg memarg)
  | Memory_copy (id1, id2) ->
    Memory_copy (convert_indice id1, convert_indice id2)
  | Memory_size id -> Memory_size (convert_indice id)
  | Memory_fill id -> Memory_fill (convert_indice id)
  | Memory_grow id -> Memory_grow (convert_indice id)
  | V_ibinop (shape, op) -> V_ibinop (shape, op)
  | Ref_null t -> Ref_null (convert_heap_type t)

and convert_expr (e : Binary.expr Annotated.t) : Text.expr Annotated.t =
  Annotated.map
    (fun (e : Binary.expr) ->
      List.map (fun i -> Annotated.map convert_instr i) e )
    e

let convert_elem_mode : Binary.Elem.Mode.t -> Text.Elem.Mode.t = function
  | Binary.Elem.Mode.Passive -> Text.Elem.Mode.Passive
  | Declarative -> Declarative
  | Active (opt, e) ->
    let opt = Option.map (fun i -> Text.Raw i) opt in
    let e = convert_expr e in
    Active (opt, e)

let convert_elem : Binary.Elem.t -> Text.Elem.t = function
  | { Binary.Elem.id; typ; init; mode; explicit_typ } ->
    let init = List.map convert_expr init in
    let mode = convert_elem_mode mode in
    { Text.Elem.id; typ = convert_ref_type typ; init; mode; explicit_typ }

let convert_data_mode : Binary.Data.Mode.t -> Text.Data.Mode.t = function
  | Binary.Data.Mode.Passive -> Text.Data.Mode.Passive
  | Active (i, e) ->
    let e = convert_expr e in
    Active (Some (Raw i), e)

let convert_data : Binary.Data.t -> Text.Data.t = function
  | { Binary.Data.id; init; mode } ->
    let mode = convert_data_mode mode in
    { Text.Data.id; init; mode }

let from_types types : Text.Module.Field.t list =
  Array.map
    (fun ((id, ft) : Binary.Typedef.t) ->
      Text.Module.Field.Typedef (id, convert_func_type ft) )
    types
  |> Array.to_list

let from_global (global : (Binary.Global.t, Binary.Global.Type.t) Origin.t array)
  : Text.Module.Field.t list =
  Array.map
    (function
      | Origin.Local ({ typ = mut, vt; init; id } : Binary.Global.t) ->
        let init = convert_expr init in
        let typ = (mut, convert_val_type vt) in
        Text.Module.Field.Global { typ; init; id }
      | Imported { modul_name; name; assigned_name; typ = mut, vt } ->
        let typ =
          Text.Import.Type.Global (assigned_name, (mut, convert_val_type vt))
        in
        Text.Module.Field.Import { modul_name; name; typ } )
    global
  |> Array.to_list

let convert_table_limits : Binary.Table.Type.limits -> Text.limits = function
  | I64 { min; max } ->
    { is_i64 = true
    ; min = Int64.to_string_u min
    ; max = Option.map Int64.to_string_u max
    }
  | I32 { min; max } ->
    { is_i64 = false
    ; min = Int32.to_string_u min
    ; max = Option.map Int32.to_string_u max
    }

let from_table table : Text.Module.Field.t list =
  Array.map
    (function
      | Origin.Local Binary.Table.{ id; typ = limits, rt; init } ->
        let init = Option.map convert_expr init in
        Text.Module.Field.Table
          { id; typ = (convert_table_limits limits, convert_ref_type rt); init }
      | Imported { modul_name; name; assigned_name; typ = limits, rt } ->
        let typ =
          Text.Import.Type.Table
            (assigned_name, (convert_table_limits limits, convert_ref_type rt))
        in
        Import { modul_name; name; typ } )
    table
  |> Array.to_list

let convert_mem_limits : Binary.Mem.Type.limits -> Text.limits = function
  | I64 { min; max } ->
    { is_i64 = true
    ; min = Int.to_string min
    ; max = Option.map Int.to_string max
    }
  | I32 { min; max } ->
    { is_i64 = false
    ; min = Int32.to_string_u min
    ; max = Option.map Int32.to_string_u max
    }

let from_mem mem : Text.Module.Field.t list =
  Array.map
    (function
      | Origin.Local (name, t) ->
        Text.Module.Field.Mem (name, convert_mem_limits t)
      | Imported { modul_name; name; assigned_name; typ } ->
        let typ =
          Text.Import.Type.Mem (assigned_name, convert_mem_limits typ)
        in
        Import { modul_name; name; typ } )
    mem
  |> Array.to_list

let from_func func : Text.Module.Field.t list =
  Array.map
    (function
      | Origin.Local (func : Binary.Func.t) ->
        let type_f = convert_block_type func.type_f in
        let body = convert_expr func.body in
        let id = func.id in
        let locals =
          List.map (fun (id, vt) -> (id, convert_val_type vt)) func.locals
        in
        Text.Module.Field.Func { type_f; locals; body; id }
      | Imported { modul_name; name; assigned_name; typ } ->
        let typ = convert_block_type typ in
        let typ = Text.Import.Type.Func (assigned_name, typ) in
        Text.Module.Field.Import { modul_name; name; typ } )
    func
  |> Array.to_list

let from_elem elem : Text.Module.Field.t list =
  Array.map
    (fun (elem : Binary.Elem.t) ->
      let elem = convert_elem elem in
      Text.Module.Field.Elem elem )
    elem
  |> Array.to_list

let from_data data : Text.Module.Field.t list =
  Array.map
    (fun (data : Binary.Data.t) ->
      let data = convert_data data in
      Text.Module.Field.Data data )
    data
  |> Array.to_list

let from_exports (exports : Binary.Module.Exports.t) : Text.Module.Field.t list
    =
  let global =
    Array.map
      (fun ({ name; id } : Binary.Export.t) ->
        let id = Some (Text.Raw id) in
        Text.Module.Field.Export { name; typ = Global id } )
      exports.global
  in

  let mem =
    Array.map
      (fun ({ name; id } : Binary.Export.t) ->
        let id = Some (Text.Raw id) in
        Text.Module.Field.Export { name; typ = Mem id } )
      exports.mem
  in

  let table =
    Array.map
      (fun ({ name; id } : Binary.Export.t) ->
        let id = Some (Text.Raw id) in
        Text.Module.Field.Export { name; typ = Table id } )
      exports.table
  in

  let func =
    Array.map
      (fun ({ name; id } : Binary.Export.t) ->
        let id = Some (Text.Raw id) in
        Text.Module.Field.Export { name; typ = Func id } )
      exports.func
  in

  Array.to_list global @ Array.to_list mem @ Array.to_list table
  @ Array.to_list func

let from_start = function
  | None -> []
  | Some n -> [ Text.Module.Field.Start (Raw n) ]

let modul
  { Binary.Module.id
  ; types
  ; global
  ; table
  ; mem
  ; func
  ; elem
  ; data
  ; start
  ; exports
  ; _
  } =
  let fields =
    from_types types @ from_global global @ from_table table @ from_mem mem
    @ from_func func @ from_elem elem @ from_data data @ from_exports exports
    @ from_start start
  in
  let imported, locals =
    List.partition_map
      (function
        | Text.Module.Field.Import _ as import -> Either.Left import
        | local -> Either.Right local )
      fields
  in
  let fields = imported @ locals in

  { Text.Module.id; fields }
src/compile/binary_to_text.ml

57.65%
