diff --git a/manifest/main.ml b/manifest/main.ml index f6c7b50f12df3412fac9bef2dece14f533fa2397..fa113dca3d81ee5c7b0e64bf7c5aba8edf56dff1 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3185,6 +3185,7 @@ end = struct "main" ~path:(path // "lib_protocol/test/integration") ~opam:(sf "tezos-protocol-%s-tests" name_dash) + ~dep_files:(conditional_list [("block.wasm", N.(number >= 014))]) ~deps: [ octez_context; diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 12e3fc0f6492d726901bf07b001fd121093bc06b..42f70eb0d6914a53f237763437768aa3d2805b34 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1135,6 +1135,9 @@ struct let compute_step (tree : Tree.tree) = Wasm.compute_step tree + let boot (ctxt : Tree.t) (boot_sector : string) = + Wasm.boot ctxt boot_sector + let set_input_step {inbox_level; message_counter} payload (tree : Tree.tree) = Wasm.set_input_step {inbox_level; message_counter} payload tree diff --git a/src/lib_protocol_environment/sigs/v6.ml b/src/lib_protocol_environment/sigs/v6.ml index ad963f449467df70adb2f620cdb6aa87ca5150d0..0f498647381e4497fe81742b70525ff230df0379 100644 --- a/src/lib_protocol_environment/sigs/v6.ml +++ b/src/lib_protocol_environment/sigs/v6.ml @@ -11178,6 +11178,8 @@ type info = { module Make (Tree : Context.TREE with type key = string list and type value = bytes) : sig + val boot : Tree.t -> string -> Tree.tree Lwt.t + val compute_step : Tree.tree -> Tree.tree Lwt.t val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t diff --git a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli index 3d9b45fea9c5c8999c4003832c04ef3fa577a67b..34cfb2e52bf7ba67a5b7f1ce73fd94f9049b1b63 100644 --- a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli @@ -37,6 +37,8 @@ type info = { module Make (Tree : Context.TREE with type key = string list and type value = bytes) : sig + val boot : Tree.t -> string -> Tree.tree Lwt.t + val compute_step : Tree.tree -> Tree.tree Lwt.t val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t 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..52fc61d65bfcd043724006559e34378600b1cb2e --- /dev/null +++ b/src/lib_scoru_wasm/kont_encodings.ml @@ -0,0 +1,983 @@ +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); + ] + +type packed_field_type = Packed : 'a field_type -> packed_field_type + +let packed_field_type : packed_field_type Data_encoding.t = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"type_field" + (constant "type_field") + (function Packed TypeField -> Some () | _ -> None) + (fun () -> Packed TypeField); + case + (Tag 1) + ~title:"import_field" + (constant "import_field") + (function Packed ImportField -> Some () | _ -> None) + (fun () -> Packed ImportField); + case + (Tag 2) + ~title:"func_field" + (constant "func_field") + (function Packed FuncField -> Some () | _ -> None) + (fun () -> Packed FuncField); + case + (Tag 3) + ~title:"table_field" + (constant "table_field") + (function Packed TableField -> Some () | _ -> None) + (fun () -> Packed TableField); + case + (Tag 4) + ~title:"memory_field" + (constant "memory_field") + (function Packed MemoryField -> Some () | _ -> None) + (fun () -> Packed MemoryField); + case + (Tag 5) + ~title:"global_field" + (constant "global_field") + (function Packed GlobalField -> Some () | _ -> None) + (fun () -> Packed GlobalField); + case + (Tag 6) + ~title:"export_field" + (constant "export_field") + (function Packed ExportField -> Some () | _ -> None) + (fun () -> Packed ExportField); + case + (Tag 7) + ~title:"start_field" + (constant "start_field") + (function Packed StartField -> Some () | _ -> None) + (fun () -> Packed StartField); + case + (Tag 8) + ~title:"start_field" + (constant "start_field") + (function Packed StartField -> Some () | _ -> None) + (fun () -> Packed StartField); + case + (Tag 9) + ~title:"elem_field" + (constant "elem_field") + (function Packed ElemField -> Some () | _ -> None) + (fun () -> Packed ElemField); + case + (Tag 10) + ~title:"data_count_field" + (constant "data_count_field") + (function Packed DataCountField -> Some () | _ -> None) + (fun () -> Packed DataCountField); + case + (Tag 11) + ~title:"code_field" + (constant "code_field") + (function Packed CodeField -> Some () | _ -> None) + (fun () -> Packed CodeField); + case + (Tag 12) + ~title:"data_field" + (constant "data_field") + (function Packed DataField -> Some () | _ -> None) + (fun () -> Packed DataField); + ] + +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); + ] + +let elem_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"EKStart" + (obj1 (req "kind" @@ constant "EKStart")) + (function EKStart -> Some () | _ -> None) + (fun () -> EKStart); + case + (Tag 1) + ~title:"EKMode" + (obj6 + (req "kind" @@ constant "EKMode") + (req "left" pos) + (req "index" @@ Ast_encoding.phrase_encoding int32) + (req "index_kind" index_kind) + (req "early_ref_type" @@ option Types_encoding.ref_type_encoding) + (req "offset_kont" (tup2 pos (list instr_block_kont)))) + (function + | EKMode {left; index; index_kind; early_ref_type; offset_kont} -> + Some ((), left, index, index_kind, early_ref_type, offset_kont) + | _ -> None) + (fun ((), left, index, index_kind, early_ref_type, offset_kont) -> + EKMode {left; index; index_kind; early_ref_type; offset_kont}); + case + (Tag 2) + ~title:"EKInitIndexed" + (obj4 + (req "kind" @@ constant "EKInitIndexed") + (req "mode" Ast_encoding.segment_mode_encoding) + (req "ref_type" Types_encoding.ref_type_encoding) + (req "einit_vec" @@ vec_kont Ast_encoding.const_encoding)) + (function + | EKInitIndexed {mode; ref_type; einit_vec} -> + Some ((), mode, ref_type, einit_vec) + | _ -> None) + (fun ((), mode, ref_type, einit_vec) -> + EKInitIndexed {mode; ref_type; einit_vec}); + case + (Tag 3) + ~title:"EKInitConst" + (obj5 + (req "kind" @@ constant "EKInitConst") + (req "mode" Ast_encoding.segment_mode_encoding) + (req "ref_type" Types_encoding.ref_type_encoding) + (req "einit_vec" @@ vec_kont Ast_encoding.const_encoding) + (req "einit_kont" @@ tup2 pos (list instr_block_kont))) + (function + | EKInitConst {mode; ref_type; einit_vec; einit_kont} -> + Some ((), mode, ref_type, einit_vec, einit_kont) + | _ -> None) + (fun ((), mode, ref_type, einit_vec, einit_kont) -> + EKInitConst {mode; ref_type; einit_vec; einit_kont}); + case + (Tag 4) + ~title:"EKStop" + (obj2 + (req "kind" @@ constant "EKStop") + (req "elem" Ast_encoding.elem_segment_encoding')) + (function EKStop elem -> Some ((), elem) | _ -> None) + (fun ((), elem) -> EKStop elem); + ] + +let byte_vector_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"VKStart" + (obj1 (req "kind" @@ constant "VKStart")) + (function VKStart -> Some () | _ -> None) + (fun () -> VKStart); + case + (Tag 1) + ~title:"VKRead" + (obj4 + (req "kind" @@ constant "VKRead") + (req "buffer" Lazy_encoding.chunked_byte_vector) + (req "pos" int31) + (req "len" int31)) + (function + | VKRead (buffer, pos, len) -> Some ((), buffer, pos, len) | _ -> None) + (fun ((), buffer, pos, len) -> VKRead (buffer, pos, len)); + case + (Tag 2) + ~title:"VKStop" + (obj2 + (req "kind" @@ constant "VKStop") + (req "buffer" Lazy_encoding.chunked_byte_vector)) + (function VKStop buffer -> Some ((), buffer) | _ -> None) + (fun ((), buffer) -> VKStop buffer); + ] + +let code_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"CKStart" + (obj1 (req "kind" @@ constant "CKStart")) + (function CKStart -> Some () | _ -> None) + (fun () -> CKStart); + case + (Tag 1) + ~title:"CKLocals" + (obj6 + (req "kind" @@ constant "CKLocals") + (req "left" pos) + (req "size" size) + (req "pos" pos) + (req "vec_kont" + @@ vec_map_kont + (tup2 int32 Types_encoding.value_type_encoding) + Types_encoding.value_type_encoding) + (req "locals_size" int64)) + (function + | CKLocals {left; size; pos; vec_kont; locals_size} -> + Some ((), left, size, pos, vec_kont, locals_size) + | _ -> None) + (fun ((), left, size, pos, vec_kont, locals_size) -> + CKLocals {left; size; pos; vec_kont; locals_size}); + case + (Tag 2) + ~title:"CKBody" + (obj5 + (req "kind" @@ constant "CKBody") + (req "left" pos) + (req "size" size) + (req "locals" @@ list Types_encoding.value_type_encoding) + (req "const_kont" @@ list instr_block_kont)) + (function + | CKBody {left; size; locals; const_kont} -> + Some ((), left, size, locals, const_kont) + | _ -> None) + (fun ((), left, size, locals, const_kont) -> + CKBody {left; size; locals; const_kont}); + case + (Tag 3) + ~title:"CKStop" + (obj2 + (req "kind" @@ constant "CKStop") + (req "res" Ast_encoding.func_encoding)) + (function CKStop res -> Some ((), res) | _ -> None) + (fun ((), res) -> CKStop res); + ] + +let data_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"DKStart" + (obj1 (req "kind" @@ constant "DKStart")) + (function DKStart -> Some () | _ -> None) + (fun () -> DKStart); + case + (Tag 1) + ~title:"DKMode" + (obj4 + (req "kind" @@ constant "DKMode") + (req "left" pos) + (req "index" @@ Ast_encoding.phrase_encoding int32) + (req "offset_kont" (tup2 pos (list instr_block_kont)))) + (function + | DKMode {left; index; offset_kont} -> + Some ((), left, index, offset_kont) + | _ -> None) + (fun ((), left, index, offset_kont) -> + DKMode {left; index; offset_kont}); + case + (Tag 2) + ~title:"DKInit" + (obj3 + (req "kind" @@ constant "DKInit") + (req "dmode" Ast_encoding.segment_mode_encoding) + (req "init_kont" byte_vector_kont)) + (function + | DKInit {dmode; init_kont} -> Some ((), dmode, init_kont) | _ -> None) + (fun ((), dmode, init_kont) -> DKInit {dmode; init_kont}); + case + (Tag 3) + ~title:"DKStop" + (obj2 + (req "kind" @@ constant "DKStop") + (req "res" Ast_encoding.data_segment_encoding')) + (function DKStop res -> Some ((), res) | _ -> None) + (fun ((), res) -> DKStop res); + ] + +type packed_field_type_and_vec = + | Packed_field_type_and_vec : + 'a field_type * 'a vec_kont + -> packed_field_type_and_vec + +let cases_for_field_type_and_vec : + type a. + int -> a field_type -> packed_field_type_and_vec Data_encoding.case list = + fun tag field -> + let open Data_encoding in + [ + (let title = title_for_field_type field in + case + ~title + (Tag tag) + (obj2 + (req "field_type" packed_field_type) + (req "vec_kont" @@ vec_kont (encoding_for_field_type field))) + (function + | Packed_field_type_and_vec (f, v) -> ( + match field_type_eq field f with + | Eq_refl -> Some (Packed f, v) + | _ -> None)) + (fun (Packed f', v) -> + match field_type_eq field f' with + | Eq_refl -> Packed_field_type_and_vec (field, v) + | _ -> raise (Invalid_argument "unexpected field_type"))); + ] + +let field_type_and_vec : packed_field_type_and_vec Data_encoding.t = + let open Data_encoding in + union + @@ List.concat + [ + cases_for_field_type_and_vec 0 TypeField; + cases_for_field_type_and_vec 1 ImportField; + cases_for_field_type_and_vec 2 FuncField; + cases_for_field_type_and_vec 3 TableField; + cases_for_field_type_and_vec 4 MemoryField; + cases_for_field_type_and_vec 5 GlobalField; + cases_for_field_type_and_vec 6 ExportField; + cases_for_field_type_and_vec 7 StartField; + cases_for_field_type_and_vec 8 ElemField; + cases_for_field_type_and_vec 9 DataCountField; + cases_for_field_type_and_vec 10 CodeField; + cases_for_field_type_and_vec 11 DataField; + ] + +let module_kont' = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"MKStart" + (obj1 (req "kind" @@ constant "MKStart")) + (function MKStart -> Some () | _ -> None) + (fun () -> MKStart); + case + (Tag 1) + ~title:"MKSkipCustom" + (obj2 + (req "kind" @@ constant "MKSkipCustom") + (req "value" @@ option (tup2 packed_field_type section_tag))) + (function + | MKSkipCustom (Some (f, value)) -> Some ((), Some (Packed f, value)) + | MKSkipCustom None -> Some ((), None) + | _ -> None) + (function + | (), Some (Packed f, value) -> MKSkipCustom (Some (f, value)) + | (), None -> MKSkipCustom None); + case + (Tag 2) + ~title:"MKFieldStart" + (obj3 + (req "kind" @@ constant "MKFieldStart") + (req "field_type" packed_field_type) + (req "section_tag" section_tag)) + (function + | MKFieldStart (f, value) -> Some ((), Packed f, value) | _ -> None) + (function (), Packed f, value -> MKFieldStart (f, value)); + case + (Tag 3) + ~title:"MKField" + (obj3 + (req "kind" @@ constant "MKField") + (req "field_type_and_vec" field_type_and_vec) + (req "size" size)) + (function + | MKField (ft, size, vec_kont) -> + Some ((), Packed_field_type_and_vec (ft, vec_kont), size) + | _ -> None) + (function + | (), Packed_field_type_and_vec (ft, vec_kont), size -> + MKField (ft, size, vec_kont)); + case + (Tag 4) + ~title:"MKElaborateFunc" + (obj5 + (req "kind" @@ constant "MKElaborateFunc") + (req "vars" @@ list Ast_encoding.var_encoding) + (req "funcs" @@ list Ast_encoding.func_encoding) + (req "vec_kont" @@ vec_kont Ast_encoding.func_encoding) + (req "flag" bool)) + (function + | MKElaborateFunc (vars, funcs, vec_kont, flag) -> + Some ((), vars, funcs, vec_kont, flag) + | _ -> None) + (function + | (), vars, funcs, vec_kont, flag -> + MKElaborateFunc (vars, funcs, vec_kont, flag)); + case + (Tag 5) + ~title:"MKElaborateFunc" + (obj5 + (req "kind" @@ constant "MKElaborateFunc") + (req "vars" @@ list Ast_encoding.var_encoding) + (req "funcs" @@ list Ast_encoding.func_encoding) + (req "vec_kont" @@ vec_kont Ast_encoding.func_encoding) + (req "flag" bool)) + (function + | MKElaborateFunc (vars, funcs, vec_kont, flag) -> + Some ((), vars, funcs, vec_kont, flag) + | _ -> None) + (function + | (), vars, funcs, vec_kont, flag -> + MKElaborateFunc (vars, funcs, vec_kont, flag)); + case + (Tag 6) + ~title:"MKBuild" + (obj3 + (req "kind" @@ constant "MKBuild") + (req "parsed_sections" @@ option (list Ast_encoding.func_encoding)) + (req "flag" bool)) + (function MKBuild (l, f) -> Some ((), l, f) | _ -> None) + (fun ((), l, f) -> MKBuild (l, f)); + case + (Tag 7) + ~title:"MKStop" + (obj2 + (req "kind" @@ constant "MKStop") + (req "res" Ast_encoding.module_encoding')) + (function MKStop m -> Some ((), m) | _ -> None) + (fun ((), m) -> MKStop m); + case + (Tag 8) + ~title:"MKImport" + (obj5 + (req "kind" @@ constant "MKImport") + (req "import_kont" import_kont) + (req "pos" pos) + (req "size" size) + (req "vec_kont" @@ vec_kont Ast_encoding.import_encoding)) + (function + | MKImport (import_kont, pos, size, vec_kont) -> + Some ((), import_kont, pos, size, vec_kont) + | _ -> None) + (fun ((), import_kont, pos, size, vec_kont) -> + MKImport (import_kont, pos, size, vec_kont)); + case + (Tag 9) + ~title:"MKExport" + (obj5 + (req "kind" @@ constant "MKExport") + (req "export_kont" export_kont) + (req "pos" pos) + (req "size" size) + (req "vec_kont" @@ vec_kont Ast_encoding.export_encoding)) + (function + | MKExport (export_kont, pos, size, vec_kont) -> + Some ((), export_kont, pos, size, vec_kont) + | _ -> None) + (fun ((), export_kont, pos, size, vec_kont) -> + MKExport (export_kont, pos, size, vec_kont)); + case + (Tag 10) + ~title:"MKGlobal" + (obj6 + (req "kind" @@ constant "MKGlobal") + (req "gobal_type" Types_encoding.global_type_encoding) + (req "pos" int31) + (req "instrs" @@ list instr_block_kont) + (req "size" size) + (req "vec_kont" @@ vec_kont Ast_encoding.global_encoding)) + (function + | MKGlobal (global_type, pos, instrs, size, vec_kont) -> + Some ((), global_type, pos, instrs, size, vec_kont) + | _ -> None) + (fun ((), global_type, pos, instrs, size, vec_kont) -> + MKGlobal (global_type, pos, instrs, size, vec_kont)); + case + (Tag 11) + ~title:"MKElem" + (obj5 + (req "kind" @@ constant "MKElem") + (req "elem_kont" elem_kont) + (req "pos" pos) + (req "size" size) + (req "vec_kont" @@ vec_kont Ast_encoding.elem_segment_encoding)) + (function + | MKElem (elem_kont, pos, size, vec_kont) -> + Some ((), elem_kont, pos, size, vec_kont) + | _ -> None) + (fun ((), elem_kont, pos, size, vec_kont) -> + MKElem (elem_kont, pos, size, vec_kont)); + case + (Tag 12) + ~title:"MKData" + (obj5 + (req "kind" @@ constant "MKData") + (req "data_kont" data_kont) + (req "pos" pos) + (req "size" size) + (req "vec_kont" @@ vec_kont Ast_encoding.data_segment_encoding)) + (function + | MKData (data_kont, pos, size, vec_kont) -> + Some ((), data_kont, pos, size, vec_kont) + | _ -> None) + (fun ((), data_kont, pos, size, vec_kont) -> + MKData (data_kont, pos, size, vec_kont)); + case + (Tag 13) + ~title:"MKCode" + (obj5 + (req "kind" @@ constant "MKCode") + (req "code_kont" code_kont) + (req "pos" pos) + (req "size" size) + (req "vec_kont" @@ vec_kont Ast_encoding.func_encoding)) + (function + | MKCode (code_kont, pos, size, vec_kont) -> + Some ((), code_kont, pos, size, vec_kont) + | _ -> None) + (fun ((), code_kont, pos, size, vec_kont) -> + MKCode (code_kont, pos, size, vec_kont)); + ] + +let module_kont = + Data_encoding.( + conv + (fun {building_state; kont} -> (building_state, kont)) + (fun (building_state, kont) -> {building_state; kont}) + (obj2 (req "building_state" @@ list field) (req "kont" module_kont'))) + +let stream = + Data_encoding.( + conv + (fun {name; bytes; pos} -> (name, bytes, !pos)) + (fun (name, bytes, pos) -> {name; bytes; pos = ref pos}) + (obj3 (req "name" string) (req "bytes" string) (req "pos" int31))) + +let decode_kont = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"D_Start" + (obj3 + (req "kind" @@ constant "D_Start") + (req "name" string) + (req "input" string)) + (function D_Start {name; input} -> Some ((), name, input) | _ -> None) + (fun ((), name, input) -> D_Start {name; input}); + case + (Tag 1) + ~title:"D_Next" + (obj4 + (req "kind" @@ constant "D_Next") + (req "start" int31) + (req "input" stream) + (req "step" module_kont)) + (function + | D_Next {start; input; step} -> Some ((), start, input, step) + | _ -> None) + (fun ((), start, input, step) -> D_Next {start; input; step}); + case + (Tag 2) + ~title:"D_Result" + (obj2 + (req "kind" @@ constant "D_Result") + (req "result" @@ Ast_encoding.(phrase_encoding module_encoding'))) + (function D_Result result -> Some ((), result) | _ -> None) + (fun ((), result) -> D_Result result); + ] diff --git a/src/lib_scoru_wasm/lazy_encoding.ml b/src/lib_scoru_wasm/lazy_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..08fea6ef403e0dc2047e0511c7d8fbf96ffdbb6e --- /dev/null +++ b/src/lib_scoru_wasm/lazy_encoding.ml @@ -0,0 +1,6 @@ +open Tezos_webassembly_interpreter + +let chunked_byte_vector : Chunked_byte_vector.Buffer.t Data_encoding.t = + let open Data_encoding in + let open Chunked_byte_vector.Buffer in + conv to_string_unstable of_string string diff --git a/src/lib_scoru_wasm/tezos_scoru_wasm.ml b/src/lib_scoru_wasm/tezos_scoru_wasm.ml index 3de1f2f0b5d5e1356f105e08df2fadad396bbc0e..2a65800840177040fb95bf099608c363caa08a86 100644 --- a/src/lib_scoru_wasm/tezos_scoru_wasm.ml +++ b/src/lib_scoru_wasm/tezos_scoru_wasm.ml @@ -32,6 +32,8 @@ open Sigs +let ( let*! ) = Lwt.bind + type input = { inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; message_counter : Z.t; @@ -54,7 +56,43 @@ type info = { input_request : input_request; (** The current VM input request. *) } +type compute_step_kont = + | CS_Parsing of Tezos_webassembly_interpreter.Decode.decode_kont + | CS_Runtime of Tezos_webassembly_interpreter.Ast.module_' + | CS_Error + +let compute_step_kont_encoding = + let open Data_encoding in + union + [ + case + ~title:"boot_sequence" + (Tag 0) + (obj2 + (req "kind" @@ constant "boot_sequence") + (req "value" Kont_encodings.decode_kont)) + (function CS_Parsing kont -> Some ((), kont) | _ -> None) + (fun ((), kont) -> CS_Parsing kont); + case + ~title:"runtime" + (Tag 1) + (obj2 + (req "kind" (constant "runtime")) + (req "ast" Ast_encoding.module_encoding')) + (function CS_Runtime m -> Some ((), m) | _ -> None) + (fun ((), m) -> CS_Runtime m); + case + ~title:"error" + (Tag 2) + (obj1 (req "kind" @@ constant "error")) + (function CS_Error -> Some () | _ -> None) + (fun () -> CS_Error); + ] + module Make (T : TreeS) : sig + (** [boot ctxt boot_sector] initializes the PVM with a given [boot_sector]. *) + val boot : T.t -> string -> T.tree Lwt.t + (** [compute_step] forwards the VM by one compute tick. If the VM is expecting input, it gets stuck. @@ -86,7 +124,101 @@ end = struct include T end - let compute_step = Lwt.return + module Thunk = Thunk.Make (Tree) + + (* TODO: Should not be [string], but chunked data *) + type state = + string (* wasm-version *) + * (string (* boot sector *) * string (* next kernel *)) + * compute_step_kont (* label for [compute_step] *) + * int (* persistent state of [compute_step] *) + + let state_schema : state Thunk.schema = + let open Thunk.Schema in + obj4 + (req "wasm-version" @@ encoding Data_encoding.string) + (req "durable" @@ folders ["kernel"] + @@ obj2 + (req "boot.wasm" @@ encoding Data_encoding.string) + (req "next" @@ encoding Data_encoding.string)) + (req "label" @@ encoding compute_step_kont_encoding) + (req "counter" @@ encoding Data_encoding.int31) + + let version_l = Thunk.tup4_0 + + let boot_l = Thunk.(tup4_1 ^. tup2_0) + + let _next_boot_l = Thunk.(tup4_1 ^. tup2_1) + + let label_l = Thunk.tup4_2 + + let counter_l = Thunk.tup4_3 + + let boot : T.t -> string -> T.tree Lwt.t = + fun ctxt boot_sector -> + let aux = + let open Lwt_result.Syntax in + let open Thunk.Syntax in + let tree = T.empty ctxt in + let thunk = Thunk.decode state_schema tree in + let* () = (thunk ^-> version_l) ^:= "2.0.0" in + let* () = (thunk ^-> boot_l) ^:= boot_sector in + let* () = + (thunk ^-> label_l) + ^:= CS_Parsing (D_Start {name = "boot.wasm"; input = boot_sector}) + in + let*! tree = Thunk.encode tree thunk in + Lwt_result.return tree + in + let open Lwt.Syntax in + let* aux = aux in + match aux with Ok tree -> Lwt.return tree | Error _ -> assert false + + let incr_counter state_t = + let open Thunk.Syntax in + let*^? cpt = state_t ^-> counter_l in + (state_t ^-> counter_l) ^:= (Option.value ~default:0 cpt + 1) + + let step : + state Thunk.t -> compute_step_kont -> compute_step_kont Thunk.result Lwt.t + = + fun state_t -> + let open Lwt_result.Syntax in + function + | CS_Parsing (D_Result res) -> + let* () = incr_counter state_t in + Lwt_result.return (CS_Runtime res.it) + | CS_Parsing kont -> + let* () = incr_counter state_t in + let kont = + try CS_Parsing (Tezos_webassembly_interpreter.Decode.decode_step kont) + with _ -> CS_Error + in + Lwt_result.return kont + | CS_Runtime modules -> + let* () = incr_counter state_t in + Lwt_result.return (CS_Runtime modules) + | CS_Error -> + let* () = incr_counter state_t in + Lwt_result.return CS_Error + + let compute_step tree = + let aux state_t = + let open Lwt_result.Syntax in + let open Thunk.Syntax in + let*^ kont = state_t ^-> label_l in + let* kont' = step state_t kont in + (state_t ^-> label_l) ^:= kont' + in + + let open Lwt.Syntax in + let state_t = Thunk.decode state_schema tree in + let* x = aux state_t in + match x with + | Ok () -> Thunk.encode tree state_t + | Error _ -> + (* If our PVM implementation is correct, this never happens *) + assert false let set_input_step _ _ = Lwt.return (* TODO: https://gitlab.com/tezos/tezos/-/issues/3092 @@ -104,3 +236,7 @@ end = struct input_request = No_input_required; } end + +module Encoding = struct + module Kont = Kont_encodings +end diff --git a/src/lib_scoru_wasm/thunk.ml b/src/lib_scoru_wasm/thunk.ml new file mode 100644 index 0000000000000000000000000000000000000000..ee3d8bf46d2abd377b7d164925960985c65b6d17 --- /dev/null +++ b/src/lib_scoru_wasm/thunk.ml @@ -0,0 +1,544 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Copyright (c) 2022 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. *) +(* *) +(*****************************************************************************) + +module Lwt_syntax = struct + include Lwt.Syntax + + let return = Lwt.return +end + +module Lwt_result_syntax = struct + include Lwt_result.Syntax + + let ( let*! ) x k : ('a, 'b) result Lwt.t = Lwt.bind x k + + let return x = Lwt.return (Ok x) + + let fail x = Lwt.return (Error x) +end + +module Make (T : Sigs.TreeS) = struct + type nonrec 'a result = ('a, string) result + + type tree = T.tree + + type 'a decoder = tree -> 'a option result Lwt.t + + type 'a encoder = tree -> string list -> 'a -> tree Lwt.t + + module Schema = struct + type !'a t = {folders : string list; descr : 'a schema} + + and !'a schema = + | Leaf_s : 'a encoder * 'a decoder -> 'a schema + | Tup2_s : 'a field * 'b field -> ('a * 'b) schema + | Tup3_s : 'a field * 'b field * 'c field -> ('a * 'b * 'c) schema + | Tup4_s : + 'a field * 'b field * 'c field * 'd field + -> ('a * 'b * 'c * 'd) schema + | Map_s : ('a -> string) * 'b t -> ('a -> 'b) schema + + and !'a field = {directory : string; schema : 'a t} + + let encoding : 'a Data_encoding.t -> 'a t = + fun encoding -> + let encoder tree key value = + T.add tree key (Data_encoding.Binary.to_bytes_exn encoding value) + in + let decoder tree = + let open Lwt_result_syntax in + let*! bytes = T.find tree [] in + match bytes with + | Some bytes -> + Lwt_result.return + @@ Some (Data_encoding.Binary.of_bytes_exn encoding bytes) + | None -> Lwt_result.return None + in + {folders = []; descr = Leaf_s (encoder, decoder)} + + let lift encoder decoder = {folders = []; descr = Leaf_s (encoder, decoder)} + + let req directory schema = {directory; schema} + + let folders str {folders; descr} = {folders = folders @ List.rev str; descr} + + let obj2 b1 b2 = {folders = []; descr = Tup2_s (b1, b2)} + + let obj3 b1 b2 b3 = {folders = []; descr = Tup3_s (b1, b2, b3)} + + let obj4 b1 b2 b3 b4 = {folders = []; descr = Tup4_s (b1, b2, b3, b4)} + + let map encoder schema = {folders = []; descr = Map_s (encoder, schema)} + end + + type 'a schema = 'a Schema.t + + type !'a shallow = + | Shallow : tree option -> 'a shallow + | Tup2 : 'a t * 'b t -> ('a * 'b) shallow + | Tup3 : 'a t * 'b t * 'c t -> ('a * 'b * 'c) shallow + | Tup4 : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) shallow + | Leaf : 'a -> 'a shallow + | Map : tree option * ('a * 'b t) list -> ('a -> 'b) shallow + + and !'a t = {value : 'a shallow ref; schema : 'a schema} + + let shallow_t tree schema = {value = ref (Shallow tree); schema} + + type 'a thunk = 'a t + + let decode : 'a schema -> tree -> 'a thunk = + fun schema tree -> shallow_t (Some tree) schema + + let encode : type a. tree -> a thunk -> tree Lwt.t = + fun tree -> + let rec encode : type a. string list -> tree -> a thunk -> tree Lwt.t = + fun prefix tree thunk -> + let open Lwt_syntax in + let prefix = thunk.schema.folders @ prefix in + match (!(thunk.value), thunk.schema.descr) with + | Shallow (Some tree'), _ -> + let* tree = T.add_tree tree (List.rev prefix) tree' in + return tree + | Shallow None, _ -> + let* tree = T.remove tree (List.rev prefix) in + return tree + | Leaf x, Leaf_s (encoder, _) -> + let* tree = encoder tree (List.rev prefix) x in + return tree + | Map (Some tree', assoc), Map_s (key_encoder, _schema) -> + let* tree' = + Lwt_list.fold_left_s + (fun tree' (k, v) -> encode [key_encoder k] tree' v) + tree' + assoc + in + let* tree = T.add_tree tree (List.rev prefix) tree' in + return tree + | Map (None, assoc), Map_s (key_encoder, _schema) -> + let* tree = T.remove tree (List.rev prefix) in + let* tree = + Lwt_list.fold_left_s + (fun tree (k, v) -> encode (key_encoder k :: prefix) tree v) + tree + assoc + in + return tree + | Tup2 (x, y), Tup2_s (fst, snd) -> + let* tree = encode (fst.directory :: prefix) tree x in + let* tree = encode (snd.directory :: prefix) tree y in + return tree + | Tup3 (x, y, z), Tup3_s (fst, snd, thd) -> + let* tree = encode (fst.directory :: prefix) tree x in + let* tree = encode (snd.directory :: prefix) tree y in + let* tree = encode (thd.directory :: prefix) tree z in + return tree + | Tup4 (a, b, c, d), Tup4_s (a_s, b_s, c_s, d_s) -> + let* tree = encode (a_s.directory :: prefix) tree a in + let* tree = encode (b_s.directory :: prefix) tree b in + let* tree = encode (c_s.directory :: prefix) tree c in + let* tree = encode (d_s.directory :: prefix) tree d in + return tree + | _, _ -> raise (Invalid_argument "encode: thunk has an incorrect schema") + in + encode [] tree + + let find : type a. a t -> a option result Lwt.t = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Leaf x, _ -> return (Some x) + | Shallow (Some tree), Leaf_s (_, decoder) -> ( + let*! tree = T.find_tree tree (List.rev thunk.schema.folders) in + match tree with + | Some tree -> + let* x = decoder tree in + (thunk.value := + match x with Some x -> Leaf x | None -> Shallow None) ; + return x + | None -> return None) + | Shallow None, Leaf_s (_, _decoder) -> return None + | _ -> fail "not a leaf" + + let get thunk = + let open Lwt_result_syntax in + let* x = find thunk in + match x with Some x -> return x | None -> fail "missing leaf" + + let set : type a. a t -> a -> unit result Lwt.t = + fun thunk x -> + let open Lwt_result_syntax in + match !(thunk.value) with + | Leaf _ | Shallow _ -> + thunk.value := Leaf x ; + return () + | _ -> fail "not a leaf" + + let cut : type a. a t -> unit result Lwt.t = + fun thunk -> + let open Lwt_result_syntax in + thunk.value := Shallow None ; + return () + + type ('a, 'b) lens = 'a thunk -> 'b thunk result Lwt.t + + let ( ^. ) : ('a, 'b) lens -> ('b, 'c) lens -> ('a, 'c) lens = + fun l1 l2 thunk -> + let open Lwt_result_syntax in + let* thunk = l1 thunk in + l2 thunk + + let tup2_0 : type a b. (a * b, a) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup2 (x, _y), _ -> return x + | Shallow (Some tree), Tup2_s (x, y) -> + let*! tree_x = T.find_tree tree (x.directory :: thunk.schema.folders) in + let*! tree_y = T.find_tree tree (y.directory :: thunk.schema.folders) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + thunk.value := Tup2 (x, y) ; + return @@ x + | Shallow None, Tup2_s (x, y) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + thunk.value := Tup2 (x, y) ; + return @@ x + | _ -> fail "not a tup2" + + let tup2_1 : type a b. (a * b, b) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup2 (_x, y), _ -> return y + | Shallow (Some tree), Tup2_s (x, y) -> + let*! tree_x = T.find_tree tree (x.directory :: thunk.schema.folders) in + let*! tree_y = T.find_tree tree (y.directory :: thunk.schema.folders) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + thunk.value := Tup2 (x, y) ; + return y + | Shallow None, Tup2_s (x, y) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + thunk.value := Tup2 (x, y) ; + return y + | _ -> fail "not a tup2" + + let tup3_0 : type a b c. (a * b * c, a) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup3 (x, _y, _z), _ -> return x + | Shallow (Some tree), Tup3_s (x, y, z) -> + let*! tree_x = T.find_tree tree (x.directory :: thunk.schema.folders) in + let*! tree_y = T.find_tree tree (y.directory :: thunk.schema.folders) in + let*! tree_z = T.find_tree tree (z.directory :: thunk.schema.folders) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + let z = shallow_t tree_z z.schema in + thunk.value := Tup3 (x, y, z) ; + return x + | Shallow None, Tup3_s (x, y, z) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + let z = shallow_t None z.schema in + thunk.value := Tup3 (x, y, z) ; + return x + | _ -> fail "not a tup3" + + let tup3_1 : type a b c. (a * b * c, b) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup3 (_x, y, _z), _ -> return y + | Shallow (Some tree), Tup3_s (x, y, z) -> + let*! tree_x = T.find_tree tree (x.directory :: thunk.schema.folders) in + let*! tree_y = T.find_tree tree (y.directory :: thunk.schema.folders) in + let*! tree_z = T.find_tree tree (z.directory :: thunk.schema.folders) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + let z = shallow_t tree_z z.schema in + thunk.value := Tup3 (x, y, z) ; + return y + | Shallow None, Tup3_s (x, y, z) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + let z = shallow_t None z.schema in + thunk.value := Tup3 (x, y, z) ; + return y + | _ -> fail "not a tup3" + + let tup3_2 : type a b c. (a * b * c, c) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup3 (_x, _y, z), _ -> return z + | Shallow (Some tree), Tup3_s (x, y, z) -> + let*! tree_x = T.find_tree tree (x.directory :: thunk.schema.folders) in + let*! tree_y = T.find_tree tree (y.directory :: thunk.schema.folders) in + let*! tree_z = T.find_tree tree (z.directory :: thunk.schema.folders) in + let x = shallow_t tree_x x.schema in + let y = shallow_t tree_y y.schema in + let z = shallow_t tree_z z.schema in + thunk.value := Tup3 (x, y, z) ; + return z + | Shallow None, Tup3_s (x, y, z) -> + let x = shallow_t None x.schema in + let y = shallow_t None y.schema in + let z = shallow_t None z.schema in + thunk.value := Tup3 (x, y, z) ; + return z + | _ -> fail "not a tup3" + + let tup4_0 : type a b c d. (a * b * c * d, a) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (a, _b, _c, _d), _ -> return a + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let*! tree_a = + T.find_tree tree (a_f.directory :: thunk.schema.folders) + in + let*! tree_b = + T.find_tree tree (b_f.directory :: thunk.schema.folders) + in + let*! tree_c = + T.find_tree tree (c_f.directory :: thunk.schema.folders) + in + let*! tree_d = + T.find_tree tree (d_f.directory :: thunk.schema.folders) + in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return a + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return a + | _ -> fail "not a tup4" + + let tup4_1 : type a b c d. (a * b * c * d, b) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (_a, b, _c, _d), _ -> return b + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let*! tree_a = + T.find_tree tree (a_f.directory :: thunk.schema.folders) + in + let*! tree_b = + T.find_tree tree (b_f.directory :: thunk.schema.folders) + in + let*! tree_c = + T.find_tree tree (c_f.directory :: thunk.schema.folders) + in + let*! tree_d = + T.find_tree tree (d_f.directory :: thunk.schema.folders) + in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return b + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return b + | _ -> fail "not a tup4" + + let tup4_2 : type a b c d. (a * b * c * d, c) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (_a, _b, c, _d), _ -> return c + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let*! tree_a = + T.find_tree tree (a_f.directory :: thunk.schema.folders) + in + let*! tree_b = + T.find_tree tree (b_f.directory :: thunk.schema.folders) + in + let*! tree_c = + T.find_tree tree (c_f.directory :: thunk.schema.folders) + in + let*! tree_d = + T.find_tree tree (d_f.directory :: thunk.schema.folders) + in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return c + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return c + | _ -> fail "not a tup4" + + let tup4_3 : type a b c d. (a * b * c * d, d) lens = + fun thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Tup4 (_a, _b, _c, d), _ -> return d + | Shallow (Some tree), Tup4_s (a_f, b_f, c_f, d_f) -> + let*! tree_a = + T.find_tree tree (a_f.directory :: thunk.schema.folders) + in + let*! tree_b = + T.find_tree tree (b_f.directory :: thunk.schema.folders) + in + let*! tree_c = + T.find_tree tree (c_f.directory :: thunk.schema.folders) + in + let*! tree_d = + T.find_tree tree (d_f.directory :: thunk.schema.folders) + in + let a = shallow_t tree_a a_f.schema in + let b = shallow_t tree_b b_f.schema in + let c = shallow_t tree_c c_f.schema in + let d = shallow_t tree_d d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return d + | Shallow None, Tup4_s (a_f, b_f, c_f, d_f) -> + let a = shallow_t None a_f.schema in + let b = shallow_t None b_f.schema in + let c = shallow_t None c_f.schema in + let d = shallow_t None d_f.schema in + thunk.value := Tup4 (a, b, c, d) ; + return d + | _ -> fail "not a tup4" + + let entry : type a b. a -> (a -> b, b) lens = + fun k thunk -> + let open Lwt_result_syntax in + match (!(thunk.value), thunk.schema.descr) with + | Map (Some tree, assoc), Map_s (encoder, schema) -> ( + match List.assq_opt k assoc with + | Some v -> return v + | None -> + let entry = encoder k in + let*! tree' = T.find_tree tree (entry :: thunk.schema.folders) in + let v = shallow_t tree' schema in + thunk.value := Map (Some tree, (k, v) :: assoc) ; + return v) + | Shallow (Some tree), Map_s (encoder, schema) -> + let entry = encoder k in + let*! tree' = T.find_tree tree (entry :: thunk.schema.folders) in + let v = shallow_t tree' schema in + thunk.value := Map (Some tree, [(k, v)]) ; + return v + | (Map (None, []) | Shallow None), Map_s (_encoder, schema) -> + let v = shallow_t None schema in + thunk.value := Map (None, [(k, v)]) ; + return v + | Map (None, assoc), Map_s (_encoder, schema) -> ( + match List.assq_opt k assoc with + | Some v -> return v + | None -> + let v = shallow_t None schema in + thunk.value := Map (None, (k, v) :: assoc) ; + return v) + | _ -> fail "not a directory" + + module Lazy_list = struct + type 'a t = int32 * (int32 -> 'a) + + let schema : 'a schema -> 'a t schema = + fun schema -> + let open Schema in + obj2 + (req "len" @@ encoding Data_encoding.int32) + (req "contents" (map Int32.to_string schema)) + + let length : 'a t thunk -> int32 result Lwt.t = + fun thunk -> + let open Lwt_result_syntax in + let* len = tup2_0 thunk in + let* len = find len in + return @@ Option.value ~default:0l len + + let nth ~check idx : ('a t, 'a) lens = + fun thunk -> + let open Lwt_result_syntax in + let* c = length thunk in + if (not check) || idx < c then + (tup2_1 ^. entry Int32.(pred @@ sub c idx)) thunk + else fail "index out of bound" + + let alloc_cons : 'a t thunk -> (int32 * 'a thunk) result Lwt.t = + fun thunk -> + let open Lwt_result_syntax in + let* c = length thunk in + let* len = tup2_0 thunk in + let* () = set len (Int32.succ c) in + let* cons = (tup2_1 ^. entry c) thunk in + return (c, cons) + + let cons : 'a t thunk -> 'a -> int32 result Lwt.t = + fun thunk x -> + let open Lwt_result_syntax in + let* idx, cell = alloc_cons thunk in + let* () = set cell x in + return idx + end + + module Syntax = struct + let ( ^-> ) x f = f x + + let ( let*^? ) x k = + let open Lwt_result_syntax in + let* x = x in + let* x = find x in + k x + + let ( let*^ ) x k = + let open Lwt_result_syntax in + let* x = x in + let* x = get x in + k x + + let ( ^:= ) x v = + let open Lwt_result_syntax in + let* x = x in + set x v + end +end diff --git a/src/lib_scoru_wasm/thunk.mli b/src/lib_scoru_wasm/thunk.mli new file mode 100644 index 0000000000000000000000000000000000000000..d8df2b3668566d917bf0ed0c67d037be3a7bee1d --- /dev/null +++ b/src/lib_scoru_wasm/thunk.mli @@ -0,0 +1,126 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Copyright (c) 2022 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. *) +(* *) +(*****************************************************************************) + +module Make (T : Sigs.TreeS) : sig + type nonrec 'a result = ('a, string) result + + type tree = T.tree + + type 'a decoder = tree -> 'a option result Lwt.t + + type 'a encoder = tree -> string list -> 'a -> tree Lwt.t + + module Schema : sig + type !'a t + + val encoding : 'a Data_encoding.t -> 'a t + + val lift : 'a encoder -> 'a decoder -> 'a t + + type !'a field + + val folders : string list -> 'a t -> 'a t + + val req : string -> 'a t -> 'a field + + val obj2 : 'a field -> 'b field -> ('a * 'b) t + + val obj3 : 'a field -> 'b field -> 'c field -> ('a * 'b * 'c) t + + val obj4 : + 'a field -> 'b field -> 'c field -> 'd field -> ('a * 'b * 'c * 'd) t + + val map : ('a -> string) -> 'b t -> ('a -> 'b) t + end + + type 'a schema = 'a Schema.t + + type !'a t + + type 'a thunk = 'a t + + val decode : 'a schema -> tree -> 'a thunk + + val encode : tree -> 'a thunk -> tree Lwt.t + + val find : 'a thunk -> 'a option result Lwt.t + + val get : 'a thunk -> 'a result Lwt.t + + val set : 'a thunk -> 'a -> unit result Lwt.t + + val cut : 'a thunk -> unit result Lwt.t + + type ('a, 'b) lens = 'a thunk -> 'b thunk result Lwt.t + + val ( ^. ) : ('a, 'b) lens -> ('b, 'c) lens -> ('a, 'c) lens + + val tup2_0 : ('a * 'b, 'a) lens + + val tup2_1 : ('a * 'b, 'b) lens + + val tup3_0 : ('a * 'b * 'c, 'a) lens + + val tup3_1 : ('a * 'b * 'c, 'b) lens + + val tup3_2 : ('a * 'b * 'c, 'c) lens + + val tup4_0 : ('a * 'b * 'c * 'd, 'a) lens + + val tup4_1 : ('a * 'b * 'c * 'd, 'b) lens + + val tup4_2 : ('a * 'b * 'c * 'd, 'c) lens + + val tup4_3 : ('a * 'b * 'c * 'd, 'd) lens + + val entry : 'a -> ('a -> 'b, 'b) lens + + module Lazy_list : sig + type !'a t + + val schema : 'a schema -> 'a t schema + + val length : 'a t thunk -> int32 result Lwt.t + + val nth : check:bool -> int32 -> ('a t, 'a) lens + + val alloc_cons : 'a t thunk -> (int32 * 'a thunk) result Lwt.t + + val cons : 'a t thunk -> 'a -> int32 result Lwt.t + end + + module Syntax : sig + val ( ^-> ) : 'a thunk -> ('a, 'b) lens -> 'b thunk result Lwt.t + + val ( let*^ ) : + 'a thunk result Lwt.t -> ('a -> 'b result Lwt.t) -> 'b result Lwt.t + + val ( let*^? ) : + 'a thunk result Lwt.t -> ('a option -> 'b result Lwt.t) -> 'b result Lwt.t + + val ( ^:= ) : 'a thunk result Lwt.t -> 'a -> unit result Lwt.t + end +end diff --git a/src/lib_scoru_wasm/types_encoding.ml b/src/lib_scoru_wasm/types_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..8c1d8d41fc7d9aadb03c56c65472bcf362be834d --- /dev/null +++ b/src/lib_scoru_wasm/types_encoding.ml @@ -0,0 +1,150 @@ +(*****************************************************************************) +(* *) +(* 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) (constant "V128Type")) + +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); + ] + +let num_type_encoding : num_type Data_encoding.t = + Data_encoding.string_enum + [ + ("I32Type", I32Type); + ("I64Type", I64Type); + ("F32Type", F32Type); + ("F64Type", F64Type); + ] + +let ref_type_encoding : ref_type Data_encoding.t = + Data_encoding.string_enum + [("FuncRefType", FuncRefType); ("ExternRefType", ExternRefType)] + +let value_type_encoding : value_type Data_encoding.t = + Data_encoding.( + union + [ + case + (Tag 0) + ~title:"NumType" + num_type_encoding + (function NumType x -> Some x | _ -> None) + (fun x -> NumType x); + case + (Tag 1) + ~title:"VecType" + vec_type_encoding + (function VecType x -> Some x | _ -> None) + (fun x -> VecType x); + case + (Tag 2) + ~title:"RefType" + ref_type_encoding + (function RefType x -> Some x | _ -> None) + (fun x -> RefType x); + ]) + +let mutability_encoding : mutability Data_encoding.t = + Data_encoding.string_enum [("immutable", Immutable); ("mutable", Mutable)] + +let global_type_encoding = + Data_encoding.( + conv + (function GlobalType (v, m) -> (v, m)) + (fun (v, m) -> GlobalType (v, m)) + (obj2 + (req "value_type" value_type_encoding) + (req "mutability" mutability_encoding))) + +let limits_encoding value_encoding : _ limits Data_encoding.t = + Data_encoding.( + conv + (fun {min; max} -> (min, max)) + (fun (min, max) -> {min; max}) + (obj2 (req "min" value_encoding) (req "max" @@ option value_encoding))) + +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)) + +let result_type_encoding = Data_encoding.(list value_type_encoding) + +let func_type_encoding : func_type Data_encoding.t = + Data_encoding.( + conv + (function FuncType (x, y) -> (x, y)) + (fun (x, y) -> FuncType (x, y)) + (tup2 result_type_encoding result_type_encoding)) 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..30e44f9eb8833c953c29ed17371e01b6ea86ad92 100644 --- a/src/lib_webassembly/interpreter/binary/decode.ml +++ b/src/lib_webassembly/interpreter/binary/decode.ml @@ -1517,7 +1517,6 @@ type module_kont = { building_state : field list; (** Accumulated parsed sections. *) kont : module_kont' } - let rec find_vec : type t. t field_type -> _ -> t list * int = fun ty fields -> match fields with @@ -1865,6 +1864,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 diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index bf20e218d3423ed389a76834386479f259a2e098..3e5a2f9150965f8bf8a5448142db90bdfc434efc 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -177,14 +177,7 @@ module V2_0_0 = struct open Monad - let initial_state ctxt boot_sector = - let open Lwt_syntax in - let state = Tree.empty ctxt in - let* state = Tree.add state ["wasm-version"] (Bytes.of_string "2.0.0") in - let* state = - Tree.add state ["boot-sector"] (Bytes.of_string boot_sector) - in - Lwt.return state + let initial_state ctxt boot_sector = WASM_machine.boot ctxt boot_sector let state_hash state = let m = diff --git a/src/proto_alpha/lib_protocol/test/integration/block.wasm b/src/proto_alpha/lib_protocol/test/integration/block.wasm new file mode 100644 index 0000000000000000000000000000000000000000..1dbd2eba49de600234024ab4724f2f9ac66dd81b Binary files /dev/null and b/src/proto_alpha/lib_protocol/test/integration/block.wasm differ diff --git a/src/proto_alpha/lib_protocol/test/integration/dune b/src/proto_alpha/lib_protocol/test/integration/dune index 3136d7705e9bf52dcbb28157607cc9bf6e6e2e55..b5a1669206993ad316046f609337a966baf37635 100644 --- a/src/proto_alpha/lib_protocol/test/integration/dune +++ b/src/proto_alpha/lib_protocol/test/integration/dune @@ -25,4 +25,5 @@ (rule (alias runtest) (package tezos-protocol-alpha-tests) + (deps block.wasm) (action (run %{dep:./main.exe}))) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml index 0a31ad4390d62d620a6884e2c9725e77a5eaf8fa..c2ae7bfe3e6714e94890e43f0b7e493a888a8b8b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml @@ -27,9 +27,9 @@ (** Testing ------- Component: sc rollup wasm - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/main.exe \ - -- test "^sc rollup wasm$" + Invocation: cd src/proto_alpha/lib_protocol/test/integration/ ; \ + dune exec -- ./main.exe \ + test "^sc rollup wasm$" Subject: Test the WASM 2.0 PVM. *) @@ -109,12 +109,62 @@ module Verifier = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.ProtocolImplementation module Prover = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.Make (WASM_P) +let eval_and_check ~expected s = + let open Lwt_syntax in + let* s = Prover.eval s in + let* x = Context_binary.Tree.find s ["counter"] in + let* label = Context_binary.Tree.find s ["label"] in + let label = WithExceptions.Option.get ~loc:__LOC__ label in + (match x with + | Some x -> + let x = Data_encoding.(Binary.of_bytes_exn int31 x) in + Format.(printf "counter = %d@ " x) ; + let label = + Data_encoding.Binary.of_bytes_exn + Tezos_scoru_wasm.compute_step_kont_encoding + label + in + Format.( + printf + "%a@ " + (fun fmt label -> + fprintf + fmt + "%s" + Data_encoding.Json.( + to_string ~newline:true + @@ construct Tezos_scoru_wasm.compute_step_kont_encoding label)) + label) ; + assert (x = expected) + | _ -> assert false) ; + return s + +let check_boot_sector s boot_sector = + let open Lwt_result_syntax in + let*! candidate = + Context_binary.Tree.find s ["durable"; "kernel"; "boot.wasm"] + in + (match candidate with + | Some candidate -> + assert (boot_sector = Data_encoding.(Binary.of_bytes_exn string candidate)) + | None -> assert false) ; + return_unit + let should_boot () = let open Lwt_result_syntax in let*! index = Context_binary.init "/tmp" in let context = Context_binary.empty index in - let*! s = Prover.initial_state context "" in - let*! s = Prover.eval s in + let bs = Contract_helpers.read_file "block.wasm" in + let*! s = Prover.initial_state context bs in + let* () = check_boot_sector s bs in + let*! s = eval_and_check ~expected:1 s in + let*! s = eval_and_check ~expected:2 s in + let*! s = eval_and_check ~expected:3 s in + let*! s = eval_and_check ~expected:4 s in + let*! s = eval_and_check ~expected:5 s in + let*! s = eval_and_check ~expected:6 s in + let*! s = eval_and_check ~expected:7 s in + let*! s = eval_and_check ~expected:8 s in let*! p_res = Prover.produce_proof context None s in match p_res with | Ok proof ->