diff --git a/src/lib_scoru_wasm/ast_encoding.ml b/src/lib_scoru_wasm/ast_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..9194a8e342792e362ebe76edf22b09671989ecb9 --- /dev/null +++ b/src/lib_scoru_wasm/ast_encoding.ml @@ -0,0 +1,1329 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* 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 Ast +module Values = Values_encoding +module Types = Types_encoding + +module IntOp = struct + open IntOp + + let unop_encoding = + let open Data_encoding in + union + [ + case + ~title:"Clz" + (Tag 0) + (constant "Clz") + (function Clz -> Some () | _ -> None) + (fun () -> Clz); + case + ~title:"Ctz" + (Tag 1) + (constant "Ctz") + (function Ctz -> Some () | _ -> None) + (fun () -> Ctz); + case + ~title:"Popnct" + (Tag 2) + (constant "Popnct") + (function Popcnt -> Some () | _ -> None) + (fun () -> Popcnt); + case + ~title:"ExtendS" + (Tag 3) + (obj1 (req "ExtendS" Types.pack_size_encoding)) + (function ExtendS s -> Some s | _ -> None) + (fun s -> ExtendS s); + ] + + let binop_encoding = + Data_encoding.string_enum + [ + ("Add", Add); + ("Sub", Sub); + ("Mul", Mul); + ("DivS", DivS); + ("DivU", DivU); + ("RemS", RemS); + ("RemU", RemU); + ("And", And); + ("Or", Or); + ("Xor", Xor); + ("Shl", Shl); + ("ShrS", ShrS); + ("ShrU", ShrU); + ("Rotl", Rotl); + ("Rotr", Rotr); + ] + + let testop_encoding = + Data_encoding.(conv (fun Eqz -> ()) (fun () -> Eqz) (constant "Eqz")) + + let relop_encoding = + Data_encoding.string_enum + [ + ("Eq", Eq); + ("Ne", Ne); + ("LtS", LtS); + ("LtU", LtU); + ("GtS", GtS); + ("GtU", GtU); + ("LeS", LeS); + ("LeU", LeU); + ("GeS", GeS); + ("GeU", GeU); + ] + + let cvtop_encoding = + Data_encoding.string_enum + [ + ("ExtendSI32", ExtendSI32); + ("ExtendUI32", ExtendUI32); + ("WrapI64", WrapI64); + ("TruncSF32", TruncSF32); + ("TruncUF32", TruncUF32); + ("TruncSF64", TruncSF64); + ("TruncUF64", TruncUF64); + ("TruncSatSF32", TruncSatSF32); + ("TruncSatUF32", TruncSatUF32); + ("TruncSatSF64", TruncSatSF64); + ("TruncSatUF64", TruncSatUF64); + ("ReinterpretFloat", ReinterpretFloat); + ] +end + +module FloatOp = struct + open FloatOp + + let unop_encoding = + Data_encoding.string_enum + ([ + ("Neg", Neg); + ("Abs", Abs); + ("Ceil", Ceil); + ("Floor", Floor); + ("Trunc", Trunc); + ("Nearest", Nearest); + ("Sqrt", Sqrt); + ] + : (string * unop) list) + + let binop_encoding = + Data_encoding.string_enum + ([ + ("Add", Add); + ("Sub", Sub); + ("Mul", Mul); + ("Div", Div); + ("Min", Min); + ("Max", Max); + ("CopySign", CopySign); + ] + : (string * binop) list) + + let testop_encoding = + Data_encoding.( + conv + (function (_ : testop) -> .) + (fun () -> + failwith "FloatOp.testop_encoding" + (* the testop type cannot be instantiated and is used to fill an + impossible case in the AST, this shouldn't happen. *)) + null) + + let relop_encoding = + Data_encoding.string_enum + ([("Eq", Eq); ("Ne", Ne); ("Lt", Lt); ("Gt", Gt); ("Le", Le); ("Ge", Ge)] + : (string * relop) list) + + let cvtop_encoding = + Data_encoding.string_enum + [ + ("ConvertSI32", ConvertSI32); + ("ConvertUI32", ConvertUI32); + ("ConvertSI64", ConvertSI64); + ("ConvertUI64", ConvertUI64); + ("PromoteF32", PromoteF32); + ("DemoteF64", DemoteF64); + ("ReinterpretInt", ReinterpretInt); + ] +end + +module V128Op = struct + open Ast.V128Op + + let itestop_encoding = + Data_encoding.( + conv (fun AllTrue -> ()) (fun () -> AllTrue) (constant "AllTrue")) + + let iunop_encoding = + Data_encoding.string_enum + ([("Abs", Abs); ("Neg", Neg); ("Popcnt", Popcnt)] : (string * iunop) list) + + let funop_encoding = + Data_encoding.string_enum + [ + ("Abs", Abs); + ("Neg", Neg); + ("Sqrt", Sqrt); + ("Ceil", Ceil); + ("Floor", Floor); + ("Trunc", Trunc); + ("Nearest", Nearest); + ] + + let ibinop_encoding = + let open Data_encoding in + union + [ + case + ~title:"Add" + (Tag 0) + (constant "Add") + (function (Add : ibinop) -> Some () | _ -> None) + (fun () -> Add); + case + ~title:"Sub" + (Tag 1) + (constant "Sub") + (function (Sub : ibinop) -> Some () | _ -> None) + (fun () -> Sub); + case + ~title:"Mul" + (Tag 2) + (constant "Mul") + (function (Mul : ibinop) -> Some () | _ -> None) + (fun () -> Mul); + case + ~title:"MinS" + (Tag 3) + (constant "MinS") + (function MinS -> Some () | _ -> None) + (fun () -> MinS); + case + ~title:"MinU" + (Tag 4) + (constant "MinU") + (function MinU -> Some () | _ -> None) + (fun () -> MinU); + case + ~title:"MaxS" + (Tag 5) + (constant "MaxS") + (function MaxS -> Some () | _ -> None) + (fun () -> MaxS); + case + ~title:"MaxU" + (Tag 6) + (constant "MaxU") + (function MaxU -> Some () | _ -> None) + (fun () -> MaxU); + case + ~title:"AvgrU" + (Tag 7) + (constant "AvgrU") + (function AvgrU -> Some () | _ -> None) + (fun () -> AvgrU); + case + ~title:"AddSatS" + (Tag 8) + (constant "AddSatS") + (function AddSatS -> Some () | _ -> None) + (fun () -> AddSatS); + case + ~title:"AddSatU" + (Tag 9) + (constant "AddSatU") + (function AddSatU -> Some () | _ -> None) + (fun () -> AddSatU); + case + ~title:"SubSatS" + (Tag 10) + (constant "SubSatS") + (function SubSatS -> Some () | _ -> None) + (fun () -> SubSatS); + case + ~title:"SubSatU" + (Tag 11) + (constant "SubSatU") + (function SubSatU -> Some () | _ -> None) + (fun () -> SubSatU); + case + ~title:"DotS" + (Tag 12) + (constant "DotS") + (function DotS -> Some () | _ -> None) + (fun () -> DotS); + case + ~title:"Q15MulRSatS" + (Tag 13) + (constant "Q15MulRSatS") + (function Q15MulRSatS -> Some () | _ -> None) + (fun () -> Q15MulRSatS); + case + ~title:"ExtMulLowS" + (Tag 14) + (constant "ExtMulLowS") + (function ExtMulLowS -> Some () | _ -> None) + (fun () -> ExtMulLowS); + case + ~title:"ExtMulHighS" + (Tag 15) + (constant "ExtMulHighS") + (function ExtMulHighS -> Some () | _ -> None) + (fun () -> ExtMulHighS); + case + ~title:"ExtMulLowU" + (Tag 16) + (constant "ExtMulLowU") + (function ExtMulLowU -> Some () | _ -> None) + (fun () -> ExtMulLowU); + case + ~title:"ExtMulHighU" + (Tag 17) + (constant "ExtMulHighU") + (function ExtMulHighU -> Some () | _ -> None) + (fun () -> ExtMulHighU); + case + ~title:"Swizzle" + (Tag 18) + (constant "Swizzle") + (function Swizzle -> Some () | _ -> None) + (fun () -> Swizzle); + case + ~title:"Shuffle" + (Tag 19) + (obj1 (req "Shuffle" (list int31))) + (function Shuffle l -> Some l | _ -> None) + (fun l -> Shuffle l); + case + ~title:"NarrowS" + (Tag 20) + (constant "NarrowS") + (function NarrowS -> Some () | _ -> None) + (fun () -> NarrowS); + case + ~title:"NarrowU" + (Tag 21) + (constant "NarrowU") + (function NarrowU -> Some () | _ -> None) + (fun () -> NarrowU); + ] + + let fbinop_encoding = + Data_encoding.string_enum + ([ + ("Add", Add); + ("Sub", Sub); + ("Mul", Mul); + ("Div", Div); + ("Min", Min); + ("Max", Max); + ("Pmin", Pmin); + ("Pmax", Pmax); + ] + : (string * fbinop) list) + + let irelop_encoding = + Data_encoding.string_enum + ([ + ("Eq", Eq); + ("Ne", Ne); + ("LtS", LtS); + ("LtU", LtU); + ("LeS", LeS); + ("LeU", LeU); + ("GtS", GtS); + ("GtU", GtU); + ("GeS", GeS); + ("GeU", GeU); + ] + : (string * irelop) list) + + let frelop_encoding = + Data_encoding.string_enum + [("Eq", Eq); ("Ne", Ne); ("Lt", Lt); ("Le", Le); ("Gt", Gt); ("Ge", Ge)] + + let icvtop_encoding = + Data_encoding.string_enum + [ + ("ExtendLowS", ExtendLowS); + ("ExtendLowU", ExtendLowU); + ("ExtendHighS", ExtendHighS); + ("ExtendHighU", ExtendHighU); + ("ExtAddPairwiseS", ExtAddPairwiseS); + ("ExtAddPairwiseU", ExtAddPairwiseU); + ("TruncSatSF32x4", TruncSatSF32x4); + ("TruncSatUF32x4", TruncSatUF32x4); + ("TruncSatSZeroF64x2", TruncSatSZeroF64x2); + ("TruncSatUZeroF64x2", TruncSatUZeroF64x2); + ] + + let fcvtop_encoding = + Data_encoding.string_enum + [ + ("DemoteZeroF64x2", DemoteZeroF64x2); + ("PromoteLowF32x4", PromoteLowF32x4); + ("ConvertSI32x4", ConvertSI32x4); + ("ConvertUI32x4", ConvertUI32x4); + ] + + let ishiftop_encoding = + Data_encoding.string_enum [("Shl", Shl); ("ShrS", ShrS); ("ShrU", ShrU)] + + let ibitmaskop_encoding = + Data_encoding.( + conv (fun Bitmask -> ()) (fun () -> Bitmask) (constant "Bitmask")) + + let vtestop_encoding = + Data_encoding.( + conv (fun AnyTrue -> ()) (fun () -> AnyTrue) (constant "AnyTrue")) + + let vunop_encoding = + Data_encoding.(conv (fun Not -> ()) (fun () -> Not) (constant "Not")) + + let vbinop_encoding = + Data_encoding.string_enum + [("And", And); ("Or", Or); ("Xor", Xor); ("AndNot", AndNot)] + + let vternop_encoding = + Data_encoding.( + conv (fun Bitselect -> ()) (fun () -> Bitselect) (constant "Bitselect")) + + let void_encoding : void Data_encoding.t = + Data_encoding.( + conv + (function (_ : void) -> .) + (fun () -> + failwith "void_encoding" + (* the void type cannot be instantiated and is used to fill an + impossible case in the AST, this shouldn't happen. *)) + null) + + let testop_encoding = + Values.V128.laneop_encoding + itestop_encoding + itestop_encoding + itestop_encoding + itestop_encoding + void_encoding + void_encoding + + let unop_encoding = + Values.V128.laneop_encoding + iunop_encoding + iunop_encoding + iunop_encoding + iunop_encoding + funop_encoding + funop_encoding + + let binop_encoding = + Values.V128.laneop_encoding + ibinop_encoding + ibinop_encoding + ibinop_encoding + ibinop_encoding + fbinop_encoding + fbinop_encoding + + let relop_encoding = + Values.V128.laneop_encoding + irelop_encoding + irelop_encoding + irelop_encoding + irelop_encoding + frelop_encoding + frelop_encoding + + let cvtop_encoding = + Values.V128.laneop_encoding + icvtop_encoding + icvtop_encoding + icvtop_encoding + icvtop_encoding + fcvtop_encoding + fcvtop_encoding + + let shiftop_encoding = + Values.V128.laneop_encoding + ishiftop_encoding + ishiftop_encoding + ishiftop_encoding + ishiftop_encoding + void_encoding + void_encoding + + let bitmaskop_encoding = + Values.V128.laneop_encoding + ibitmaskop_encoding + ibitmaskop_encoding + ibitmaskop_encoding + ibitmaskop_encoding + void_encoding + void_encoding + + let nsplatop_encoding = + Data_encoding.(conv (fun Splat -> ()) (fun () -> Splat) (constant "Splat")) + + let nextractop_encoding v_encoding = + Data_encoding.( + conv + (fun (Extract (i, v)) -> (i, v)) + (fun (i, v) -> Extract (i, v)) + (tup2 int31 v_encoding)) + + let nreplaceop_encoding = + Data_encoding.(conv (fun (Replace i) -> i) (fun i -> Replace i) int31) + + let splatop_encoding = + Values.V128.laneop_encoding + nsplatop_encoding + nsplatop_encoding + nsplatop_encoding + nsplatop_encoding + nsplatop_encoding + nsplatop_encoding + + let extractop_encoding = + Values.V128.laneop_encoding + (nextractop_encoding Types.extension_encoding) + (nextractop_encoding Types.extension_encoding) + (nextractop_encoding Data_encoding.null) + (nextractop_encoding Data_encoding.null) + (nextractop_encoding Data_encoding.null) + (nextractop_encoding Data_encoding.null) + + let replaceop_encoding = + Values.V128.laneop_encoding + nreplaceop_encoding + nreplaceop_encoding + nreplaceop_encoding + nreplaceop_encoding + nreplaceop_encoding + nreplaceop_encoding +end + +let testop_encoding = + Values.op_encoding + IntOp.testop_encoding + IntOp.testop_encoding + FloatOp.testop_encoding + FloatOp.testop_encoding + +let unop_encoding = + Values.op_encoding + IntOp.unop_encoding + IntOp.unop_encoding + FloatOp.unop_encoding + FloatOp.unop_encoding + +let binop_encoding = + Values.op_encoding + IntOp.binop_encoding + IntOp.binop_encoding + FloatOp.binop_encoding + FloatOp.binop_encoding + +let relop_encoding = + Values.op_encoding + IntOp.relop_encoding + IntOp.relop_encoding + FloatOp.relop_encoding + FloatOp.relop_encoding + +let cvtop_encoding = + Values.op_encoding + IntOp.cvtop_encoding + IntOp.cvtop_encoding + FloatOp.cvtop_encoding + FloatOp.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 ty_encoding value_encoding = + Data_encoding.( + conv + (fun {ty; align; offset; pack} -> (ty, align, offset, pack)) + (fun (ty, align, offset, pack) -> {ty; align; offset; pack}) + (obj4 + (req "ty" ty_encoding) + (req "align" int31) + (req "offset" int32) + (req "pack" value_encoding))) + +let loadop_encoding = + Data_encoding.( + memop_encoding + Types.num_type_encoding + (option (tup2 Types.pack_size_encoding Types.extension_encoding))) + +let storeop_encoding = + Data_encoding.( + memop_encoding Types.num_type_encoding (option Types.pack_size_encoding)) + +let vec_loadop_encoding = + Data_encoding.( + memop_encoding + Types.vec_type_encoding + (option (tup2 Types.pack_size_encoding Types.vec_extension_encoding))) + +let vec_storeop_encoding = + memop_encoding Types.vec_type_encoding Data_encoding.null + +let vec_laneop_encoding = + Data_encoding.( + tup2 (memop_encoding Types.vec_type_encoding Types.pack_size_encoding) int31) + +(* Expressions *) + +let pos_encoding = + Data_encoding.( + conv + (fun {Source.file; line; column} -> (file, line, column)) + (fun (file, line, column) -> {file; line; column}) + (obj3 (req "file" string) (req "line" int31) (req "column" int31))) + +let region_encoding = + Data_encoding.( + conv + (fun {Source.left; right} -> (left, right)) + (fun (left, right) -> {left; right}) + (obj2 (req "left" pos_encoding) (req "right" pos_encoding))) + +let full_phrase_encoding value_encoding = + Data_encoding.( + conv + (fun {Source.at; it} -> (at, it)) + (fun (at, it) -> {at; it}) + (obj2 (req "at" region_encoding) (req "it" value_encoding))) + +let phrase_encoding value_encoding = + Data_encoding.( + conv + (fun {Source.it; _} -> it) + (fun it -> {at = Source.no_region; it}) + value_encoding) + +let var_encoding = phrase_encoding Data_encoding.int32 + +let num_encoding = phrase_encoding Values.num_encoding + +let vec_encoding = phrase_encoding Values.vec_encoding + +let name_encoding = Data_encoding.(list int31) + +let block_type_encoding = + let open Data_encoding in + union + [ + case + ~title:"VarBlockType" + (Tag 0) + var_encoding + (function VarBlockType v -> Some v | _ -> None) + (fun v -> VarBlockType v); + case + ~title:"ValBlockType" + (Tag 1) + (Data_encoding.option Types.value_type_encoding) + (function ValBlockType v -> Some v | _ -> None) + (fun v -> ValBlockType v); + ] + +let instr_encoding' = + let open Data_encoding in + mu "instr" @@ fun instr_encoding' -> + let instr_encoding = phrase_encoding instr_encoding' in + union + [ + case + ~title:"Unreachable" + (Tag 0) + (constant "Unreachable") + (function Unreachable -> Some () | _ -> None) + (fun () -> Unreachable); + case + ~title:"Nop" + (Tag 1) + (constant "Nop") + (function Nop -> Some () | _ -> None) + (fun () -> Nop); + case + ~title:"Drop" + (Tag 2) + (constant "Drop") + (function Drop -> Some () | _ -> None) + (fun () -> Drop); + case + ~title:"Select" + (Tag 3) + (option (list Types.value_type_encoding)) + (function Select l -> Some l | _ -> None) + (fun l -> Select l); + case + ~title:"Block" + (Tag 4) + (obj1 (req "Block" (tup2 block_type_encoding (list instr_encoding)))) + (function Block (bt, il) -> Some (bt, il) | _ -> None) + (fun (bt, il) -> Block (bt, il)); + case + ~title:"Loop" + (Tag 5) + (obj1 (req "Loop" (tup2 block_type_encoding (list instr_encoding)))) + (function Loop (bt, il) -> Some (bt, il) | _ -> None) + (fun (bt, il) -> Loop (bt, il)); + case + ~title:"If" + (Tag 6) + (obj1 + (req + "If" + (tup3 + block_type_encoding + (list instr_encoding) + (list instr_encoding)))) + (function If (bt, il, il') -> Some (bt, il, il') | _ -> None) + (fun (bt, il, il') -> If (bt, il, il')); + case + ~title:"Br" + (Tag 7) + (obj1 (req "Br" var_encoding)) + (function Br v -> Some v | _ -> None) + (fun v -> Br v); + case + ~title:"BrIf" + (Tag 8) + (obj1 (req "BrIf" var_encoding)) + (function BrIf v -> Some v | _ -> None) + (fun v -> BrIf v); + case + ~title:"BrTable" + (Tag 9) + (obj1 (req "BrTable" (tup2 (list var_encoding) var_encoding))) + (function BrTable (vs, v) -> Some (vs, v) | _ -> None) + (fun (vs, v) -> BrTable (vs, v)); + case + ~title:"Return" + (Tag 10) + (constant "Return") + (function Return -> Some () | _ -> None) + (fun () -> Return); + case + ~title:"Call" + (Tag 11) + (obj1 (req "Call" var_encoding)) + (function Call v -> Some v | _ -> None) + (fun v -> Call v); + case + ~title:"CallIndirect" + (Tag 12) + (obj1 (req "CallIndirect" (tup2 var_encoding var_encoding))) + (function CallIndirect (v, v') -> Some (v, v') | _ -> None) + (fun (v, v') -> CallIndirect (v, v')); + case + ~title:"LocalGet" + (Tag 13) + (obj1 (req "LocalGet" var_encoding)) + (function LocalGet v -> Some v | _ -> None) + (fun v -> LocalGet v); + case + ~title:"LocalSet" + (Tag 14) + (obj1 (req "LocalSet" var_encoding)) + (function LocalSet v -> Some v | _ -> None) + (fun v -> LocalSet v); + case + ~title:"LocalTee" + (Tag 15) + (obj1 (req "LocalTee" var_encoding)) + (function LocalTee v -> Some v | _ -> None) + (fun v -> LocalTee v); + case + ~title:"GlobalGet" + (Tag 16) + (obj1 (req "GlobalGet" var_encoding)) + (function GlobalGet v -> Some v | _ -> None) + (fun v -> GlobalGet v); + case + ~title:"GlobalSet" + (Tag 17) + (obj1 (req "GlobalSet" var_encoding)) + (function GlobalSet v -> Some v | _ -> None) + (fun v -> GlobalSet v); + case + ~title:"TableGet" + (Tag 18) + (obj1 (req "TableGet" var_encoding)) + (function TableGet v -> Some v | _ -> None) + (fun v -> TableGet v); + case + ~title:"TableSet" + (Tag 19) + (obj1 (req "TableSet" var_encoding)) + (function TableSet v -> Some v | _ -> None) + (fun v -> TableSet v); + case + ~title:"TableSize" + (Tag 20) + (obj1 (req "TableSize" var_encoding)) + (function TableSize v -> Some v | _ -> None) + (fun v -> TableSize v); + case + ~title:"TableGrow" + (Tag 21) + (obj1 (req "TableGrow" var_encoding)) + (function TableGrow v -> Some v | _ -> None) + (fun v -> TableGrow v); + case + ~title:"TableFill" + (Tag 22) + (obj1 (req "TableFill" var_encoding)) + (function TableFill v -> Some v | _ -> None) + (fun v -> TableFill v); + case + ~title:"TableCopy" + (Tag 23) + (obj1 (req "TableCopy" (tup2 var_encoding var_encoding))) + (function TableCopy (v, v') -> Some (v, v') | _ -> None) + (fun (v, v') -> CallIndirect (v, v')); + case + ~title:"TableInit" + (Tag 24) + (obj1 (req "TableInit" (tup2 var_encoding var_encoding))) + (function TableInit (v, v') -> Some (v, v') | _ -> None) + (fun (v, v') -> TableInit (v, v')); + case + ~title:"ElemDrop" + (Tag 25) + (obj1 (req "ElemDrop" var_encoding)) + (function ElemDrop v -> Some v | _ -> None) + (fun v -> ElemDrop v); + case + ~title:"Load" + (Tag 26) + (obj1 (req "Load" loadop_encoding)) + (function Load v -> Some v | _ -> None) + (fun v -> Load v); + case + ~title:"Store" + (Tag 27) + (obj1 (req "Store" storeop_encoding)) + (function Store v -> Some v | _ -> None) + (fun v -> Store v); + case + ~title:"VecLoad" + (Tag 28) + (obj1 (req "VecLoad" vec_loadop_encoding)) + (function VecLoad v -> Some v | _ -> None) + (fun v -> VecLoad v); + case + ~title:"VecStore" + (Tag 29) + (obj1 (req "VecStore" vec_storeop_encoding)) + (function VecStore v -> Some v | _ -> None) + (fun v -> VecStore v); + case + ~title:"VecLoadLane" + (Tag 30) + (obj1 (req "VecLoadLane" vec_laneop_encoding)) + (function VecLoadLane v -> Some v | _ -> None) + (fun v -> VecLoadLane v); + case + ~title:"VecStoreLane" + (Tag 31) + (obj1 (req "VecStoreLane" vec_laneop_encoding)) + (function VecStoreLane v -> Some v | _ -> None) + (fun v -> VecStoreLane v); + case + ~title:"MemorySize" + (Tag 32) + (obj1 (req "MemorySize" (constant "MemorySize"))) + (function MemorySize -> Some () | _ -> None) + (fun () -> MemorySize); + case + ~title:"MemoryGrow" + (Tag 33) + (obj1 (req "MemoryGrow" (constant "MemoryGrow"))) + (function MemoryGrow -> Some () | _ -> None) + (fun () -> MemoryGrow); + case + ~title:"MemoryFill" + (Tag 34) + (obj1 (req "MemoryFill" (constant "MemoryFill"))) + (function MemoryFill -> Some () | _ -> None) + (fun () -> MemoryFill); + case + ~title:"MemoryCopy" + (Tag 35) + (obj1 (req "MemoryCopy" (constant "MemoryCopy"))) + (function MemoryCopy -> Some () | _ -> None) + (fun () -> MemoryCopy); + case + ~title:"MemoryInit" + (Tag 36) + (obj1 (req "MemoryInit" var_encoding)) + (function MemoryInit v -> Some v | _ -> None) + (fun v -> MemoryInit v); + case + ~title:"DataDrop" + (Tag 37) + (obj1 (req "DataDrop" var_encoding)) + (function DataDrop v -> Some v | _ -> None) + (fun v -> DataDrop v); + case + ~title:"RefNull" + (Tag 38) + (obj1 (req "RefNull" Types.ref_type_encoding)) + (function RefNull r -> Some r | _ -> None) + (fun r -> RefNull r); + case + ~title:"RefFunc" + (Tag 39) + (obj1 (req "RefFunc" var_encoding)) + (function RefFunc r -> Some r | _ -> None) + (fun r -> RefFunc r); + case + ~title:"RefIsNull" + (Tag 40) + (obj1 (req "RefIsNull" (constant "RefIsNull"))) + (function RefIsNull -> Some () | _ -> None) + (fun () -> RefIsNull); + case + ~title:"Const" + (Tag 41) + (obj1 (req "Const" num_encoding)) + (function Const n -> Some n | _ -> None) + (fun n -> Const n); + case + ~title:"Test" + (Tag 42) + (obj1 (req "Test" testop_encoding)) + (function Test t -> Some t | _ -> None) + (fun t -> Test t); + case + ~title:"Compare" + (Tag 43) + (obj1 (req "Compare" relop_encoding)) + (function Compare t -> Some t | _ -> None) + (fun t -> Compare t); + case + ~title:"Unary" + (Tag 44) + (obj1 (req "Unary" unop_encoding)) + (function Unary o -> Some o | _ -> None) + (fun o -> Unary o); + case + ~title:"Binary" + (Tag 45) + (obj1 (req "Binary" binop_encoding)) + (function Binary o -> Some o | _ -> None) + (fun o -> Binary o); + case + ~title:"Convert" + (Tag 46) + (obj1 (req "Convert" cvtop_encoding)) + (function Convert t -> Some t | _ -> None) + (fun t -> Convert t); + case + ~title:"VecConst" + (Tag 47) + (obj1 (req "VecConst" vec_encoding)) + (function VecConst t -> Some t | _ -> None) + (fun t -> VecConst t); + case + ~title:"VecTest" + (Tag 48) + (obj1 (req "VecTest" vec_testop_encoding)) + (function VecTest t -> Some t | _ -> None) + (fun t -> VecTest t); + case + ~title:"VecCompare" + (Tag 49) + (obj1 (req "VecCompare" vec_relop_encoding)) + (function VecCompare t -> Some t | _ -> None) + (fun t -> VecCompare t); + case + ~title:"VecUnary" + (Tag 50) + (obj1 (req "VecUnary" vec_unop_encoding)) + (function VecUnary t -> Some t | _ -> None) + (fun t -> VecUnary t); + case + ~title:"VecBinary" + (Tag 51) + (obj1 (req "VecBinary" vec_binop_encoding)) + (function VecBinary t -> Some t | _ -> None) + (fun t -> VecBinary t); + case + ~title:"VecConvert" + (Tag 52) + (obj1 (req "VecConvert" vec_cvtop_encoding)) + (function VecConvert t -> Some t | _ -> None) + (fun t -> VecConvert t); + case + ~title:"VecShift" + (Tag 53) + (obj1 (req "VecShift" vec_shiftop_encoding)) + (function VecShift t -> Some t | _ -> None) + (fun t -> VecShift t); + case + ~title:"VecBitmask" + (Tag 54) + (obj1 (req "VecBitmask" vec_bitmaskop_encoding)) + (function VecBitmask t -> Some t | _ -> None) + (fun t -> VecBitmask t); + case + ~title:"VecTestBits" + (Tag 55) + (obj1 (req "VecTestBits" vec_vtestop_encoding)) + (function VecTestBits t -> Some t | _ -> None) + (fun t -> VecTestBits t); + case + ~title:"VecUnaryBits" + (Tag 56) + (obj1 (req "VecUnaryBits" vec_vunop_encoding)) + (function VecUnaryBits t -> Some t | _ -> None) + (fun t -> VecUnaryBits t); + case + ~title:"VecBinaryBits" + (Tag 57) + (obj1 (req "VecBinaryBits" vec_vbinop_encoding)) + (function VecBinaryBits t -> Some t | _ -> None) + (fun t -> VecBinaryBits t); + case + ~title:"VecTernaryBits" + (Tag 58) + (obj1 (req "VecTernaryBits" vec_vternop_encoding)) + (function VecTernaryBits t -> Some t | _ -> None) + (fun t -> VecTernaryBits t); + case + ~title:"VecSplat" + (Tag 59) + (obj1 (req "VecSplat" vec_splatop_encoding)) + (function VecSplat t -> Some t | _ -> None) + (fun t -> VecSplat t); + case + ~title:"VecExtract" + (Tag 60) + (obj1 (req "VecExtract" vec_extractop_encoding)) + (function VecExtract t -> Some t | _ -> None) + (fun t -> VecExtract t); + case + ~title:"VecReplace" + (Tag 61) + (obj1 (req "VecReplace" vec_replaceop_encoding)) + (function VecReplace t -> Some t | _ -> None) + (fun t -> VecReplace t); + ] + +let instr_encoding = phrase_encoding instr_encoding' + +let const_encoding = phrase_encoding (Data_encoding.list instr_encoding) + +let global_encoding' = + Data_encoding.( + conv + (fun {gtype; ginit} -> (gtype, ginit)) + (fun (gtype, ginit) -> {gtype; ginit}) + (obj2 + (req "gtype" Types.global_type_encoding) + (req "ginit" const_encoding))) + +let global_encoding = phrase_encoding global_encoding' + +let func_encoding' = + Data_encoding.( + conv + (fun {ftype; locals; body} -> (ftype, locals, body)) + (fun (ftype, locals, body) -> {ftype; locals; body}) + (obj3 + (req "ftype" var_encoding) + (req "locals" (list Types.value_type_encoding)) + (req "body" (list instr_encoding)))) + +let func_encoding = phrase_encoding func_encoding' + +let table_encoding' = + Data_encoding.( + conv (fun {ttype} -> ttype) (fun ttype -> {ttype}) Types.table_type_encoding) + +let table_encoding = phrase_encoding table_encoding' + +let memory_encoding' = + Data_encoding.conv + (fun {mtype} -> mtype) + (fun mtype -> {mtype}) + Types.memory_type_encoding + +let memory_encoding = phrase_encoding memory_encoding' + +let segment_mode_encoding' = + let open Data_encoding in + union + [ + case + ~title:"Passive" + (Tag 0) + (constant "Passive") + (function Passive -> Some () | _ -> None) + (fun () -> Passive); + case + ~title:"Active" + (Tag 1) + (obj1 + (req + "Active" + (obj2 (req "index" var_encoding) (req "offset" const_encoding)))) + (function Active {index; offset} -> Some (index, offset) | _ -> None) + (fun (index, offset) -> Active {index; offset}); + case + ~title:"Declarative" + (Tag 2) + (constant "Declarative") + (function Declarative -> Some () | _ -> None) + (fun () -> Declarative); + ] + +let segment_mode_encoding = phrase_encoding segment_mode_encoding' + +let elem_segment_encoding' = + Data_encoding.( + conv + (fun {etype; einit; emode} -> (etype, einit, emode)) + (fun (etype, einit, emode) -> {etype; einit; emode}) + (obj3 + (req "etype" Types.ref_type_encoding) + (req "einit" (list const_encoding)) + (req "emode" segment_mode_encoding))) + +let elem_segment_encoding = phrase_encoding elem_segment_encoding' + +(* TODO *) +let chunked_byte_vector_encoding : Chunked_byte_vector.Buffer.t Data_encoding.t + = + Data_encoding.(conv (fun _ -> assert false) (fun _ -> assert false) null) + +let data_segment_encoding' = + Data_encoding.( + conv + (fun {dinit; dmode} -> (dinit, dmode)) + (fun (dinit, dmode) -> {dinit; dmode}) + (obj2 + (req "dinit" chunked_byte_vector_encoding) + (req "dmode" segment_mode_encoding))) + +let data_segment_encoding = phrase_encoding data_segment_encoding' + +let export_desc_encoding' = + let open Data_encoding in + union + [ + case + ~title:"FuncExport" + (Tag 0) + (obj1 (req "FuncExport" var_encoding)) + (function FuncExport v -> Some v | _ -> None) + (fun v -> FuncExport v); + case + ~title:"TableExport" + (Tag 1) + (obj1 (req "TableExport" var_encoding)) + (function TableExport v -> Some v | _ -> None) + (fun v -> TableExport v); + case + ~title:"MemoryExport" + (Tag 2) + (obj1 (req "MemoryExport" var_encoding)) + (function MemoryExport v -> Some v | _ -> None) + (fun v -> MemoryExport v); + case + ~title:"GlobalExport" + (Tag 3) + (obj1 (req "GlobalExport" var_encoding)) + (function GlobalExport v -> Some v | _ -> None) + (fun v -> GlobalExport v); + ] + +let export_desc_encoding = phrase_encoding export_desc_encoding' + +let export_encoding' = + Data_encoding.( + conv + (fun {name; edesc} -> (name, edesc)) + (fun (name, edesc) -> {name; edesc}) + (obj2 (req "name" name_encoding) (req "edesc" export_desc_encoding))) + +let export_encoding = phrase_encoding export_encoding' + +let import_desc_encoding' = + let open Data_encoding in + union + [ + case + ~title:"FuncImport" + (Tag 0) + (obj1 (req "FuncImport" var_encoding)) + (function FuncImport v -> Some v | _ -> None) + (fun v -> FuncImport v); + case + ~title:"TableImport" + (Tag 1) + (obj1 (req "TableImport" Types.table_type_encoding)) + (function TableImport v -> Some v | _ -> None) + (fun v -> TableImport v); + case + ~title:"MemoryImport" + (Tag 2) + (obj1 (req "MemoryImport" Types.memory_type_encoding)) + (function MemoryImport v -> Some v | _ -> None) + (fun v -> MemoryImport v); + case + ~title:"GlobalImport" + (Tag 3) + (obj1 (req "GlobalImport" Types.global_type_encoding)) + (function GlobalImport v -> Some v | _ -> None) + (fun v -> GlobalImport v); + ] + +let import_desc_encoding = phrase_encoding import_desc_encoding' + +let import_encoding' = + Data_encoding.( + conv + (fun {module_name; item_name; idesc} -> (module_name, item_name, idesc)) + (fun (module_name, item_name, idesc) -> {module_name; item_name; idesc}) + (obj3 + (req "module_name" name_encoding) + (req "item_name" name_encoding) + (req "idesc" import_desc_encoding))) + +let import_encoding = phrase_encoding import_encoding' + +let start_encoding' = + Data_encoding.( + conv + (fun {sfunc} -> sfunc) + (fun sfunc -> {sfunc}) + (obj1 (req "sfunc" var_encoding))) + +let start_encoding = phrase_encoding start_encoding' + +let type_encoding = phrase_encoding Types.func_type_encoding + +let lazy_vector_encoding _value_encoding = + Data_encoding.( + conv + (fun _ -> failwith "lazy_vector encoder placeholder") + (fun _ -> failwith "lazy_vector decoder placeholder") + unit) + +let module_encoding' = + Data_encoding.( + conv + (fun { + types; + globals; + tables; + memories; + funcs; + start; + elems; + datas; + imports; + exports; + } -> + ( types, + globals, + tables, + memories, + funcs, + start, + elems, + datas, + imports, + exports )) + (fun ( types, + globals, + tables, + memories, + funcs, + start, + elems, + datas, + imports, + exports ) -> + { + types; + globals; + tables; + memories; + funcs; + start; + elems; + datas; + imports; + exports; + }) + (obj10 + (req "types" (lazy_vector_encoding type_encoding)) + (req "globals" (lazy_vector_encoding global_encoding)) + (req "tables" (lazy_vector_encoding table_encoding)) + (req "memories" (lazy_vector_encoding memory_encoding)) + (req "funcs" (lazy_vector_encoding func_encoding)) + (req "start" (option start_encoding)) + (req "elems" (lazy_vector_encoding elem_segment_encoding)) + (req "datas" (lazy_vector_encoding data_segment_encoding)) + (req "imports" (lazy_vector_encoding import_encoding)) + (req "exports" (lazy_vector_encoding export_encoding)))) diff --git a/src/lib_scoru_wasm/kont_encodings.ml b/src/lib_scoru_wasm/kont_encodings.ml new file mode 100644 index 0000000000000000000000000000000000000000..c6b6f1d9ee382b854b32c2b166bfb1fdb7bb6cd1 --- /dev/null +++ b/src/lib_scoru_wasm/kont_encodings.ml @@ -0,0 +1,420 @@ +open Tezos_webassembly_interpreter.Ast +open Tezos_webassembly_interpreter.Decode + +(** The encoding of the types currently using a [list] will have to be + replaced with tree decoder and encoders. *) + +(* Useful to encode part of a GADT *) +type ('a, 'b) eq = Eq_refl : ('a, 'a) eq | Neq : ('a, 'b) eq + +let section_tag : section_tag Data_encoding.t = + let open Data_encoding in + union + [ + case + ~title:"code_section" + (Tag 0) + (constant "code_section") + (function `CodeSection -> Some () | _ -> None) + (fun () -> `CodeSection); + case + ~title:"custom_section" + (Tag 1) + (constant "custom_section") + (function `CustomSection -> Some () | _ -> None) + (fun () -> `CustomSection); + case + ~title:"data_count_section" + (Tag 2) + (constant "data_count_section") + (function `DataCountSection -> Some () | _ -> None) + (fun () -> `DataCountSection); + case + ~title:"data_section" + (Tag 3) + (constant "data_section") + (function `DataSection -> Some () | _ -> None) + (fun () -> `DataSection); + case + ~title:"elem_section" + (Tag 4) + (constant "elem_section") + (function `ElemSection -> Some () | _ -> None) + (fun () -> `ElemSection); + case + ~title:"export_section" + (Tag 5) + (constant "export_section") + (function `ExportSection -> Some () | _ -> None) + (fun () -> `ExportSection); + case + ~title:"func_section" + (Tag 6) + (constant "func_section") + (function `FuncSection -> Some () | _ -> None) + (fun () -> `FuncSection); + case + ~title:"global_section" + (Tag 7) + (constant "global_section") + (function `GlobalSection -> Some () | _ -> None) + (fun () -> `GlobalSection); + case + ~title:"import_section" + (Tag 8) + (constant "import_section") + (function `ImportSection -> Some () | _ -> None) + (fun () -> `ImportSection); + case + ~title:"memory_section" + (Tag 9) + (constant "memory_section") + (function `MemorySection -> Some () | _ -> None) + (fun () -> `MemorySection); + case + ~title:"start_section" + (Tag 10) + (constant "start_section") + (function `StartSection -> Some () | _ -> None) + (fun () -> `StartSection); + case + ~title:"table_section" + (Tag 11) + (constant "table_section") + (function `TableSection -> Some () | _ -> None) + (fun () -> `TableSection); + case + ~title:"type_section" + (Tag 12) + (constant "type_section") + (function `TypeSection -> Some () | _ -> None) + (fun () -> `TypeSection); + ] + +let type_ : type_ Data_encoding.t = assert false + +let title_for_field_type : type a. a field_type -> string = function + | TypeField -> "type_field" + | ImportField -> "import_field" + | FuncField -> "func_field" + | TableField -> "table_field" + | MemoryField -> "memory_field" + | GlobalField -> "global_field" + | ExportField -> "export_field" + | StartField -> "start_field" + | ElemField -> "elem_field" + | DataCountField -> "data_count_field" + | CodeField -> "code_field" + | DataField -> "data_field" + +let encoding_for_field_type : type a. a field_type -> a Data_encoding.t = + function + | TypeField -> Ast_encoding.type_encoding + | ImportField -> Ast_encoding.import_encoding + | FuncField -> Ast_encoding.var_encoding + | TableField -> Ast_encoding.table_encoding + | MemoryField -> Ast_encoding.memory_encoding + | GlobalField -> Ast_encoding.global_encoding + | ExportField -> Ast_encoding.export_encoding + | StartField -> Ast_encoding.start_encoding + | ElemField -> Ast_encoding.elem_segment_encoding + | DataCountField -> Data_encoding.int32 + | CodeField -> Ast_encoding.func_encoding + | DataField -> Ast_encoding.data_segment_encoding + +let field_type_eq : type a b. a field_type -> b field_type -> (a, b) eq = + fun f1 f2 -> + match (f1, f2) with + | TypeField, TypeField -> Eq_refl + | ImportField, ImportField -> Eq_refl + | FuncField, FuncField -> Eq_refl + | TableField, TableField -> Eq_refl + | MemoryField, MemoryField -> Eq_refl + | GlobalField, GlobalField -> Eq_refl + | ExportField, ExportField -> Eq_refl + | StartField, StartField -> Eq_refl + | ElemField, ElemField -> Eq_refl + | DataCountField, DataCountField -> Eq_refl + | CodeField, CodeField -> Eq_refl + | DataField, DataField -> Eq_refl + | _ -> Neq + +let cases_for_field_type : + type a. int -> a field_type -> field Data_encoding.case list = + fun tag field -> + let open Data_encoding in + [ + (let title = "vec_" ^ title_for_field_type field in + case + ~title + (Tag (2 * tag)) + (obj3 + (req "kind" (constant title)) + (req "values" (list @@ encoding_for_field_type field)) + (req "len" int31)) + (fun f -> + match f with + | VecField (field', l, i) -> ( + match field_type_eq field field' with + | Eq_refl -> Some ((), l, i) + | Neq -> None) + | _ -> None) + (fun ((), l, i) -> VecField (field, l, i))); + (let title = "single_" ^ title_for_field_type field in + case + ~title + (Tag ((2 * tag) + 1)) + (obj2 + (req "kind" (constant title)) + (req "value" (option @@ encoding_for_field_type field))) + (fun f -> + match f with + | SingleField (field', o) -> ( + match field_type_eq field field' with + | Eq_refl -> Some ((), o) + | Neq -> None) + | _ -> None) + (fun ((), o) -> SingleField (field, o))); + ] + +let field : field Data_encoding.t = + let open Data_encoding in + union + @@ List.concat + [ + cases_for_field_type 0 TypeField; + cases_for_field_type 1 ImportField; + cases_for_field_type 2 FuncField; + cases_for_field_type 3 TableField; + cases_for_field_type 4 MemoryField; + cases_for_field_type 5 GlobalField; + cases_for_field_type 6 ExportField; + cases_for_field_type 7 StartField; + cases_for_field_type 8 ElemField; + cases_for_field_type 9 DataCountField; + cases_for_field_type 10 CodeField; + cases_for_field_type 11 DataField; + ] + +let vec_map_kont : + 'a Data_encoding.t -> + 'b Data_encoding.t -> + ('a, 'b) vec_map_kont Data_encoding.t = + fun in_encoding out_encoding -> + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"collect" + (obj2 (req "index" int31) (req "input" @@ list in_encoding)) + (function Collect (i, l) -> Some (i, l) | _ -> None) + (fun (i, l) -> Collect (i, l)); + case + (Tag 1) + ~title:"rev" + (obj3 + (req "input" @@ list in_encoding) + (req "output" @@ list out_encoding) + (req "index" int31)) + (function Rev (i, o, x) -> Some (i, o, x) | _ -> None) + (fun (i, o, x) -> Rev (i, o, x)); + ] + +let vec_kont : 'a Data_encoding.t -> 'a vec_kont Data_encoding.t = + fun encoding -> vec_map_kont encoding encoding + +let pos = Data_encoding.int31 + +let size = + Data_encoding.( + conv + (fun {size; start} -> (size, start)) + (fun (size, start) -> {size; start}) + (obj2 (req "size" int31) (req "start" pos))) + +let name_step = + let open Data_encoding in + union + [ + case + ~title:"NKStart" + (Tag 0) + (obj1 (req "kind" @@ constant "NKStart")) + (function NKStart -> Some () | _ -> None) + (fun () -> NKStart); + case + ~title:"MKParse" + (Tag 1) + (obj3 + (req "kind" @@ constant "MKParse") + (req "pos" pos) + (req "vec" @@ vec_kont int31)) + (function NKParse (pos, vec) -> Some ((), pos, vec) | _ -> None) + (fun ((), pos, vec) -> NKParse (pos, vec)); + case + ~title:"NKStop" + (Tag 2) + (obj2 (req "kind" @@ constant "NKStop") (req "result" @@ list int31)) + (function NKStop res -> Some ((), res) | _ -> None) + (fun ((), res) -> NKStop res); + ] + +let utf8 = Data_encoding.(list int31) + +let import_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"ImpKStart" + (obj1 (req "kind" @@ constant "ImpKStart")) + (function ImpKStart -> Some () | _ -> None) + (fun () -> ImpKStart); + case + (Tag 1) + ~title:"ImpKModuleName" + (obj2 + (req "kind" @@ constant "ImpKModuleName") + (req "name_step" name_step)) + (function ImpKModuleName step -> Some ((), step) | _ -> None) + (fun ((), step) -> ImpKModuleName step); + case + (Tag 2) + ~title:"ImpKItemName" + (obj3 + (req "kind" @@ constant "ImpKItemName") + (req "utf8" utf8) + (req "name_step" name_step)) + (function + | ImpKItemName (utf8, name_step) -> Some ((), utf8, name_step) + | _ -> None) + (fun ((), utf8, name_step) -> ImpKItemName (utf8, name_step)); + case + (Tag 3) + ~title:"ImpKStop" + (obj2 + (req "kind" @@ constant "ImpKStop") + (req "res" Ast_encoding.import_encoding')) + (function ImpKStop res -> Some ((), res) | _ -> None) + (fun ((), res) -> ImpKStop res); + ] + +let export_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"ExpKStart" + (obj1 (req "kind" @@ constant "ExpKStart")) + (function ExpKStart -> Some () | _ -> None) + (fun () -> ExpKStart); + case + (Tag 1) + ~title:"ExpKName" + (obj2 (req "kind" @@ constant "ExpKName") (req "name_step" name_step)) + (function ExpKName name_step -> Some ((), name_step) | _ -> None) + (fun ((), name_step) -> ExpKName name_step); + case + (Tag 2) + ~title:"ExpKStop" + (obj2 + (req "kind" @@ constant "ExpKStop") + (req "export" Ast_encoding.export_encoding')) + (function ExpKStop export -> Some ((), export) | _ -> None) + (fun ((), export) -> ExpKStop export); + ] + +let instr_block_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"IKStop" + (obj2 + (req "kind" @@ constant "IKStop") + (req "result" @@ list Ast_encoding.instr_encoding)) + (function IKStop res -> Some ((), res) | _ -> None) + (fun ((), res) -> IKStop res); + case + (Tag 1) + ~title:"IKRev" + (obj3 + (req "kind" @@ constant "IKRev") + (req "input" @@ list Ast_encoding.instr_encoding) + (req "output" @@ list Ast_encoding.instr_encoding)) + (function + | IKRev (input, output) -> Some ((), input, output) | _ -> None) + (fun ((), input, output) -> IKRev (input, output)); + case + (Tag 2) + ~title:"IKNext" + (obj2 + (req "kind" @@ constant "IKNext") + (req "accumulator" @@ list Ast_encoding.instr_encoding)) + (function IKNext res -> Some ((), res) | _ -> None) + (fun ((), res) -> IKNext res); + case + (Tag 3) + ~title:"IKBlock" + (obj3 + (req "kind" @@ constant "IKBlock") + (req "block_type" @@ Ast_encoding.block_type_encoding) + (req "top" int31)) + (function + | IKBlock (block_type, idx) -> Some ((), block_type, idx) | _ -> None) + (fun ((), block_type, idx) -> IKBlock (block_type, idx)); + case + (Tag 4) + ~title:"IKLoop" + (obj3 + (req "kind" @@ constant "IKLoop") + (req "block_type" @@ Ast_encoding.block_type_encoding) + (req "top" int31)) + (function + | IKLoop (block_type, idx) -> Some ((), block_type, idx) | _ -> None) + (fun ((), block_type, idx) -> IKLoop (block_type, idx)); + case + (Tag 5) + ~title:"IKIf1" + (obj3 + (req "kind" @@ constant "IKIf1") + (req "block_type" @@ Ast_encoding.block_type_encoding) + (req "top" int31)) + (function + | IKIf1 (block_type, idx) -> Some ((), block_type, idx) | _ -> None) + (fun ((), block_type, idx) -> IKIf1 (block_type, idx)); + case + (Tag 6) + ~title:"IKIf2" + (obj4 + (req "kind" @@ constant "IKIf2") + (req "block_type" @@ Ast_encoding.block_type_encoding) + (req "top" int31) + (req "instructinos" @@ list Ast_encoding.instr_encoding)) + (function + | IKIf2 (block_type, idx, instrs) -> Some ((), block_type, idx, instrs) + | _ -> None) + (fun ((), block_type, idx, instrs) -> IKIf2 (block_type, idx, instrs)); + ] + +let index_kind = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"Indexed" + (constant "indexed") + (function Indexed -> Some () | _ -> None) + (fun () -> Indexed); + case + (Tag 1) + ~title:"Const" + (constant "indexed") + (function Const -> Some () | _ -> None) + (fun () -> Const); + ] diff --git a/src/lib_scoru_wasm/types_encoding.ml b/src/lib_scoru_wasm/types_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..043678f2c321cb82e38e1eff3a38cde6425390f8 --- /dev/null +++ b/src/lib_scoru_wasm/types_encoding.ml @@ -0,0 +1,139 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* 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 Types + +(* TODO: placeholder, implemented in !5484 *) +let vec_type_encoding = + Data_encoding.(conv (fun V128Type -> ()) (fun () -> V128Type) unit) + +let pack_size_encoding = + Data_encoding.string_enum + [ + ("Pack8", Pack8); + ("Pack16", Pack16); + ("Pack32", Pack32); + ("Pack64", Pack64); + ] + +let pack_shape_encoding = + Data_encoding.string_enum + [("Pack8x8", Pack8x8); ("Pack16x4", Pack16x4); ("Pack32x2", Pack32x2)] + +let extension_encoding = Data_encoding.string_enum [("SX", SX); ("ZX", ZX)] + +let vec_extension_encoding = + let open Data_encoding in + union + [ + case + ~title:"ExtLane" + (Tag 0) + (obj1 (req "ExtLane" (tup2 pack_shape_encoding extension_encoding))) + (function ExtLane (s, e) -> Some (s, e) | _ -> None) + (fun (s, e) -> ExtLane (s, e)); + case + ~title:"ExtSplat" + (Tag 1) + (constant "ExtSplat") + (function ExtSplat -> Some () | _ -> None) + (fun () -> ExtSplat); + case + ~title:"ExtZero" + (Tag 2) + (constant "ExtZero") + (function ExtZero -> Some () | _ -> None) + (fun () -> ExtZero); + ] + +(* TODO: placeholder, implemented in !5484 *) +let num_type_encoding : num_type Data_encoding.t = + Data_encoding.( + conv + (fun _ -> failwith "num_type_encoding") + (fun _ -> failwith "num_type_encoding") + string) + +(* TODO: placeholder, implemented in !5484 *) +let value_type_encoding : value_type Data_encoding.t = + Data_encoding.( + conv + (fun _ -> failwith "value_type_encoding") + (fun _ -> failwith "value_type_encoding") + string) + +(* TODO: placeholder, implemented in !5484 *) +let ref_type_encoding : ref_type Data_encoding.t = + Data_encoding.( + conv + (fun _ -> failwith "ref_type_encoding") + (fun _ -> failwith "ref_type_encoding") + string) + +(* TODO: placeholder, implemented in !5484 *) +let mutability_encoding : mutability Data_encoding.t = + Data_encoding.( + conv + (fun _ -> failwith "mutability_encoding") + (fun _ -> failwith "mutability_encoding") + string) + +let global_type_encoding = + Data_encoding.( + conv + (fun (GlobalType (v, m)) -> (v, m)) + (fun (v, m) -> GlobalType (v, m)) + (tup2 value_type_encoding mutability_encoding)) + +(* TODO: placeholder, implemented in !5484 *) +let limits_encoding _value_encoding : _ limits Data_encoding.t = + Data_encoding.( + conv + (fun _ -> failwith "limits_encoding") + (fun _ -> failwith "limits_encoding") + string) + +let table_type_encoding = + Data_encoding.( + conv + (fun (TableType (l, r)) -> (l, r)) + (fun (l, r) -> TableType (l, r)) + (tup2 (limits_encoding int32) ref_type_encoding)) + +let memory_type_encoding = + Data_encoding.( + conv + (fun (MemoryType l) -> l) + (fun l -> MemoryType l) + (limits_encoding int32)) + +(* TODO *) +let func_type_encoding : func_type Data_encoding.t = + Data_encoding.( + conv + (fun _ -> failwith "func_type_encoding") + (fun _ -> failwith "func_type_encoding") + string) diff --git a/src/lib_scoru_wasm/values_encoding.ml b/src/lib_scoru_wasm/values_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..7db9ba186486aa247d7011dd5fa2af9e46f72227 --- /dev/null +++ b/src/lib_scoru_wasm/values_encoding.ml @@ -0,0 +1,201 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* 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 Values + +module I32 = struct + type t = I32.t + + let encoding = Data_encoding.int32 +end + +module I64 = struct + type t = I64.t + + let encoding = Data_encoding.int64 +end + +module F32 = struct + type t = F32.t + + (* TODO: Floats are not used, but there's probably a better encoding. *) + let encoding = + Data_encoding.conv F32.to_string F32.of_string Data_encoding.string +end + +module F64 = struct + type t = F64.t + + (* TODO: Floats are not used, but there's probably a better encoding. *) + let encoding = + Data_encoding.conv F64.to_string F64.of_string Data_encoding.string +end + +module V128 = struct + type t = V128.t + + let encoding = + Data_encoding.conv V128.to_bits V128.of_bits Data_encoding.string + + open V128 + + let laneop_encoding i8x16_encoding i16x8_encoding i32x4_encoding + i64x2_encoding f32x4_encoding f64x2_encoding = + let open Data_encoding in + union + [ + case + ~title:"I8x16" + (Tag 0) + (obj1 (req "I8x16" i8x16_encoding)) + (function I8x16 v -> Some v | _ -> None) + (fun v -> I8x16 v); + case + ~title:"I16x8" + (Tag 1) + (obj1 (req "I16x8" i16x8_encoding)) + (function I16x8 v -> Some v | _ -> None) + (fun v -> I16x8 v); + case + ~title:"I32x4" + (Tag 2) + (obj1 (req "I32x4" i32x4_encoding)) + (function I32x4 v -> Some v | _ -> None) + (fun v -> I32x4 v); + case + ~title:"I64x2" + (Tag 3) + (obj1 (req "I64x2" i64x2_encoding)) + (function I64x2 v -> Some v | _ -> None) + (fun v -> I64x2 v); + case + ~title:"F32x4" + (Tag 4) + (obj1 (req "F32x4" f32x4_encoding)) + (function F32x4 v -> Some v | _ -> None) + (fun v -> F32x4 v); + case + ~title:"F64x2" + (Tag 5) + (obj1 (req "F64x2" f64x2_encoding)) + (function F64x2 v -> Some v | _ -> None) + (fun v -> F64x2 v); + ] +end + +let op_encoding i32_encoding i64_encoding f32_encoding f64_encoding = + let open Data_encoding in + union + [ + case + ~title:"I32" + (Tag 0) + (obj1 (req "I32" i32_encoding)) + (function I32 v -> Some v | _ -> None) + (fun v -> I32 v); + case + ~title:"I64" + (Tag 1) + (obj1 (req "I64" i64_encoding)) + (function I64 v -> Some v | _ -> None) + (fun v -> I64 v); + case + ~title:"F32" + (Tag 2) + (obj1 (req "F32" f32_encoding)) + (function F32 v -> Some v | _ -> None) + (fun v -> F32 v); + case + ~title:"F64" + (Tag 3) + (obj1 (req "F64" f64_encoding)) + (function F64 v -> Some v | _ -> None) + (fun v -> F64 v); + ] + +let vecop_encoding v128_encoding = + Data_encoding.(conv (fun (V128 v) -> v) (fun v -> V128 v) v128_encoding) + +let num_encoding = + op_encoding I32.encoding I64.encoding F32.encoding F64.encoding + +let vec_encoding = vecop_encoding V128.encoding + +(* TODO placeholder *) +let func_inst_encoding = + Data_encoding.( + conv + (fun _ -> failwith "func_inst_encoding") + (fun _ -> failwith "func_inst_encoding") + unit) + +let ref_encoding = + let open Data_encoding in + union + [ + case + ~title:"NullRef" + (Tag 0) + (obj1 (req "NullRef" Types_encoding.ref_type_encoding)) + (function Values.NullRef r -> Some r | _ -> None) + (fun r -> Values.NullRef r); + case + ~title:"FuncRef" + (Tag 1) + (obj1 (req "FuncRef" func_inst_encoding)) + (function Instance.FuncRef r -> Some r | _ -> None) + (fun r -> Instance.FuncRef r); + case + ~title:"ExternRef" + (Tag 2) + (obj1 (req "ExternRef" int32)) + (function Script.ExternRef r -> Some r | _ -> None) + (fun r -> Script.ExternRef r); + ] + +let values_encoding = + let open Data_encoding in + union + [ + case + ~title:"Num" + (Tag 0) + (obj1 (req "Num" num_encoding)) + (function Num n -> Some n | _ -> None) + (fun n -> Num n); + case + ~title:"Vec" + (Tag 1) + (obj1 (req "Vec" vec_encoding)) + (function Vec v -> Some v | _ -> None) + (fun v -> Vec v); + case + ~title:"Ref" + (Tag 2) + (obj1 (req "Ref" ref_encoding)) + (function Ref r -> Some r | _ -> None) + (fun r -> Ref r); + ] diff --git a/src/lib_webassembly/interpreter/binary/decode.ml b/src/lib_webassembly/interpreter/binary/decode.ml index 7ed25f220682b8f6a02a68429674995343ecebf5..d2111a950f5f8c3dc6e4d9e121970378d27aa96b 100644 --- a/src/lib_webassembly/interpreter/binary/decode.ml +++ b/src/lib_webassembly/interpreter/binary/decode.ml @@ -1865,6 +1865,25 @@ let module_step s state = (* Stop cannot reduce. *) -> assert false +type decode_kont = + | D_Start of { name : string; input : string} + | D_Next of {start : int; input : stream; step : module_kont} + | D_Result of module_ + +let decode_step = function + | D_Start {name; input} -> + let input = stream name input in + let start = pos input in + let step = {building_state = []; kont = MKStart} in + D_Next {input; start; step} + | D_Next {input; start; step = {kont = MKStop m; _}} -> + let stop = pos input in + D_Result (Source.(m @@ region input start stop) ) + | D_Next ({input; step; _ } as k) -> + let step = module_step input step in + D_Next {k with step} + | D_Result _ -> raise (Invalid_argument "decode_step: no more step") + let module_ s = let rec loop = function | { kont = MKStop m; _ } -> m diff --git a/src/lib_webassembly/interpreter/binary/decode.mli b/src/lib_webassembly/interpreter/binary/decode.mli index 4460023d2586ca7628f0d319369570bb8313c2cc..367f4efab1fd1621d69690d2ae5d6575e10ed3b4 100644 --- a/src/lib_webassembly/interpreter/binary/decode.mli +++ b/src/lib_webassembly/interpreter/binary/decode.mli @@ -3,3 +3,243 @@ exception Code of Source.region * string val decode : string -> string -> Ast.module_ (* raises Code *) val decode_custom : Ast.name -> string -> string -> string list (* raises Code *) + +(* ------ Tick functions and dependencies ----------------------------------- *) + +open Ast +open Types + +(* We re-export these types to be able to write encodings in + [lib_scoru_wasm]. *) + +type section_tag = + [ `CodeSection + | `CustomSection + | `DataCountSection + | `DataSection + | `ElemSection + | `ExportSection + | `FuncSection + | `GlobalSection + | `ImportSection + | `MemorySection + | `StartSection + | `TableSection + | `TypeSection ] + +(** Sections representation. *) +type _ field_type = + | TypeField : type_ field_type + | ImportField : import field_type + | FuncField : var field_type + | TableField : table field_type + | MemoryField : memory field_type + | GlobalField : global field_type + | ExportField : export field_type + | StartField : start field_type + | ElemField : elem_segment field_type + | DataCountField : int32 field_type + | CodeField : func field_type + | DataField : data_segment field_type + +(** Result of a section parsing, being either a single value or a vector. *) +type field = + | VecField : 'a field_type * 'a list * int -> field + | SingleField : 'a field_type * 'a option -> field + +(** Vector and size continuations *) + +(** Vector accumulator, used in two steps: first accumulating the values, then + reversing them and possibly mapping them, counting the number of values in + the list. Continuation passing style transformation of {!List.map} also + returning length. *) +type ('a, 'b) vec_map_kont = + Collect of int * 'a list + | Rev of 'a list * 'b list * int + +type 'a vec_kont = ('a, 'a) vec_map_kont + +type pos = int + +type size = { size: int; start: pos} + +type name_step = + | NKStart + (** UTF8 name starting point. *) + | NKParse of pos * (int, int) vec_map_kont + (** UTF8 char parsing. *) + | NKStop of int list + (** UTF8 name final step.*) + +type utf8 = int list + +type import_kont = + | ImpKStart + (** Import parsing starting point. *) + | ImpKModuleName of name_step + (** Import module name parsing UTF8 char per char step. *) + | ImpKItemName of utf8 * name_step + (** Import item name parsing UTF8 char per char step. *) + | ImpKStop of import' + (** Import final step. *) + +type export_kont = + | ExpKStart + (** Export parsing starting point. *) + | ExpKName of name_step + (** Export name parsing UTF8 char per char step. *) + | ExpKStop of export' + (** Export final step. *) + +(** Instruction parsing continuations. *) +type instr_block_kont = + | IKStop of instr list + (** Final step of a block parsing. *) + | IKRev of instr list * instr list + (** Reversal of lists of instructions. *) + | IKNext of instr list + (** Tag parsing, containing the accumulation of already parsed values. *) + | IKBlock of block_type * int + (** Block parsing step. *) + | IKLoop of block_type * int + (** Loop parsing step. *) + | IKIf1 of block_type * int + (** If parsing step. *) + | IKIf2 of block_type * int * instr list + (** If .. else parsing step. *) + +type index_kind = Indexed | Const + +type elem_kont = + | EKStart + (** Starting point of an element segment parsing. *) + | EKMode of + { + left: pos; + index : int32 Source.phrase; + index_kind: index_kind; + early_ref_type : ref_type option; + offset_kont: pos * instr_block_kont list + } + (** Element segment mode parsing step. *) + | EKInitIndexed of + { mode: segment_mode; + ref_type: ref_type; + einit_vec: const vec_kont + } + (** Element segment initialization code parsing step for referenced values. *) + | EKInitConst of + { mode: segment_mode; + ref_type: ref_type; + einit_vec: const vec_kont; + einit_kont: pos * instr_block_kont list + } + (** Element segment initialization code parsing step for constant values. *) + | EKStop of elem_segment' + (** Final step of a segment parsing. *) + +(** Incremental chunked byte vector creation (from implicit input). *) +type byte_vector_kont = + | VKStart + (** Initial step. *) + | VKRead of Chunked_byte_vector.Buffer.t * int * int + (** Reading step, containing the current position in the string and the + length, reading byte per byte. *) + | VKStop of Chunked_byte_vector.Buffer.t + (** Final step, cannot reduce. *) + +(** Code section parsing. *) +type code_kont = + | CKStart + (** Starting point of a function parsing. *) + | CKLocals of + { left: pos; + size : size; + pos : pos; + vec_kont: (int32 * value_type, value_type) vec_map_kont; + locals_size: Int64.t; + } + (** Parsing step of local values of a function. *) + | CKBody of + { left: pos; + size : size; + locals: value_type list; + const_kont: instr_block_kont list; + } + (** Parsing step of the body of a function. *) + | CKStop of func + (** Final step of a parsed function, irreducible. *) + +type data_kont = + | DKStart + (** Starting point of a data segment parsing. *) + | DKMode of + { left : pos; + index: int32 Source.phrase; + offset_kont: pos * instr_block_kont list + } + (** Data segment mode parsing step. *) + | DKInit of { dmode: segment_mode; init_kont: byte_vector_kont } + | DKStop of data_segment' + (** Final step of a data segment parsing. *) + +(** Module parsing steps *) +type module_kont' = + | MKStart + (** Initial state of a module parsing *) + | MKSkipCustom : ('a field_type * section_tag) option -> module_kont' + (** Custom section which are skipped, with the next section to parse. *) + | MKFieldStart : 'a field_type * section_tag -> module_kont' + (** Starting point of a section, handles parsing generic section header. *) + | MKField : 'a field_type * size * 'a vec_kont -> module_kont' + (** Section currently parsed, accumulating each element from the underlying vector. *) + | MKElaborateFunc : var list * func list * func vec_kont * bool -> module_kont' + (** Elaboration of functions from the code section with their declared type in + the func section, and accumulating invariants conditions associated to + functions. *) + | MKBuild of func list option * bool + (** Accumulating the parsed sections vectors into a module and checking + invariants. *) + | MKStop of module_' (* TODO (#3120): actually, should be module_ *) + (** Final step of the parsing, cannot reduce. *) + + (* For the next continuations, the vectors are only used for accumulation, and + reduce to `MK_Field(.., Rev ..)`. *) + | MKImport of import_kont * pos * size * import vec_kont + (** Import section parsing. *) + | MKExport of export_kont * pos * size * export vec_kont + (** Export section parsing. *) + | MKGlobal of global_type * int * instr_block_kont list * size * global vec_kont + (** Globals section parsing, containing the starting position, the + continuation of the current global block instruction, and the size of the + section. *) + | MKElem of elem_kont * int * size * elem_segment vec_kont + (** Element segments section parsing, containing the current element parsing + continuation, the starting position of the current element, the size of + the section. *) + | MKData of data_kont * int * size * data_segment vec_kont + (** Data segments section parsing, containing the current data parsing + continuation, the starting position of the current data, the size of the + section. *) + | MKCode of code_kont * int * size * func vec_kont + (** Code section parsing, containing the current function parsing + continuation, the starting position of the current function, the size of + the section. *) + +type module_kont = + { building_state : field list; (** Accumulated parsed sections. *) + kont : module_kont' } + +type stream = +{ + name : string; + bytes : string; + pos : int ref; +} + +type decode_kont = + | D_Start of { name : string; input : string} + | D_Next of {start : int; input : stream; step : module_kont} + | D_Result of module_ + +val decode_step : decode_kont -> decode_kont