interpreter_encodings.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Tezos_webassembly_interpreter
open Data_encoding_utils
let string_enum cases =
let open Data_encoding in
match cases with
| [(title, value)] -> conv (fun _ -> ()) (fun () -> value) (constant title)
| cases -> string_enum cases
module Source = struct
open Source
let phrase_encoding encoding =
let open Data_encoding in
conv (fun x -> x.it) (fun v -> v @@ no_region) encoding
end
module Types = struct
open Types
let i32_case f = ("i32", f I32Type)
let i64_case f = ("i64", f I64Type)
let num_type_cases f = [i32_case f; i64_case f]
let num_type_encoding = string_enum (num_type_cases Fun.id)
let v128_case f = ("v128", f V128Type)
let vec_type_cases f = [v128_case f]
let vec_type_encoding = string_enum (vec_type_cases Fun.id)
let funcref_case f = ("funcref", f FuncRefType)
let externref_case f = ("externref", f ExternRefType)
let ref_type_cases f = [funcref_case f; externref_case f]
let ref_type_encoding = string_enum (ref_type_cases Fun.id)
let value_type_cases f =
num_type_cases (fun nt -> f (NumType nt))
@ vec_type_cases (fun vt -> f (VecType vt))
@ ref_type_cases (fun rt -> f (RefType rt))
let value_type_encoding = string_enum (value_type_cases Fun.id)
let result_type_encoding =
(* : #3076
Once the AST is adapted this must not be a list but a lazy structure. *)
Data_encoding.list value_type_encoding
let func_type_encoding ~params_encoding ~result_encoding =
let open Data_encoding in
conv
(fun (FuncType (params, result)) -> (params, result))
(fun (params, result) -> FuncType (params, result))
(obj2 (req "params" params_encoding) (req "result" result_encoding))
let mutability_encoding =
string_enum [("mutable", Mutable); ("immutable", Immutable)]
let pack_size_encoding =
string_enum
[
("Pack8", Pack8);
("Pack16", Pack16);
("Pack32", Pack32);
("Pack64", Pack64);
]
let pack_shape_encoding =
string_enum
[("Pack8x8", Pack8x8); ("Pack16x4", Pack16x4); ("Pack32x2", Pack32x2)]
let extension_encoding = string_enum [("SX", SX); ("ZX", ZX)]
let vec_extension_encoding =
let open Data_encoding in
union_incr
[
case_incr
"ExtLane"
(obj2
(req "pack_shape" pack_shape_encoding)
(req "extension" extension_encoding))
(function ExtLane (x, y) -> Some (x, y) | _ -> None)
(fun (x, y) -> ExtLane (x, y));
unit_case_incr "ExtSplat" ExtSplat;
unit_case_incr "ExtZero" ExtZero;
]
let global_type_encoding =
let open Data_encoding in
conv
(fun (Types.GlobalType (v, m)) -> (v, m))
(fun (v, m) -> Types.GlobalType (v, m))
(tup2 value_type_encoding mutability_encoding)
let limits_encoding value_encoding =
let open Data_encoding in
conv
(fun {min; max} -> (min, max))
(fun (min, max) -> {min; max})
(tup2 value_encoding (option value_encoding))
let table_type_encoding =
let open Data_encoding in
conv
(fun (TableType (l, r)) -> (l, r))
(fun (l, r) -> TableType (l, r))
(tup2 (limits_encoding int32) ref_type_encoding)
let memory_type_encoding =
let open Data_encoding in
conv
(fun (MemoryType l) -> l)
(fun l -> MemoryType l)
(limits_encoding int32)
end
module Values = struct
open Values
let op_encoding i32 i64 =
union_incr
[
case_incr
"I32"
i32
(function I32 x -> Some x | _ -> None)
(fun x -> I32 x);
case_incr
"I64"
i64
(function I64 x -> Some x | _ -> None)
(fun x -> I64 x);
]
let vecop_encoding v128 =
union_incr
[case_incr "V128" v128 (function V128 x -> Some x) (fun x -> V128 x)]
let num_encoding : num Data_encoding.t =
let open Data_encoding in
op_encoding int32 int64
let vec_encoding =
let open Data_encoding in
vecop_encoding (conv V128.to_bits V128.of_bits string)
end
module V128 = struct
open V128
let laneop_encoding i8x16 i16x8 i32x4 i64x2 =
union_incr
[
case_incr
"I8x16"
i8x16
(function I8x16 x -> Some x | _ -> None)
(fun x -> I8x16 x);
case_incr
"I16x8"
i16x8
(function I16x8 x -> Some x | _ -> None)
(fun x -> I16x8 x);
case_incr
"I32x4"
i32x4
(function I32x4 x -> Some x | _ -> None)
(fun x -> I32x4 x);
case_incr
"I64x2"
i64x2
(function I64x2 x -> Some x | _ -> None)
(fun x -> I64x2 x);
]
end
module Ast = struct
open Ast
module IntOp = struct
open IntOp
let unop_encoding =
union_incr
[
unit_case_incr "Clz" Clz;
unit_case_incr "Ctz" Ctz;
unit_case_incr "Popcnt" Popcnt;
case_incr
"ExtendS"
Types.pack_size_encoding
(function ExtendS x -> Some x | _ -> None)
(fun x -> ExtendS x);
]
let binop_encoding =
union_incr
[
unit_case_incr "Add" Add;
unit_case_incr "Sub" Sub;
unit_case_incr "Mul" Mul;
unit_case_incr "DivS" DivS;
unit_case_incr "DivU" DivU;
unit_case_incr "RemS" RemS;
unit_case_incr "RemU" RemU;
unit_case_incr "And" And;
unit_case_incr "Or" Or;
unit_case_incr "Xor" Xor;
unit_case_incr "Shl" Shl;
unit_case_incr "ShrS" ShrS;
unit_case_incr "ShrU" ShrU;
unit_case_incr "Rotl" Rotl;
unit_case_incr "Rotr" Rotr;
]
let testop_encoding = union_incr [unit_case_incr "Eqz" Ast.IntOp.Eqz]
let relop_encoding =
union_incr
[
unit_case_incr "Eq" Eq;
unit_case_incr "Ne" Ne;
unit_case_incr "LtS" LtS;
unit_case_incr "LtU" LtU;
unit_case_incr "GtS" GtS;
unit_case_incr "GtU" GtU;
unit_case_incr "LeS" LeS;
unit_case_incr "LeU" LeU;
unit_case_incr "GeS" GeS;
unit_case_incr "GeU" GeU;
]
let cvtop_encoding =
union_incr
[
unit_case_incr "ExtendSI32" ExtendSI32;
unit_case_incr "ExtendUI32" ExtendUI32;
unit_case_incr "WrapI64" WrapI64;
unit_case_incr "TruncSF32" TruncSF32;
unit_case_incr "TruncUF32" TruncUF32;
unit_case_incr "TruncSF64" TruncSF64;
unit_case_incr "TruncUF64" TruncUF64;
unit_case_incr "TruncSatSF32" TruncSatSF32;
unit_case_incr "TruncSatUF32" TruncSatUF32;
unit_case_incr "TruncSatSF64" TruncSatSF64;
unit_case_incr "TruncSatUF64" TruncSatUF64;
unit_case_incr "ReinterpretFloat" ReinterpretFloat;
]
end
module V128Op = struct
open V128Op
let itestop_encoding = union_incr [unit_case_incr "AllTrue" AllTrue]
let iunop_encoding =
union_incr
[
unit_case_incr "Abs" (Abs : iunop);
unit_case_incr "Neg" (Neg : iunop);
unit_case_incr "Popcnt" Popcnt;
]
let ibinop_encoding =
let open Data_encoding in
union_incr
[
unit_case_incr "Add" (Add : ibinop);
unit_case_incr "Sub" (Sub : ibinop);
unit_case_incr "Mul" (Mul : ibinop);
unit_case_incr "MinS" MinS;
unit_case_incr "MinU" MinU;
unit_case_incr "MaxS" MaxS;
unit_case_incr "MaxU" MaxU;
unit_case_incr "AvgrU" AvgrU;
unit_case_incr "AddSatS" AddSatS;
unit_case_incr "AddSatU" AddSatU;
unit_case_incr "SubSatS" SubSatS;
unit_case_incr "SubSatU" SubSatU;
unit_case_incr "DotS" DotS;
unit_case_incr "Q15MulRSatS" Q15MulRSatS;
unit_case_incr "ExtMulLowS" ExtMulLowS;
unit_case_incr "ExtMulHighS" ExtMulHighS;
unit_case_incr "ExtMulLowU" ExtMulLowU;
unit_case_incr "ExtMulHighU" ExtMulHighU;
unit_case_incr "Swizzle" Swizzle;
case_incr
"Shuffle"
(list int8)
(function Shuffle ints -> Some ints | _ -> None)
(fun ints -> Shuffle ints);
unit_case_incr "NarrowS" NarrowS;
unit_case_incr "NarrowU" NarrowU;
]
let irelop_encoding =
union_incr
[
unit_case_incr "Eq" (Eq : irelop);
unit_case_incr "Ne" (Ne : irelop);
unit_case_incr "LtS" LtS;
unit_case_incr "LtU" LtU;
unit_case_incr "LeS" LeS;
unit_case_incr "LeU" LeU;
unit_case_incr "GtS" GtS;
unit_case_incr "GtU" GtU;
unit_case_incr "GeS" GeS;
unit_case_incr "GeU" GeU;
]
let icvtop_encoding =
union_incr
[
unit_case_incr "ExtendLowS" ExtendLowS;
unit_case_incr "ExtendLowU" ExtendLowU;
unit_case_incr "ExtendHighS" ExtendHighS;
unit_case_incr "ExtendHighU" ExtendHighU;
unit_case_incr "ExtAddPairwiseS" ExtAddPairwiseS;
unit_case_incr "ExtAddPairwiseU" ExtAddPairwiseU;
unit_case_incr "TruncSatSF32x4" TruncSatSF32x4;
unit_case_incr "TruncSatUF32x4" TruncSatUF32x4;
unit_case_incr "TruncSatSZeroF64x2" TruncSatSZeroF64x2;
unit_case_incr "TruncSatUZeroF64x2" TruncSatUZeroF64x2;
]
let ishiftop_encoding =
union_incr
[
unit_case_incr "Shl" Shl;
unit_case_incr "ShrS" ShrS;
unit_case_incr "ShrU" ShrU;
]
let ibitmaskop_encoding = union_incr [unit_case_incr "Bitmask" Bitmask]
let vtestop_encoding = union_incr [unit_case_incr "AnyTrue" AnyTrue]
let vunop_encoding = union_incr [unit_case_incr "Not" Not]
let vbinop_encoding =
union_incr
[
unit_case_incr "And" And;
unit_case_incr "Or" Or;
unit_case_incr "Xor" Xor;
unit_case_incr "AndNot" AndNot;
]
let vternop_encoding = union_incr [unit_case_incr "Bitselect" Bitselect]
let testop_encoding : testop Data_encoding.t =
V128.laneop_encoding
itestop_encoding
itestop_encoding
itestop_encoding
itestop_encoding
let unop_encoding : unop Data_encoding.t =
V128.laneop_encoding
iunop_encoding
iunop_encoding
iunop_encoding
iunop_encoding
let binop_encoding : binop Data_encoding.t =
V128.laneop_encoding
ibinop_encoding
ibinop_encoding
ibinop_encoding
ibinop_encoding
let relop_encoding : relop Data_encoding.t =
V128.laneop_encoding
irelop_encoding
irelop_encoding
irelop_encoding
irelop_encoding
let cvtop_encoding : cvtop Data_encoding.t =
V128.laneop_encoding
icvtop_encoding
icvtop_encoding
icvtop_encoding
icvtop_encoding
let shiftop_encoding : shiftop Data_encoding.t =
V128.laneop_encoding
ishiftop_encoding
ishiftop_encoding
ishiftop_encoding
ishiftop_encoding
let bitmaskop_encoding : bitmaskop Data_encoding.t =
V128.laneop_encoding
ibitmaskop_encoding
ibitmaskop_encoding
ibitmaskop_encoding
ibitmaskop_encoding
let nsplatop_encoding = union_incr [unit_case_incr "Splat" Splat]
let nextractop_encoding inner =
let open Data_encoding in
union_incr
[
case_incr
"Extract"
(tup2 Data_encoding.int31 inner)
(function Extract (x, y) -> Some (x, y))
(fun (x, y) -> Extract (x, y));
]
let nreplaceop_encoding =
union_incr
[
case_incr
"Replace"
Data_encoding.int31
(function Replace x -> Some x)
(fun x -> Replace x);
]
let splatop_encoding : splatop Data_encoding.t =
V128.laneop_encoding
nsplatop_encoding
nsplatop_encoding
nsplatop_encoding
nsplatop_encoding
let extractop_encoding : extractop Data_encoding.t =
let open Data_encoding in
V128.laneop_encoding
(nextractop_encoding Types.extension_encoding)
(nextractop_encoding Types.extension_encoding)
(nextractop_encoding unit)
(nextractop_encoding unit)
let replaceop_encoding : replaceop Data_encoding.t =
V128.laneop_encoding
nreplaceop_encoding
nreplaceop_encoding
nreplaceop_encoding
nreplaceop_encoding
end
let testop_encoding : Ast.testop Data_encoding.t =
Values.op_encoding IntOp.testop_encoding IntOp.testop_encoding
let unop_encoding : Ast.unop Data_encoding.t =
Values.op_encoding IntOp.unop_encoding IntOp.unop_encoding
let binop_encoding : Ast.binop Data_encoding.t =
Values.op_encoding IntOp.binop_encoding IntOp.binop_encoding
let relop_encoding : Ast.relop Data_encoding.t =
Values.op_encoding IntOp.relop_encoding IntOp.relop_encoding
let cvtop_encoding : Ast.cvtop Data_encoding.t =
Values.op_encoding IntOp.cvtop_encoding IntOp.cvtop_encoding
let vec_testop_encoding = Values.vecop_encoding V128Op.testop_encoding
let vec_relop_encoding = Values.vecop_encoding V128Op.relop_encoding
let vec_unop_encoding = Values.vecop_encoding V128Op.unop_encoding
let vec_binop_encoding = Values.vecop_encoding V128Op.binop_encoding
let vec_cvtop_encoding = Values.vecop_encoding V128Op.cvtop_encoding
let vec_shiftop_encoding = Values.vecop_encoding V128Op.shiftop_encoding
let vec_bitmaskop_encoding = Values.vecop_encoding V128Op.bitmaskop_encoding
let vec_vtestop_encoding = Values.vecop_encoding V128Op.vtestop_encoding
let vec_vunop_encoding = Values.vecop_encoding V128Op.vunop_encoding
let vec_vbinop_encoding = Values.vecop_encoding V128Op.vbinop_encoding
let vec_vternop_encoding = Values.vecop_encoding V128Op.vternop_encoding
let vec_splatop_encoding = Values.vecop_encoding V128Op.splatop_encoding
let vec_extractop_encoding = Values.vecop_encoding V128Op.extractop_encoding
let vec_replaceop_encoding = Values.vecop_encoding V128Op.replaceop_encoding
let memop_encoding type_ pack =
let open Data_encoding in
conv
(fun Ast.{ty; align; offset; pack} -> (ty, align, offset, pack))
(fun (ty, align, offset, pack) -> Ast.{ty; align; offset; pack})
(obj4
(req "type" type_)
(req "align" int31)
(req "offset" int32)
(req "pack" pack))
let loadop_encoding =
let open Data_encoding in
memop_encoding
Types.num_type_encoding
(option
(obj2
(req "pack_size" Types.pack_size_encoding)
(req "extension" Types.extension_encoding)))
let storeop_encoding =
let open Data_encoding in
memop_encoding Types.num_type_encoding (option Types.pack_size_encoding)
let vec_loadop_encoding =
let open Data_encoding in
memop_encoding
Types.vec_type_encoding
(option
(obj2
(req "pack_size" Types.pack_size_encoding)
(req "extension" Types.vec_extension_encoding)))
let vec_storeop_encoding =
let open Data_encoding in
memop_encoding Types.vec_type_encoding unit
let vec_laneop_encoding =
let open Data_encoding in
conv
(fun (x, y) -> (x, y))
(fun (x, y) -> (x, y))
(obj2
(req
"op"
(memop_encoding Types.vec_type_encoding Types.pack_size_encoding))
(req "lane" int31))
let var_encoding = Source.phrase_encoding Data_encoding.int32
let num_encoding = Source.phrase_encoding Values.num_encoding
let vec_encoding = Source.phrase_encoding Values.vec_encoding
let block_type_encoding =
let open Data_encoding in
let open Ast in
union_incr
[
case_incr
"VarBlockType"
var_encoding
(function VarBlockType x -> Some x | _ -> None)
(fun var -> VarBlockType var);
case_incr
"ValBlockType"
(option Types.value_type_encoding)
(function ValBlockType x -> Some x | _ -> None)
(fun var -> ValBlockType var);
]
let block_label_encoding =
let open Data_encoding in
let open Ast in
conv (fun (Block_label l) -> l) (fun l -> Block_label l) int32
let data_label_encoding =
let open Data_encoding in
let open Ast in
conv (fun (Data_label l) -> l) (fun l -> Data_label l) int32
let import_desc_encoding =
let open Ast in
let unannotated_encoding =
union_incr
[
case_incr
"FuncImport"
var_encoding
(function FuncImport v -> Some v | _ -> None)
(fun v -> FuncImport v);
case_incr
"TableImport"
Types.table_type_encoding
(function TableImport t -> Some t | _ -> None)
(fun t -> TableImport t);
case_incr
"MemoryImport"
Types.memory_type_encoding
(function MemoryImport m -> Some m | _ -> None)
(fun m -> MemoryImport m);
case_incr
"GlobalImport"
Types.global_type_encoding
(function GlobalImport g -> Some g | _ -> None)
(fun g -> GlobalImport g);
]
in
Source.phrase_encoding unannotated_encoding
let export_desc_encoding =
let open Ast in
let unannotated_encoding =
union_incr
[
case_incr
"FuncExport"
var_encoding
(function FuncExport v -> Some v | _ -> None)
(fun v -> FuncExport v);
case_incr
"TableExport"
var_encoding
(function TableExport t -> Some t | _ -> None)
(fun t -> TableExport t);
case_incr
"MemoryExport"
var_encoding
(function MemoryExport m -> Some m | _ -> None)
(fun m -> MemoryExport m);
case_incr
"GlobalExport"
var_encoding
(function GlobalExport g -> Some g | _ -> None)
(fun g -> GlobalExport g);
]
in
Source.phrase_encoding unannotated_encoding
let const_encoding = Source.phrase_encoding block_label_encoding
let segment_mode_encoding =
let open Data_encoding in
let unannotated_encoding =
union_incr
[
case_incr
"Passive"
(constant "Passive")
(function Ast.Passive -> Some () | _ -> None)
(fun () -> Passive);
case_incr
"Active"
(tup2 var_encoding const_encoding)
(function
| Ast.Active {index; offset} -> Some (index, offset) | _ -> None)
(fun (index, offset) -> Active {index; offset});
case_incr
"Declarative"
(constant "Declarative")
(function Ast.Declarative -> Some () | _ -> None)
(fun () -> Declarative);
]
in
Source.phrase_encoding unannotated_encoding
let table_encoding =
let open Data_encoding in
let unannoted_encoding =
conv
(fun {ttype} -> ttype)
(fun ttype -> {ttype})
Types.table_type_encoding
in
Source.phrase_encoding unannoted_encoding
let memory_encoding =
let open Data_encoding in
let unannoted_encoding =
conv
(fun {mtype} -> mtype)
(fun mtype -> {mtype})
Types.memory_type_encoding
in
Source.phrase_encoding unannoted_encoding
let global_encoding =
let open Data_encoding in
let unannoted_encoding =
conv
(fun {gtype; ginit} -> (gtype, ginit))
(fun (gtype, ginit) -> {gtype; ginit})
(tup2
Types.global_type_encoding
(Source.phrase_encoding block_label_encoding))
in
Source.phrase_encoding unannoted_encoding
let start_encoding =
let open Data_encoding in
let unannoted_encoding =
conv (fun {sfunc} -> sfunc) (fun sfunc -> {sfunc}) var_encoding
in
Source.phrase_encoding unannoted_encoding
end