From 35d9f443513f15221c9da9e736368e89d363cc52 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Fri, 3 Jun 2022 16:09:34 +0200 Subject: [PATCH 1/4] WASM: export and improve decoder interface --- src/lib_webassembly/bin/script/js.ml | 2 +- src/lib_webassembly/bin/script/run.ml | 4 +- src/lib_webassembly/bin/text/arrange.ml | 4 +- src/lib_webassembly/binary/decode.ml | 45 ++--- src/lib_webassembly/binary/decode.mli | 228 +++++++++++++++++++++++- 5 files changed, 253 insertions(+), 30 deletions(-) diff --git a/src/lib_webassembly/bin/script/js.ml b/src/lib_webassembly/bin/script/js.ml index c85d1c081e10..fd1c13079bf0 100644 --- a/src/lib_webassembly/bin/script/js.ml +++ b/src/lib_webassembly/bin/script/js.ml @@ -660,7 +660,7 @@ let of_command mods cmd = let rec unquote def = match def.it with | Textual m -> m - | Encoded (_, bs) -> Decode.decode "binary" bs + | Encoded (_, bytes) -> Decode.decode ~name:"binary" ~bytes | Quoted (_, s) -> unquote (Parse.string_to_module s) in bind mods x_opt (unquote def) ; diff --git a/src/lib_webassembly/bin/script/run.ml b/src/lib_webassembly/bin/script/run.ml index 3bc90675c225..37a8ff7aee36 100644 --- a/src/lib_webassembly/bin/script/run.ml +++ b/src/lib_webassembly/bin/script/run.ml @@ -350,9 +350,9 @@ let lookup_registry module_name item_name _t = let rec run_definition def : Ast.module_ Lwt.t = match def.it with | Textual m -> Lwt.return m - | Encoded (name, bs) -> + | Encoded (name, bytes) -> let+ () = trace_lwt "Decoding..." in - Decode.decode name bs + Decode.decode ~name ~bytes | Quoted (_, s) -> let* () = trace_lwt "Parsing quote..." in let def' = Parse.string_to_module s in diff --git a/src/lib_webassembly/bin/text/arrange.ml b/src/lib_webassembly/bin/text/arrange.ml index b8046a471502..04c21196d52a 100644 --- a/src/lib_webassembly/bin/text/arrange.ml +++ b/src/lib_webassembly/bin/text/arrange.ml @@ -686,7 +686,7 @@ let definition mode x_opt def = let rec unquote def = match def.it with | Textual m -> m - | Encoded (_, bs) -> Decode.decode "" bs + | Encoded (_, bytes) -> Decode.decode ~name:"" ~bytes | Quoted (_, s) -> unquote (Parse.string_to_module s) in module_with_var_opt x_opt (unquote def) @@ -694,7 +694,7 @@ let definition mode x_opt def = let rec unquote def = match def.it with | Textual m -> Encode.encode m - | Encoded (_, bs) -> Encode.encode (Decode.decode "" bs) + | Encoded (_, bytes) -> Encode.encode (Decode.decode ~name:"" ~bytes) | Quoted (_, s) -> unquote (Parse.string_to_module s) in binary_module_with_var_opt x_opt (unquote def) diff --git a/src/lib_webassembly/binary/decode.ml b/src/lib_webassembly/binary/decode.ml index fb20016e1221..179e003f41c8 100644 --- a/src/lib_webassembly/binary/decode.ml +++ b/src/lib_webassembly/binary/decode.ml @@ -4,7 +4,7 @@ open Binary_exn type stream = {name : string; bytes : string; pos : int ref} -let stream name bs = {name; bytes = bs; pos = ref 0} +let make_stream ~name ~bytes = {name; bytes; pos = ref 0} let len s = String.length s.bytes @@ -1512,17 +1512,15 @@ type field = | SingleField : 'a field_type * 'a option -> field (** Module parsing steps *) -type module_kont' = +type module_kont = | MKStart (** Initial state of a module parsing *) - | MKSkipCustom : ('a field_type * section_tag) option -> module_kont' + | 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' + | 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' + | 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' + | 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. *) @@ -1555,9 +1553,10 @@ type module_kont' = continuation, the starting position of the current function, the size of the section. *) -type module_kont = { +type decode_kont = { building_state : field list; (** Accumulated parsed sections. *) - kont : module_kont'; + module_kont : module_kont; + stream : stream; } let rec find_vec : type t. t field_type -> _ -> t list * int = @@ -1604,12 +1603,13 @@ let rec find_single : type t. t field_type -> _ -> t option = | DataField, DataField -> v | _ -> find_single ty rest) -let module_step s state = - let next kont = {state with kont} in - let next_with_field field kont = - {building_state = field :: state.building_state; kont} +let module_step state = + let next module_kont = {state with module_kont} in + let next_with_field field module_kont = + {state with building_state = field :: state.building_state; module_kont} in - match state.kont with + let s = state.stream in + match state.module_kont with | MKStart -> (* Module header *) let header = u32 s in @@ -1869,8 +1869,9 @@ let module_step s state = (len s) "data count section required" ; { + state with building_state = []; - kont = + module_kont = MKStop { types; @@ -1893,14 +1894,14 @@ let module_step s state = assert false | MKStop _ (* Stop cannot reduce. *) -> assert false -let module_ s = +let module_ stream = let rec loop = function - | {kont = MKStop m; _} -> m - | k -> loop (module_step s k) + | {module_kont = MKStop m; _} -> m + | k -> loop (module_step k) in - loop {building_state = []; kont = MKStart} + loop {building_state = []; module_kont = MKStart; stream} -let decode name bs = at module_ (stream name bs) +let decode ~name ~bytes = at module_ (make_stream ~name ~bytes) let all_custom tag s = let header = u32 s in @@ -1916,4 +1917,4 @@ let all_custom tag s = in collect () -let decode_custom tag name bs = all_custom tag (stream name bs) +let decode_custom tag ~name ~bytes = all_custom tag (make_stream ~name ~bytes) diff --git a/src/lib_webassembly/binary/decode.mli b/src/lib_webassembly/binary/decode.mli index c575c4022646..c8094c989dbb 100644 --- a/src/lib_webassembly/binary/decode.mli +++ b/src/lib_webassembly/binary/decode.mli @@ -1,6 +1,228 @@ exception Code of Source.region * string -val decode : string -> string -> Ast.module_ (* raises Code *) +(** Instruction parsing continuations. *) +type instr_block_kont = + | IKStop of Ast.instr list (** Final step of a block parsing. *) + | IKRev of Ast.instr list * Ast.instr list + (** Reversal of lists of instructions. *) + | IKNext of Ast.instr list + (** Tag parsing, containing the accumulation of already parsed values. *) + | IKBlock of Ast.block_type * int (** Block parsing step. *) + | IKLoop of Ast.block_type * int (** Loop parsing step. *) + | IKIf1 of Ast.block_type * int (** If parsing step. *) + | IKIf2 of Ast.block_type * int * Ast.instr list + (** If .. else parsing step. *) -val decode_custom : - Ast.name -> string -> string -> string list (* raises Code *) +(** Vector and size continuations *) + +(** Vector accumulator, used in two step: 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 + +(** Vector accumulator without mapping. *) +type 'a vec_kont = ('a, 'a) vec_map_kont + +type pos = private int + +(** Size checking version of {!sized} for CPS-style parsing. *) +type size = {size : int; start : pos} + +(** Incremental chunked byte vector creation (from implicit input). *) +type byte_vector_kont = + | VKStart (** Initial step. *) + | VKRead of Chunked_byte_vector.Buffer.t * pos * 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. *) + +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 Ast.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 Ast.export' (** Export final step. *) + +(** Code section parsing. *) +type code_kont = + | CKStart (** Starting point of a function parsing. *) + | CKLocals of { + left : pos; + size : size; + pos : pos; + vec_kont : (int32 * Types.value_type, Types.value_type) vec_map_kont; + locals_size : Int64.t; + } (** Parsing step of local values of a function. *) + | CKBody of { + left : pos; + size : size; + locals : Types.value_type list; + const_kont : instr_block_kont list; + } (** Parsing step of the body of a function. *) + | CKStop of Ast.func (** Final step of a parsed function, irreducible. *) + +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 : Types.ref_type option; + offset_kont : pos * instr_block_kont list; + } (** Element segment mode parsing step. *) + | EKInitIndexed of { + mode : Ast.segment_mode; + ref_type : Types.ref_type; + einit_vec : Ast.const vec_kont; + } + (** Element segment initialization code parsing step for referenced values. *) + | EKInitConst of { + mode : Ast.segment_mode; + ref_type : Types.ref_type; + einit_vec : Ast.const vec_kont; + einit_kont : pos * instr_block_kont list; + } + (** Element segment initialization code parsing step for constant values. *) + | EKStop of Ast.elem_segment' (** Final step of a segment parsing. *) + +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 : Ast.segment_mode; init_kont : byte_vector_kont} + | DKStop of Ast.data_segment' (** Final step of a data segment parsing. *) + +(** Representation of a section tag. *) +type section_tag = + [ `CodeSection + | `CustomSection + | `DataCountSection + | `DataSection + | `ElemSection + | `ExportSection + | `FuncSection + | `GlobalSection + | `ImportSection + | `MemorySection + | `StartSection + | `TableSection + | `TypeSection ] + +(** Sections representation. *) +type _ field_type = + | TypeField : Ast.type_ field_type + | ImportField : Ast.import field_type + | FuncField : Ast.var field_type + | TableField : Ast.table field_type + | MemoryField : Ast.memory field_type + | GlobalField : Ast.global field_type + | ExportField : Ast.export field_type + | StartField : Ast.start field_type + | ElemField : Ast.elem_segment field_type + | DataCountField : int32 field_type + | CodeField : Ast.func field_type + | DataField : Ast.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 + +(** 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 : + Ast.var list * Ast.func list * Ast.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 Ast.func list option * bool + (** Accumulating the parsed sections vectors into a module and checking + invariants. *) + | MKStop of Ast.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 * Ast.import vec_kont + (** Import section parsing. *) + | MKExport of export_kont * pos * size * Ast.export vec_kont + (** Export section parsing. *) + | MKGlobal of + Types.global_type + * int + * instr_block_kont list + * size + * Ast.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 * Ast.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 * Ast.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 * Ast.func vec_kont + (** Code section parsing, containing the current function parsing + continuation, the starting position of the current function, the size of + the section. *) + +(** Parsed bytes with the current reading position. *) +type stream = {name : string; bytes : string; pos : pos ref} + +(** Decoding continuation step. *) +type decode_kont = { + building_state : field list; + (** Accumulated parsed sections, used to build the final module. *) + module_kont : module_kont; (** Module continuation. *) + stream : stream; (** Parsed stream. *) +} + +(** [make_stream filename bytes] returns a new stream to decode. *) +val make_stream : name:string -> bytes:string -> stream + +(** [module_step kont] takes one step of parsing from a continuation and returns + a new continuation. Fails when the contination of the module is [MKStop] + since it cannot reduce. *) +val module_step : decode_kont -> decode_kont + +(** [decode ~name ~bytes] decodes a module [name] from its [bytes] encoding. + + @raise Code on parsing errors. *) +val decode : name:string -> bytes:string -> Ast.module_ + +(** [decode ~name ~bytes] decodes a custom section of name [name] from its + [bytes] encoding. + + @raise Code on parsing errors. *) +val decode_custom : Ast.name -> name:string -> bytes:string -> string list -- GitLab From 78a5e138d2945a241732bd570d9439caa9b06f5d Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 23 Jun 2022 11:16:38 +0200 Subject: [PATCH 2/4] Lib_wasm: add `loaded_bindings` function for lazy maps and vectors Also update the documentation of `cons` to reflect it grows the size of the vector, and fix an issue with `to_list` on empty vectors. --- src/lib_webassembly/util/lazy_map.ml | 4 ++++ src/lib_webassembly/util/lazy_map.mli | 5 +++++ src/lib_webassembly/util/lazy_vector.ml | 10 +++++++++- src/lib_webassembly/util/lazy_vector.mli | 9 +++++++-- 4 files changed, 25 insertions(+), 3 deletions(-) diff --git a/src/lib_webassembly/util/lazy_map.ml b/src/lib_webassembly/util/lazy_map.ml index 2cc3c58a9cb4..d24942d2e05a 100644 --- a/src/lib_webassembly/util/lazy_map.ml +++ b/src/lib_webassembly/util/lazy_map.ml @@ -59,6 +59,8 @@ module type S = sig 'a t val with_producer : ('a producer -> 'a producer) -> 'a t -> 'a t + + val loaded_bindings : 'a t -> (key * 'a) list end exception UnexpectedAccess @@ -127,6 +129,8 @@ module Make (Effect : Effect.S) (Key : KeyS) : let with_producer morph map = {map with produce_value = morph map.produce_value} + + let loaded_bindings m = Map.bindings m.values end module IntMap = Make (Effect.Identity) (Int) diff --git a/src/lib_webassembly/util/lazy_map.mli b/src/lib_webassembly/util/lazy_map.mli index e23897f2fdb3..262d16ebd7a5 100644 --- a/src/lib_webassembly/util/lazy_map.mli +++ b/src/lib_webassembly/util/lazy_map.mli @@ -84,6 +84,11 @@ module type S = sig (** [with_producer morph] lifts a morphism for a [producer] to one on [t]. *) val with_producer : ('a producer -> 'a producer) -> 'a t -> 'a t + + (** [loaded_bindings map] returns the [(key * 'a) list] representation of the + map [map] containing only the loaded values, in order of increasing keys. + This function is a witness of internal mutations. *) + val loaded_bindings : 'a t -> (key * 'a) list end (** [UnexpectedAccess] is raised in the default of the [produce_value] argument diff --git a/src/lib_webassembly/util/lazy_vector.ml b/src/lib_webassembly/util/lazy_vector.ml index bb13bb1a3baa..61b1adb41a9e 100644 --- a/src/lib_webassembly/util/lazy_vector.ml +++ b/src/lib_webassembly/util/lazy_vector.ml @@ -68,6 +68,8 @@ module type S = sig val concat : 'a t -> 'a t -> 'a t val to_list : 'a t -> 'a list effect + + val loaded_bindings : 'a t -> (key * 'a) list end module ZZ : KeyS with type t = Z.t = struct @@ -190,7 +192,13 @@ module Make (Effect : Effect.S) (Key : KeyS) : let* prefix = get Key.zero map in return (prefix :: acc) in - (unroll [@ocaml.tailcall]) [] (Key.pred map.num_elements) + (* The empty vector is not correctly taken into account otherwise, since + `pred zero` = `-1`, which is an invalid key according to + {!invalid_key}. *) + if map.num_elements = Key.zero then return [] + else (unroll [@ocaml.tailcall]) [] (Key.pred map.num_elements) + + let loaded_bindings m = Map.loaded_bindings m.values end module Int = struct diff --git a/src/lib_webassembly/util/lazy_vector.mli b/src/lib_webassembly/util/lazy_vector.mli index c3d49e811946..34610564b1a5 100644 --- a/src/lib_webassembly/util/lazy_vector.mli +++ b/src/lib_webassembly/util/lazy_vector.mli @@ -86,8 +86,8 @@ module type S = sig @raises Memory_exn.Bounds when trying to set an invalid key *) val set : key -> 'a -> 'a t -> 'a t - (** [cons value vector] prepends a value to the front. That value can then be - accessed using the [zero] key. + (** [cons value vector] prepends a value to the front and grows the vector by + one. That value can then be accessed using the [zero] key. Time complexity: O(log(instantiated_elements_in_vector)) *) val cons : 'a -> 'a t -> 'a t @@ -104,6 +104,11 @@ module type S = sig (** [to_list vector] extracts all values of the given [vector] and collects them in a list. *) val to_list : 'a t -> 'a list effect + + (** [loaded_bindings vector] returns the [(key * 'a) list] representation of + the vector [vector] containing only the loaded values, in order of + increasing keys. This function is a witness of internal mutations. *) + val loaded_bindings : 'a t -> (key * 'a) list end module Make (Effect : Effect.S) (Key : KeyS) : -- GitLab From bad92394edae3b08315562095f2f93f6c556d647 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 23 Jun 2022 11:18:02 +0200 Subject: [PATCH 3/4] WASM/AST: change top level list to lwt_lazy_vector Only transformed into lazy_vector at the last step of parsing for now --- src/lib_webassembly/bin/script/js.ml | 127 ++++++++++++++-------- src/lib_webassembly/bin/script/js.mli | 2 +- src/lib_webassembly/bin/script/run.ml | 44 +++++--- src/lib_webassembly/bin/text/arrange.ml | 128 ++++++++++++++--------- src/lib_webassembly/bin/text/arrange.mli | 2 +- src/lib_webassembly/bin/text/parser.mly | 110 ++++++++++++++----- src/lib_webassembly/bin/text/print.ml | 3 +- src/lib_webassembly/binary/decode.ml | 20 ++-- src/lib_webassembly/binary/encode.ml | 33 +++--- src/lib_webassembly/binary/encode.mli | 2 +- src/lib_webassembly/exec/eval.ml | 44 ++++++-- src/lib_webassembly/script/import.ml | 8 +- src/lib_webassembly/syntax/ast.ml | 98 +++++++++++------ src/lib_webassembly/syntax/free.ml | 30 +++++- src/lib_webassembly/syntax/free.mli | 2 +- src/lib_webassembly/util/lazy_vector.ml | 1 + src/lib_webassembly/util/lib.ml | 9 ++ src/lib_webassembly/util/lib.mli | 2 + src/lib_webassembly/valid/valid.ml | 22 +++- src/lib_webassembly/valid/valid.mli | 2 +- 20 files changed, 475 insertions(+), 214 deletions(-) diff --git a/src/lib_webassembly/bin/script/js.ml b/src/lib_webassembly/bin/script/js.ml index fd1c13079bf0..3474e4f0c445 100644 --- a/src/lib_webassembly/bin/script/js.ml +++ b/src/lib_webassembly/bin/script/js.ml @@ -2,6 +2,7 @@ open Types open Ast open Script open Source +module TzStdLib = Tezos_lwt_result_stdlib.Lwtreslib.Bare (* Harness *) @@ -199,11 +200,14 @@ type exports = extern_type NameMap.t type modules = {mutable env : exports Map.t; mutable current : int} -let exports m : exports = - List.fold_left - (fun map exp -> NameMap.add exp.it.name (export_type m exp) map) +let exports m : exports Lwt.t = + let open Lwt.Syntax in + TzStdLib.List.fold_left_s + (fun map (_, exp) -> + let+ t = export_type m exp in + NameMap.add exp.it.name t map) NameMap.empty - m.it.exports + (Lazy_vector.LwtInt32Vector.loaded_bindings m.it.exports) let modules () : modules = {env = Map.empty; current = 0} @@ -214,7 +218,8 @@ let of_var_opt (mods : modules) = function | Some x -> x.it let bind (mods : modules) x_opt m = - let exports = exports m in + let open Lwt.Syntax in + let+ exports = exports m in mods.current <- mods.current + 1 ; mods.env <- Map.add (of_var_opt mods x_opt) exports mods.env ; if x_opt <> None then mods.env <- Map.add (current_var mods) exports mods.env @@ -430,8 +435,9 @@ let wrap item_name wrap_action wrap_assertion at = :: (FuncType ([RefType FuncRefType; RefType FuncRefType], [NumType I32Type]) @@ at) :: itypes + |> Lazy_vector.LwtInt32Vector.of_list in - let imports = + let imports_list = [ {module_name = Utf8.decode "module"; item_name; idesc} @@ at; { @@ -471,18 +477,25 @@ let wrap item_name wrap_action wrap_assertion at = (fun i im -> match im.it.idesc.it with FuncImport _ -> Int32.add i 1l | _ -> i) 0l - imports + imports_list @@ at in + let imports = imports_list |> Lazy_vector.LwtInt32Vector.of_list in let edesc = FuncExport item @@ at in - let exports = [{name = Utf8.decode "run"; edesc} @@ at] in + let exports = + [{name = Utf8.decode "run"; edesc} @@ at] + |> Lazy_vector.LwtInt32Vector.of_list + in let body = [ Block (ValBlockType None, action @ assertion @ [Return @@ at]) @@ at; Unreachable @@ at; ] in - let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in + let funcs = + [{ftype = 0l @@ at; locals; body} @@ at] + |> Lazy_vector.LwtInt32Vector.of_list + in let m = {empty_module with types; funcs; imports; exports} @@ at in Encode.encode m @@ -585,16 +598,23 @@ let of_result res = | RefResult rp -> of_ref_pat rp let rec of_definition def = + let open Lwt.Syntax in match def.it with - | Textual m -> of_bytes (Encode.encode m) - | Encoded (_, bs) -> of_bytes bs - | Quoted (_, s) -> ( - try of_definition (Parse.string_to_module s) - with Parse.Syntax _ -> of_bytes "") + | Textual m -> + let+ m = Encode.encode m in + of_bytes m + | Encoded (_, bs) -> of_bytes bs |> Lwt.return + | Quoted (_, s) -> + Lwt.catch + (fun () -> of_definition (Parse.string_to_module s)) + (function + | Parse.Syntax _ -> of_bytes "" |> Lwt.return + | e -> Lwt.fail e) let of_wrapper mods x_opt name wrap_action wrap_assertion at = + let open Lwt.Syntax in let x = of_var_opt mods x_opt in - let bs = wrap name wrap_action wrap_assertion at in + let+ bs = wrap name wrap_action wrap_assertion at in "call(instance(" ^ of_bytes bs ^ ", " ^ "exports(" ^ x ^ ")), " ^ " \"run\", [])" @@ -618,25 +638,35 @@ let of_action mods act = | _ -> None )) let of_assertion' mods act name args wrapper_opt = + let open Lwt.Syntax in let act_js, act_wrapper_opt = of_action mods act in let js = name ^ "(() => " ^ act_js ^ String.concat ", " ("" :: args) ^ ")" in match act_wrapper_opt with - | None -> js ^ ";" + | None -> Lwt.return (js ^ ";") | Some (act_wrapper, out) -> let run_name, wrapper = match wrapper_opt with | None -> (name, run) | Some wrapper -> ("run", wrapper) in - run_name ^ "(() => " ^ act_wrapper (wrapper out) act.at ^ "); // " ^ js + let+ res = act_wrapper (wrapper out) act.at in + run_name ^ "(() => " ^ res ^ "); // " ^ js let of_assertion mods ass = + let open Lwt.Syntax in match ass.it with - | AssertMalformed (def, _) -> "assert_malformed(" ^ of_definition def ^ ");" - | AssertInvalid (def, _) -> "assert_invalid(" ^ of_definition def ^ ");" - | AssertUnlinkable (def, _) -> "assert_unlinkable(" ^ of_definition def ^ ");" + | AssertMalformed (def, _) -> + let+ def = of_definition def in + "assert_malformed(" ^ def ^ ");" + | AssertInvalid (def, _) -> + let+ def = of_definition def in + "assert_invalid(" ^ def ^ ");" + | AssertUnlinkable (def, _) -> + let+ def = of_definition def in + "assert_unlinkable(" ^ def ^ ");" | AssertUninstantiable (def, _) -> - "assert_uninstantiable(" ^ of_definition def ^ ");" + let+ def = of_definition def in + "assert_uninstantiable(" ^ def ^ ");" | AssertReturn (act, ress) -> of_assertion' mods @@ -649,31 +679,42 @@ let of_assertion mods ass = of_assertion' mods act "assert_exhaustion" [] None let of_command mods cmd = + let open Lwt.Syntax in + let+ cmd_s = + match cmd.it with + | Module (x_opt, def) -> + let rec unquote def = + match def.it with + | Textual m -> Lwt.return m + | Encoded (_, bytes) -> + Decode.decode ~name:"binary" ~bytes |> Lwt.return + | Quoted (_, s) -> unquote (Parse.string_to_module s) + in + let* unquoted = unquote def in + let* () = bind mods x_opt unquoted in + let+ def = of_definition def in + "let " ^ current_var mods ^ " = instance(" ^ def ^ ");\n" + ^ + if x_opt = None then "" + else "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n" + | Register (name, x_opt) -> + "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n" + |> Lwt.return + | Action act -> + let+ cmd = of_assertion' mods act "run" [] None in + cmd ^ "\n" + | Assertion ass -> + let+ cmd = of_assertion mods ass in + cmd ^ "\n" + | Meta _ -> assert false + in "\n// " ^ Filename.basename cmd.at.left.file ^ ":" ^ string_of_int cmd.at.left.line - ^ "\n" - ^ - match cmd.it with - | Module (x_opt, def) -> - let rec unquote def = - match def.it with - | Textual m -> m - | Encoded (_, bytes) -> Decode.decode ~name:"binary" ~bytes - | Quoted (_, s) -> unquote (Parse.string_to_module s) - in - bind mods x_opt (unquote def) ; - "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" - ^ - if x_opt = None then "" - else "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n" - | Register (name, x_opt) -> - "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n" - | Action act -> of_assertion' mods act "run" [] None ^ "\n" - | Assertion ass -> of_assertion mods ass ^ "\n" - | Meta _ -> assert false + ^ "\n" ^ cmd_s let of_script scr = - (if !Flags.harness then harness else "") - ^ String.concat "" (List.map (of_command (modules ())) scr) + let open Lwt.Syntax in + let+ cmds = TzStdLib.List.map_s (of_command (modules ())) scr in + (if !Flags.harness then harness else "") ^ String.concat "" cmds diff --git a/src/lib_webassembly/bin/script/js.mli b/src/lib_webassembly/bin/script/js.mli index c60d3c501ba1..c62f639082e8 100644 --- a/src/lib_webassembly/bin/script/js.mli +++ b/src/lib_webassembly/bin/script/js.mli @@ -1 +1 @@ -val of_script : Script.script -> string +val of_script : Script.script -> string Lwt.t diff --git a/src/lib_webassembly/bin/script/run.ml b/src/lib_webassembly/bin/script/run.ml index 37a8ff7aee36..49cb413500d8 100644 --- a/src/lib_webassembly/bin/script/run.ml +++ b/src/lib_webassembly/bin/script/run.ml @@ -49,7 +49,7 @@ let dispatch_file_ext on_binary on_sexpr on_script_binary on_script on_js file = let create_binary_file file _ get_module = let* () = trace_lwt ("Encoding (" ^ file ^ ")...") in - let s = Encode.encode (get_module ()) in + let* s = Encode.encode (get_module ()) in Lwt_io.( with_file ~mode:Output file (fun oc -> let* () = trace_lwt "Writing..." in @@ -68,7 +68,7 @@ let create_script_file mode file get_script _ = let create_js_file file get_script _ = let* () = trace_lwt ("Converting (" ^ file ^ ")...") in - let js = Js.of_script (get_script ()) in + let* js = Js.of_script (get_script ()) in Lwt_io.( with_file ~mode:Output file (fun oc -> let* () = trace_lwt "Writing..." in @@ -213,10 +213,14 @@ let input_stdin run = (* Printing *) +let map_to_list m = List.map snd (Lazy_vector.LwtInt32Vector.loaded_bindings m) + let print_import m im = let open Types in - let category, annotation = - match Ast.import_type m im with + let open Lwt.Syntax in + let+ category, annotation = + let+ t = Ast.import_type m im in + match t with | ExternFuncType t -> ("func", string_of_func_type t) | ExternTableType t -> ("table", string_of_table_type t) | ExternMemoryType t -> ("memory", string_of_memory_type t) @@ -231,8 +235,10 @@ let print_import m im = let print_export m ex = let open Types in - let category, annotation = - match Ast.export_type m ex with + let open Lwt.Syntax in + let+ category, annotation = + let+ t = Ast.export_type m ex in + match t with | ExternFuncType t -> ("func", string_of_func_type t) | ExternTableType t -> ("table", string_of_table_type t) | ExternMemoryType t -> ("memory", string_of_memory_type t) @@ -248,8 +254,12 @@ let print_module x_opt m = Printf.printf "module%s :\n" (match x_opt with None -> "" | Some x -> " " ^ x.it) ; - List.iter (print_import m) m.it.Ast.imports ; - List.iter (print_export m) m.it.Ast.exports ; + let* () = + TzStdLib.List.iter_s (print_import m) (map_to_list m.it.Ast.imports) + in + let+ () = + TzStdLib.List.iter_s (print_export m) (map_to_list m.it.Ast.exports) + in flush_all () let print_values vs = @@ -480,7 +490,7 @@ let run_assertion ass : unit Lwt.t = let* () = trace_lwt "Asserting invalid..." in Lwt.try_bind (fun () -> - let+ m = run_definition def in + let* m = run_definition def in Valid.check_module m) (fun _ -> Assert.error ass.at "expected validation error") (function @@ -489,7 +499,9 @@ let run_assertion ass : unit Lwt.t = | AssertUnlinkable (def, re) -> let* () = trace_lwt "Asserting unlinkable..." in let* m = run_definition def in - if not !Flags.unchecked then Valid.check_module m ; + let* () = + if not !Flags.unchecked then Valid.check_module m else Lwt.return_unit + in Lwt.try_bind (fun () -> let* imports = Import.link m in @@ -502,7 +514,9 @@ let run_assertion ass : unit Lwt.t = | AssertUninstantiable (def, re) -> let* () = trace_lwt "Asserting trap..." in let* m = run_definition def in - if not !Flags.unchecked then Valid.check_module m ; + let* () = + if not !Flags.unchecked then Valid.check_module m else Lwt.return_unit + in Lwt.try_bind (fun () -> let* imports = Import.link m in @@ -540,13 +554,13 @@ let rec run_command cmd : unit Lwt.t = quote := cmd :: !quote ; let* m = run_definition def in let* () = - if not !Flags.unchecked then ( + if not !Flags.unchecked then let* () = trace_lwt "Checking..." in - Valid.check_module m ; + let* () = Valid.check_module m in if !Flags.print_sig then - let+ () = trace_lwt "Signature:" in + let* () = trace_lwt "Signature:" in print_module x_opt m - else Lwt.return_unit) + else Lwt.return_unit else Lwt.return_unit in bind scripts x_opt [cmd] ; diff --git a/src/lib_webassembly/bin/text/arrange.ml b/src/lib_webassembly/bin/text/arrange.ml index 04c21196d52a..d3e7573ab5a4 100644 --- a/src/lib_webassembly/bin/text/arrange.ml +++ b/src/lib_webassembly/bin/text/arrange.ml @@ -43,10 +43,16 @@ let list_of_opt = function None -> [] | Some x -> [x] let list f xs = List.map f xs -let listi f xs = List.mapi f xs - let opt f xo = list f (list_of_opt xo) +let lazy_vector f map = + List.map (fun (_, v) -> f v) (Lazy_vector.LwtInt32Vector.loaded_bindings map) + +let lazy_vectori f map = + List.map + (fun (i32, v) -> f (Int32.to_int i32) v) + (Lazy_vector.LwtInt32Vector.loaded_bindings map) + let tab head f xs = if xs = [] then [] else [Node (head, list f xs)] let atom f x = Atom (f x) @@ -643,16 +649,19 @@ let module_with_var_opt x_opt m = let tx = ref 0 in let mx = ref 0 in let gx = ref 0 in - let imports = list (import fx tx mx gx) m.it.imports in + let imports = lazy_vector (import fx tx mx gx) m.it.imports in Node ( "module" ^ var_opt x_opt, - listi typedef m.it.types @ imports - @ listi (table !tx) m.it.tables - @ listi (memory !mx) m.it.memories - @ listi (global !gx) m.it.globals - @ listi (func_with_index !fx) m.it.funcs - @ list export m.it.exports @ opt start m.it.start @ listi elem m.it.elems - @ listi data m.it.datas ) + lazy_vectori typedef m.it.types + @ imports + @ lazy_vectori (table !tx) m.it.tables + @ lazy_vectori (memory !mx) m.it.memories + @ lazy_vectori (global !gx) m.it.globals + @ lazy_vectori (func_with_index !fx) m.it.funcs + @ lazy_vector export m.it.exports + @ opt start m.it.start + @ lazy_vectori elem m.it.elems + @ lazy_vectori data m.it.datas ) let binary_module_with_var_opt x_opt bs = Node ("module" ^ var_opt x_opt ^ " binary", break_bytes bs) @@ -680,30 +689,39 @@ let literal mode lit = | Ref r -> ref_ r let definition mode x_opt def = - try - match mode with - | `Textual -> - let rec unquote def = + let open Lwt.Syntax in + Lwt.catch + (fun () -> + match mode with + | `Textual -> + let rec unquote def = + match def.it with + | Textual m -> Lwt.return m + | Encoded (_, bytes) -> Decode.decode ~name:"" ~bytes |> Lwt.return + | Quoted (_, s) -> unquote (Parse.string_to_module s) + in + let+ unquoted = unquote def in + module_with_var_opt x_opt unquoted + | `Binary -> + let rec unquote def = + match def.it with + | Textual m -> Encode.encode m + | Encoded (_, bytes) -> + let m = Decode.decode ~name:"" ~bytes in + Encode.encode m + | Quoted (_, s) -> unquote (Parse.string_to_module s) + in + let+ unquoted = unquote def in + binary_module_with_var_opt x_opt unquoted + | `Original -> ( match def.it with - | Textual m -> m - | Encoded (_, bytes) -> Decode.decode ~name:"" ~bytes - | Quoted (_, s) -> unquote (Parse.string_to_module s) - in - module_with_var_opt x_opt (unquote def) - | `Binary -> - let rec unquote def = - match def.it with - | Textual m -> Encode.encode m - | Encoded (_, bytes) -> Encode.encode (Decode.decode ~name:"" ~bytes) - | Quoted (_, s) -> unquote (Parse.string_to_module s) - in - binary_module_with_var_opt x_opt (unquote def) - | `Original -> ( - match def.it with - | Textual m -> module_with_var_opt x_opt m - | Encoded (_, bs) -> binary_module_with_var_opt x_opt bs - | Quoted (_, s) -> quoted_module_with_var_opt x_opt s) - with Parse.Syntax _ -> quoted_module_with_var_opt x_opt "" + | Textual m -> module_with_var_opt x_opt m |> Lwt.return + | Encoded (_, bs) -> binary_module_with_var_opt x_opt bs |> Lwt.return + | Quoted (_, s) -> quoted_module_with_var_opt x_opt s |> Lwt.return)) + (function + | Parse.Syntax _ -> + quoted_module_with_var_opt x_opt "" |> Lwt.return + | e -> Lwt.fail e) let access x_opt n = String.concat " " [var_opt x_opt; name n] @@ -749,37 +767,45 @@ let result mode res = | RefResult rp -> ref_pat rp let assertion mode ass = + let open Lwt.Syntax in match ass.it with | AssertMalformed (def, re) -> ( match (mode, def.it) with - | `Binary, Quoted _ -> [] + | `Binary, Quoted _ -> Lwt.return [] | _ -> - [ - Node - ( "assert_malformed", - [definition `Original None def; Atom (string re)] ); - ]) + let+ def = definition `Original None def in + [Node ("assert_malformed", [def; Atom (string re)])]) | AssertInvalid (def, re) -> - [Node ("assert_invalid", [definition mode None def; Atom (string re)])] + let+ def = definition mode None def in + [Node ("assert_invalid", [def; Atom (string re)])] | AssertUnlinkable (def, re) -> - [Node ("assert_unlinkable", [definition mode None def; Atom (string re)])] + let+ def = definition mode None def in + [Node ("assert_unlinkable", [def; Atom (string re)])] | AssertUninstantiable (def, re) -> - [Node ("assert_trap", [definition mode None def; Atom (string re)])] + let+ def = definition mode None def in + [Node ("assert_trap", [def; Atom (string re)])] | AssertReturn (act, results) -> - [ - Node ("assert_return", action mode act :: List.map (result mode) results); - ] + Lwt.return + [ + Node + ("assert_return", action mode act :: List.map (result mode) results); + ] | AssertTrap (act, re) -> - [Node ("assert_trap", [action mode act; Atom (string re)])] + Lwt.return [Node ("assert_trap", [action mode act; Atom (string re)])] | AssertExhaustion (act, re) -> - [Node ("assert_exhaustion", [action mode act; Atom (string re)])] + Lwt.return + [Node ("assert_exhaustion", [action mode act; Atom (string re)])] let command mode cmd = + let open Lwt.Syntax in match cmd.it with - | Module (x_opt, def) -> [definition mode x_opt def] - | Register (n, x_opt) -> [Node ("register " ^ name n ^ var_opt x_opt, [])] - | Action act -> [action mode act] + | Module (x_opt, def) -> + let+ def = definition mode x_opt def in + [def] + | Register (n, x_opt) -> + Lwt.return [Node ("register " ^ name n ^ var_opt x_opt, [])] + | Action act -> Lwt.return [action mode act] | Assertion ass -> assertion mode ass | Meta _ -> assert false -let script mode scr = Lib.List.concat_map (command mode) scr +let script mode scr = Lib.List.concat_map_s (command mode) scr diff --git a/src/lib_webassembly/bin/text/arrange.mli b/src/lib_webassembly/bin/text/arrange.mli index e9b5a89c5d50..60c103dc7ba5 100644 --- a/src/lib_webassembly/bin/text/arrange.mli +++ b/src/lib_webassembly/bin/text/arrange.mli @@ -6,4 +6,4 @@ val func : Ast.func -> sexpr val module_ : Ast.module_ -> sexpr -val script : [`Textual | `Binary] -> Script.script -> sexpr list +val script : [`Textual | `Binary] -> Script.script -> sexpr list Lwt.t diff --git a/src/lib_webassembly/bin/text/parser.mly b/src/lib_webassembly/bin/text/parser.mly index 686e1685fc35..d6f276e56c33 100644 --- a/src/lib_webassembly/bin/text/parser.mly +++ b/src/lib_webassembly/bin/text/parser.mly @@ -202,6 +202,63 @@ let inline_type_explicit (c : context) x ft at = error at "inline function type does not match explicit type"; x +(** Intermediate module using the string representation. *) +type parsed_module = +{ + p_types : type_ list; + p_globals : global list; + p_tables : table list; + p_memories : memory list; + p_funcs : func list; + p_start : start option; + p_elems : elem_segment list; + p_datas : data_segment list; + p_imports : import list; + p_exports : export list; +} + +(* Auxiliary functions *) + +let empty_parsed_module = +{ + p_types = []; + p_globals = []; + p_tables = []; + p_memories = []; + p_funcs = []; + p_start = None; + p_elems = []; + p_datas = []; + p_imports = []; + p_exports = []; +} + +let to_module_ pm = + let + { p_types; p_imports; p_tables; p_memories; p_globals; p_funcs; p_start; p_elems; p_datas; + p_exports } = pm.it + in + let types = Lazy_vector.LwtInt32Vector.of_list p_types in + let imports = Lazy_vector.LwtInt32Vector.of_list p_imports in + let tables = Lazy_vector.LwtInt32Vector.of_list p_tables in + let memories = Lazy_vector.LwtInt32Vector.of_list p_memories in + let globals = Lazy_vector.LwtInt32Vector.of_list p_globals in + let funcs = Lazy_vector.LwtInt32Vector.of_list p_funcs in + let elems = Lazy_vector.LwtInt32Vector.of_list p_elems in + let datas = Lazy_vector.LwtInt32Vector.of_list p_datas in + let exports = Lazy_vector.LwtInt32Vector.of_list p_exports in + { + types; + tables; + memories; + globals; + funcs; + imports; + exports; + elems; + datas; + start = p_start; + } @@ pm.at %} %token LPAR RPAR @@ -999,7 +1056,7 @@ start : module_fields : | /* empty */ - { fun (c : context) () -> {empty_module with types = c.types.list} } + { fun (c : context) () -> {empty_parsed_module with p_types = c.types.list} } | module_fields1 { $1 } module_fields1 : @@ -1008,53 +1065,54 @@ module_fields1 : | global module_fields { fun c -> let gf = $1 c in let mf = $2 c in fun () -> let globs, ims, exs = gf () in let m = mf () in - if globs <> [] && m.imports <> [] then - error (List.hd m.imports).at "import after global definition"; - { m with globals = globs @ m.globals; - imports = ims @ m.imports; exports = exs @ m.exports } } + if globs <> [] && m.p_imports <> [] then + (* There's no reasons 0l is inaccessible from the text parser, since it has been built from a list *) + error (List.hd m.p_imports).at "import after global definition"; + { m with p_globals = globs @ m.p_globals; + p_imports = ims @ m.p_imports; p_exports = exs @ m.p_exports } } | table module_fields { fun c -> let tf = $1 c in let mf = $2 c in fun () -> let tabs, elems, ims, exs = tf () in let m = mf () in - if tabs <> [] && m.imports <> [] then - error (List.hd m.imports).at "import after table definition"; - { m with tables = tabs @ m.tables; elems = elems @ m.elems; - imports = ims @ m.imports; exports = exs @ m.exports } } + if tabs <> [] && m.p_imports <> [] then + error (List.hd m.p_imports).at "import after table definition"; + { m with p_tables = tabs @ m.p_tables; p_elems = elems @ m.p_elems; + p_imports = ims @ m.p_imports; p_exports = exs @ m.p_exports } } | memory module_fields { fun c -> let mmf = $1 c in let mf = $2 c in fun () -> let mems, data, ims, exs = mmf () in let m = mf () in - if mems <> [] && m.imports <> [] then - error (List.hd m.imports).at "import after memory definition"; - { m with memories = mems @ m.memories; datas = data @ m.datas; - imports = ims @ m.imports; exports = exs @ m.exports } } + if mems <> [] && m.p_imports <> [] then + error (List.hd m.p_imports).at "import after memory definition"; + { m with p_memories = mems @ m.p_memories; p_datas = data @ m.p_datas; + p_imports = ims @ m.p_imports; p_exports = exs @ m.p_exports } } | func module_fields { fun c -> let ff = $1 c in let mf = $2 c in fun () -> let funcs, ims, exs = ff () in let m = mf () in - if funcs <> [] && m.imports <> [] then - error (List.hd m.imports).at "import after function definition"; - { m with funcs = funcs @ m.funcs; - imports = ims @ m.imports; exports = exs @ m.exports } } + if funcs <> [] && m.p_imports <> [] then + error (List.hd m.p_imports).at "import after function definition"; + { m with p_funcs = funcs @ m.p_funcs; + p_imports = ims @ m.p_imports; p_exports = exs @ m.p_exports } } | elem module_fields { fun c -> let ef = $1 c in let mf = $2 c in fun () -> let elems = ef () in let m = mf () in - {m with elems = elems :: m.elems} } + {m with p_elems = elems :: m.p_elems} } | data module_fields { fun c -> let df = $1 c in let mf = $2 c in fun () -> let data = df () in let m = mf () in - {m with datas = data :: m.datas} } + {m with p_datas = data :: m.p_datas} } | start module_fields { fun c -> let mf = $2 c in fun () -> let m = mf () in let x = $1 c in - match m.start with + match m.p_start with | Some _ -> error x.at "multiple start sections" - | None -> {m with start = Some x} } + | None -> {m with p_start = Some x} } | import module_fields { fun c -> let imf = $1 c in let mf = $2 c in fun () -> let im = imf () in let m = mf () in - {m with imports = im :: m.imports} } + {m with p_imports = im :: m.p_imports} } | export module_fields { fun c -> let mf = $2 c in fun () -> let m = mf () in - {m with exports = $1 c :: m.exports} } + {m with p_exports = $1 c :: m.p_exports} } module_var_opt : | /* empty */ { None } @@ -1062,13 +1120,13 @@ module_var_opt : module_ : | LPAR MODULE module_var_opt module_fields RPAR - { $3, Textual ($4 (empty_context ()) () @@ at ()) @@ at () } + { $3, Textual (($4 (empty_context ()) () @@ at ()) |> to_module_) @@ at () } inline_module : /* Sugar */ - | module_fields { Textual ($1 (empty_context ()) () @@ at ()) @@ at () } + | module_fields { Textual (($1 (empty_context ()) () @@ at ()) |> to_module_) @@ at () } inline_module1 : /* Sugar */ - | module_fields1 { Textual ($1 (empty_context ()) () @@ at ()) @@ at () } + | module_fields1 { Textual (($1 (empty_context ()) () @@ at ()) |> to_module_) @@ at () } /* Scripts */ diff --git a/src/lib_webassembly/bin/text/print.ml b/src/lib_webassembly/bin/text/print.ml index 80127b3cd331..97441cb36829 100644 --- a/src/lib_webassembly/bin/text/print.ml +++ b/src/lib_webassembly/bin/text/print.ml @@ -7,5 +7,6 @@ let func oc width f = Sexpr.output oc width (Arrange.func f) let module_ oc width m = Sexpr.output oc width (Arrange.module_ m) let script oc width mode s = - let script = Arrange.script mode s in + let open Lwt.Syntax in + let* script = Arrange.script mode s in TzStdLib.List.iter_s (Sexpr.output oc width) script diff --git a/src/lib_webassembly/binary/decode.ml b/src/lib_webassembly/binary/decode.ml index 179e003f41c8..33e3b77c2832 100644 --- a/src/lib_webassembly/binary/decode.ml +++ b/src/lib_webassembly/binary/decode.ml @@ -1,6 +1,7 @@ (* Decoding stream *) open Binary_exn +module Vector = Lazy_vector.LwtInt32Vector type stream = {name : string; bytes : string; pos : int ref} @@ -1874,15 +1875,16 @@ let module_step state = module_kont = MKStop { - types; - tables; - memories; - globals; - funcs; - imports; - exports; - elems; - datas; + (* Parse directly into the Lazy_maps *) + types = types |> Vector.of_list; + tables = tables |> Vector.of_list; + memories = memories |> Vector.of_list; + globals = globals |> Vector.of_list; + funcs = funcs |> Vector.of_list; + imports = imports |> Vector.of_list; + exports = exports |> Vector.of_list; + elems = elems |> Vector.of_list; + datas = datas |> Vector.of_list; start; }; } diff --git a/src/lib_webassembly/binary/encode.ml b/src/lib_webassembly/binary/encode.ml index d2b4ed0a28c0..549ad14863ab 100644 --- a/src/lib_webassembly/binary/encode.ml +++ b/src/lib_webassembly/binary/encode.ml @@ -1115,7 +1115,9 @@ struct (* Data count section *) let data_count_section datas m = - section 12 len (List.length datas) Free.((module_ m).datas <> Set.empty) + let open Lwt.Syntax in + let+ modl = Free.module_ m in + section 12 len (List.length datas) Free.(modl.datas <> Set.empty) (* Custom section *) let custom (n, bs) = @@ -1126,27 +1128,32 @@ struct (* Module *) let module_ m = + let open Lwt.Syntax in + let to_list m = + List.map snd (Lazy_vector.LwtInt32Vector.loaded_bindings m) + in u32 0x6d736100l ; u32 version ; - type_section m.it.types ; - import_section m.it.imports ; - func_section m.it.funcs ; - table_section m.it.tables ; - memory_section m.it.memories ; - global_section m.it.globals ; - export_section m.it.exports ; + type_section (to_list m.it.types) ; + import_section (to_list m.it.imports) ; + func_section (to_list m.it.funcs) ; + table_section (to_list m.it.tables) ; + memory_section (to_list m.it.memories) ; + global_section (to_list m.it.globals) ; + export_section (to_list m.it.exports) ; start_section m.it.start ; - elem_section m.it.elems ; - data_count_section m.it.datas m ; - code_section m.it.funcs ; - data_section m.it.datas + elem_section (to_list m.it.elems) ; + let+ () = data_count_section (to_list m.it.datas) m in + code_section (to_list m.it.funcs) ; + data_section (to_list m.it.datas) end let encode m = + let open Lwt.Syntax in let module E = E (struct let stream = stream () end) in - E.module_ m ; + let+ () = E.module_ m in to_string E.s let encode_custom name content = diff --git a/src/lib_webassembly/binary/encode.mli b/src/lib_webassembly/binary/encode.mli index 8bd47f092f75..55845e5c94a0 100644 --- a/src/lib_webassembly/binary/encode.mli +++ b/src/lib_webassembly/binary/encode.mli @@ -2,6 +2,6 @@ exception Code of Source.region * string val version : int32 -val encode : Ast.module_ -> string +val encode : Ast.module_ -> string Lwt.t val encode_custom : Ast.name -> string -> string diff --git a/src/lib_webassembly/exec/eval.ml b/src/lib_webassembly/exec/eval.ml index 9dbb94d1ccb4..ab2ad9a14690 100644 --- a/src/lib_webassembly/exec/eval.ml +++ b/src/lib_webassembly/exec/eval.ml @@ -1,5 +1,4 @@ open Lwt.Syntax -module TzStdLib = Tezos_lwt_result_stdlib.Lwtreslib.Bare open Values open Types open Instance @@ -878,8 +877,9 @@ let create_data (inst : module_inst) (seg : data_segment) : data_inst Lwt.t = ref data let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : - module_inst = - if not (match_extern_type (extern_type_of ext) (import_type m im)) then + module_inst Lwt.t = + let+ t = import_type m im in + if not (match_extern_type (extern_type_of ext) t) then Link.error im.at ("incompatible import type for " ^ "\"" @@ -887,7 +887,7 @@ let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : ^ "\" " ^ "\"" ^ Utf8.encode im.it.item_name ^ "\": " ^ "expected " - ^ Types.string_of_extern_type (import_type m im) + ^ Types.string_of_extern_type t ^ ", got " ^ Types.string_of_extern_type (extern_type_of ext)) ; match ext with @@ -941,6 +941,7 @@ let run_data i data = let run_start start = [Call start.it.sfunc @@ start.at] let init (m : module_) (exts : extern list) : module_inst Lwt.t = + let open Lwt.Syntax in let { imports; tables; @@ -955,11 +956,40 @@ let init (m : module_) (exts : extern list) : module_inst Lwt.t = } = m.it in - if List.length exts <> List.length imports then - Link.error m.at "wrong number of imports provided for initialisation" ; + + (* TODO: #3076 + + These transformations should be refactored and abadoned during the + tickification, to avoid the roundtrip vector -> list -> vector. *) + let* types = Vector.to_list types in + let* imports = Vector.to_list imports in + let* tables = Vector.to_list tables in + let* memories = Vector.to_list memories in + let* globals = Vector.to_list globals in + let* funcs = Vector.to_list funcs in + let* elems = Vector.to_list elems in + let* datas = Vector.to_list datas in + let* exports = Vector.to_list exports in + + (* TODO: #3076 + To refactor during the tickification. *) + let* init_inst0 = + TzStdLib.List.fold_right2_s + ~when_different_lengths:() + (add_import m) + exts + imports + empty_module_inst + in + let init_inst0 = + match init_inst0 with + | Ok i -> i + | Error () -> + Link.error m.at "wrong number of imports provided for initialisation" + in let inst0 = { - (List.fold_right2 (add_import m) exts imports empty_module_inst) with + init_inst0 with types = (* TODO: #3076 [types] should be a lazy structure so we can avoid traversing it diff --git a/src/lib_webassembly/script/import.ml b/src/lib_webassembly/script/import.ml index 76fdb3c58828..687888281a33 100644 --- a/src/lib_webassembly/script/import.ml +++ b/src/lib_webassembly/script/import.ml @@ -17,8 +17,9 @@ let registry = ref Registry.empty let register name lookup = registry := Registry.add name lookup !registry let lookup (m : module_) (im : import) : Instance.extern Lwt.t = + let open Lwt.Syntax in let {module_name; item_name; idesc} = im.it in - let t = import_type m im in + let* t = import_type m im in Lwt.catch (fun () -> Registry.find module_name !registry item_name t) (function @@ -29,4 +30,7 @@ let lookup (m : module_) (im : import) : Instance.extern Lwt.t = ^ string_of_name item_name ^ "\"") | exn -> raise exn) -let link m = TzStdLib.List.map_s (lookup m) m.it.imports +let link m = + let open Lwt.Syntax in + let* imports = Lazy_vector.LwtInt32Vector.to_list m.it.imports in + TzStdLib.List.map_s (lookup m) imports diff --git a/src/lib_webassembly/syntax/ast.ml b/src/lib_webassembly/syntax/ast.ml index 8640f5cc45bf..f6aa6a35483d 100644 --- a/src/lib_webassembly/syntax/ast.ml +++ b/src/lib_webassembly/syntax/ast.ml @@ -17,6 +17,8 @@ *) open Types +module TzStdLib = Tezos_lwt_result_stdlib.Lwtreslib.Bare +module Vector = Lazy_vector.LwtInt32Vector type void = Lib.void @@ -396,65 +398,95 @@ and start' = {sfunc : var} type module_ = module_' Source.phrase and module_' = { - types : type_ list; - globals : global list; - tables : table list; - memories : memory list; - funcs : func list; + types : type_ Vector.t; + globals : global Vector.t; + tables : table Vector.t; + memories : memory Vector.t; + funcs : func Vector.t; start : start option; - elems : elem_segment list; - datas : data_segment list; - imports : import list; - exports : export list; + elems : elem_segment Vector.t; + datas : data_segment Vector.t; + imports : import Vector.t; + exports : export Vector.t; } (* Auxiliary functions *) let empty_module = { - types = []; - globals = []; - tables = []; - memories = []; - funcs = []; + types = Vector.create 0l; + globals = Vector.create 0l; + tables = Vector.create 0l; + memories = Vector.create 0l; + funcs = Vector.create 0l; start = None; - elems = []; - datas = []; - imports = []; - exports = []; + elems = Vector.create 0l; + datas = Vector.create 0l; + imports = Vector.create 0l; + exports = Vector.create 0l; } open Source -let func_type_for (m : module_) (x : var) : func_type = - (Lib.List32.nth m.it.types x.it).it +let func_type_for (m : module_) (x : var) : func_type Lwt.t = + let open Lwt.Syntax in + let+ ty = Vector.get x.it m.it.types in + ty.it -let import_type (m : module_) (im : import) : extern_type = +let import_type (m : module_) (im : import) : extern_type Lwt.t = + let open Lwt.Syntax in let {idesc; _} = im.it in match idesc.it with - | FuncImport x -> ExternFuncType (func_type_for m x) - | TableImport t -> ExternTableType t - | MemoryImport t -> ExternMemoryType t - | GlobalImport t -> ExternGlobalType t - -let export_type (m : module_) (ex : export) : extern_type = + | FuncImport x -> + let+ ty = func_type_for m x in + ExternFuncType ty + | TableImport t -> Lwt.return (ExternTableType t) + | MemoryImport t -> Lwt.return (ExternMemoryType t) + | GlobalImport t -> Lwt.return (ExternGlobalType t) + +(* This function is only used to printing types for debugging purpose, as such + it is safe to use conversions to lists. *) +let export_type (m : module_) (ex : export) : extern_type Lwt.t = + let open Lwt.Syntax in let {edesc; _} = ex.it in - let its = List.map (import_type m) m.it.imports in + let* its = + TzStdLib.List.map_s + (fun (_, i) -> import_type m i) + (Vector.loaded_bindings m.it.imports) + in let open Lib.List32 in match edesc.it with | FuncExport x -> - let fts = - funcs its @ List.map (fun f -> func_type_for m f.it.ftype) m.it.funcs + let+ fts' = + TzStdLib.List.map_s + (fun (_, f) -> func_type_for m f.it.ftype) + (Vector.loaded_bindings m.it.funcs) in + let fts = funcs its @ fts' in ExternFuncType (nth fts x.it) | TableExport x -> - let tts = tables its @ List.map (fun t -> t.it.ttype) m.it.tables in + let+ tts' = + TzStdLib.List.map_s + (fun (_, t) -> Lwt.return t.it.ttype) + (Vector.loaded_bindings m.it.tables) + in + let tts = tables its @ tts' in ExternTableType (nth tts x.it) | MemoryExport x -> - let mts = memories its @ List.map (fun m -> m.it.mtype) m.it.memories in + let+ mts' = + TzStdLib.List.map_s + (fun (_, m) -> Lwt.return m.it.mtype) + (Vector.loaded_bindings m.it.memories) + in + let mts = memories its @ mts' in ExternMemoryType (nth mts x.it) | GlobalExport x -> - let gts = globals its @ List.map (fun g -> g.it.gtype) m.it.globals in + let+ gts' = + TzStdLib.List.map_s + (fun (_, g) -> Lwt.return g.it.gtype) + (Vector.loaded_bindings m.it.globals) + in + let gts = globals its @ gts' in ExternGlobalType (nth gts x.it) let string_of_name n = diff --git a/src/lib_webassembly/syntax/free.ml b/src/lib_webassembly/syntax/free.ml index 8d1b65de590b..1b79efcd29b6 100644 --- a/src/lib_webassembly/syntax/free.ml +++ b/src/lib_webassembly/syntax/free.ml @@ -66,10 +66,26 @@ let shift s = Set.map (Int32.add (-1l)) (Set.remove 0l s) let ( ++ ) = union +let ( ++* ) x y = + let open Lwt.Syntax in + let* x' = x in + let+ y' = y in + union x' y' + let list free xs = List.fold_left union empty (List.map free xs) let opt free xo = Lib.Option.get (Lib.Option.map free xo) empty +let lazy_vector free xs = + let open Tezos_lwt_result_stdlib.Lwtreslib.Bare in + (* [Free] module is used only during the validation of the AST, no mutation + can happen at this time, and is only used during tests. It is then safe to + simply use the list. *) + List.fold_left_s + (fun acc (_, s) -> Lwt.return (union acc (free s))) + empty + (Lazy_vector.LwtInt32Vector.loaded_bindings xs) + let block_type = function | VarBlockType x -> types (var x) | ValBlockType _ -> empty @@ -152,7 +168,13 @@ let import (i : import) = import_desc i.it.idesc let start (s : start) = funcs (var s.it.sfunc) let module_ (m : module_) = - list type_ m.it.types ++ list global m.it.globals ++ list table m.it.tables - ++ list memory m.it.memories ++ list func m.it.funcs ++ opt start m.it.start - ++ list elem m.it.elems ++ list data m.it.datas ++ list import m.it.imports - ++ list export m.it.exports + lazy_vector type_ m.it.types + ++* lazy_vector global m.it.globals + ++* lazy_vector table m.it.tables + ++* lazy_vector memory m.it.memories + ++* lazy_vector func m.it.funcs + ++* Lwt.return (opt start m.it.start) + ++* lazy_vector elem m.it.elems + ++* lazy_vector data m.it.datas + ++* lazy_vector import m.it.imports + ++* lazy_vector export m.it.exports diff --git a/src/lib_webassembly/syntax/free.mli b/src/lib_webassembly/syntax/free.mli index c3419d6987f5..9b3eaaf9de49 100644 --- a/src/lib_webassembly/syntax/free.mli +++ b/src/lib_webassembly/syntax/free.mli @@ -42,6 +42,6 @@ val import : Ast.import -> t val start : Ast.start -> t -val module_ : Ast.module_ -> t +val module_ : Ast.module_ -> t Lwt.t val list : ('a -> t) -> 'a list -> t diff --git a/src/lib_webassembly/util/lazy_vector.ml b/src/lib_webassembly/util/lazy_vector.ml index 61b1adb41a9e..1b7560219554 100644 --- a/src/lib_webassembly/util/lazy_vector.ml +++ b/src/lib_webassembly/util/lazy_vector.ml @@ -185,6 +185,7 @@ module Make (Effect : Effect.S) (Key : KeyS) : let to_list map = let open Effect in let rec unroll acc index = + Format.printf "index: %s\n%!" (Key.to_string index) ; if Key.unsigned_compare index Key.zero > 0 then let* prefix = get index map in (unroll [@ocaml.tailcall]) (prefix :: acc) (Key.pred index) diff --git a/src/lib_webassembly/util/lib.ml b/src/lib_webassembly/util/lib.ml index 0ed2b4a137d9..efa3763a8116 100644 --- a/src/lib_webassembly/util/lib.ml +++ b/src/lib_webassembly/util/lib.ml @@ -113,6 +113,15 @@ module List = struct let rec concat_map f = function [] -> [] | x :: xs -> f x @ concat_map f xs + let rec concat_map_s f l = + let open Lwt.Syntax in + match l with + | [] -> Lwt.return [] + | x :: xs -> + let* x' = f x in + let+ xs' = concat_map_s f xs in + x' @ xs' + let rec pairwise f = function | [] -> [] | x1 :: x2 :: xs -> f x1 x2 :: pairwise f xs diff --git a/src/lib_webassembly/util/lib.mli b/src/lib_webassembly/util/lib.mli index 257d862a3aa8..66db615980f7 100644 --- a/src/lib_webassembly/util/lib.mli +++ b/src/lib_webassembly/util/lib.mli @@ -33,6 +33,8 @@ module List : sig val concat_map : ('a -> 'b list) -> 'a list -> 'b list + val concat_map_s : ('a -> 'b list Lwt.t) -> 'a list -> 'b list Lwt.t + val pairwise : ('a -> 'a -> 'b) -> 'a list -> 'b list end diff --git a/src/lib_webassembly/valid/valid.ml b/src/lib_webassembly/valid/valid.ml index ca02a3704f01..0f77901bf42b 100644 --- a/src/lib_webassembly/valid/valid.ml +++ b/src/lib_webassembly/valid/valid.ml @@ -685,6 +685,8 @@ let check_export (c : context) (set : NameSet.t) (ex : export) : NameSet.t = NameSet.add name set let check_module (m : module_) = + let open Lwt.Syntax in + let to_list m = List.map snd (Lazy_vector.LwtInt32Vector.loaded_bindings m) in let { types; imports; @@ -699,15 +701,25 @@ let check_module (m : module_) = } = m.it in + let types = to_list types in + let imports = to_list imports in + let tables = to_list tables in + let memories = to_list memories in + let globals = to_list globals in + let funcs = to_list funcs in + let elems = to_list elems in + let datas = to_list datas in + let exports = to_list exports in + let+ refs = + Free.module_ + ({m.it with funcs = Lazy_vector.LwtInt32Vector.create 0l; start = None} + @@ m.at) + in let c0 = List.fold_right check_import imports - { - empty_context with - refs = Free.module_ ({m.it with funcs = []; start = None} @@ m.at); - types = List.map (fun ty -> ty.it) types; - } + {empty_context with refs; types = List.map (fun ty -> ty.it) types} in let c1 = { diff --git a/src/lib_webassembly/valid/valid.mli b/src/lib_webassembly/valid/valid.mli index 5827ae56e90c..786fac4af03b 100644 --- a/src/lib_webassembly/valid/valid.mli +++ b/src/lib_webassembly/valid/valid.mli @@ -1,3 +1,3 @@ exception Invalid of Source.region * string -val check_module : Ast.module_ -> unit (* raises Invalid *) +val check_module : Ast.module_ -> unit Lwt.t (* raises Invalid *) -- GitLab From faae6638a0c01763d4f28afd57b0ebe11dfc1ce6 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Fri, 10 Jun 2022 18:57:18 +0200 Subject: [PATCH 4/4] WASM/Parser: parsing module fields into lwt_lazy_vector --- src/lib_webassembly/bin/script/js.ml | 3 +- src/lib_webassembly/bin/script/run.ml | 2 +- src/lib_webassembly/bin/text/arrange.ml | 4 +- src/lib_webassembly/binary/decode.ml | 470 ++++++++++++------------ src/lib_webassembly/binary/decode.mli | 35 +- 5 files changed, 265 insertions(+), 249 deletions(-) diff --git a/src/lib_webassembly/bin/script/js.ml b/src/lib_webassembly/bin/script/js.ml index 3474e4f0c445..8a80e6ec6309 100644 --- a/src/lib_webassembly/bin/script/js.ml +++ b/src/lib_webassembly/bin/script/js.ml @@ -686,8 +686,7 @@ let of_command mods cmd = let rec unquote def = match def.it with | Textual m -> Lwt.return m - | Encoded (_, bytes) -> - Decode.decode ~name:"binary" ~bytes |> Lwt.return + | Encoded (_, bytes) -> Decode.decode ~name:"binary" ~bytes | Quoted (_, s) -> unquote (Parse.string_to_module s) in let* unquoted = unquote def in diff --git a/src/lib_webassembly/bin/script/run.ml b/src/lib_webassembly/bin/script/run.ml index 49cb413500d8..f4b8d3f22c18 100644 --- a/src/lib_webassembly/bin/script/run.ml +++ b/src/lib_webassembly/bin/script/run.ml @@ -361,7 +361,7 @@ let rec run_definition def : Ast.module_ Lwt.t = match def.it with | Textual m -> Lwt.return m | Encoded (name, bytes) -> - let+ () = trace_lwt "Decoding..." in + let* () = trace_lwt "Decoding..." in Decode.decode ~name ~bytes | Quoted (_, s) -> let* () = trace_lwt "Parsing quote..." in diff --git a/src/lib_webassembly/bin/text/arrange.ml b/src/lib_webassembly/bin/text/arrange.ml index d3e7573ab5a4..0f7fb6f953c6 100644 --- a/src/lib_webassembly/bin/text/arrange.ml +++ b/src/lib_webassembly/bin/text/arrange.ml @@ -697,7 +697,7 @@ let definition mode x_opt def = let rec unquote def = match def.it with | Textual m -> Lwt.return m - | Encoded (_, bytes) -> Decode.decode ~name:"" ~bytes |> Lwt.return + | Encoded (_, bytes) -> Decode.decode ~name:"" ~bytes | Quoted (_, s) -> unquote (Parse.string_to_module s) in let+ unquoted = unquote def in @@ -707,7 +707,7 @@ let definition mode x_opt def = match def.it with | Textual m -> Encode.encode m | Encoded (_, bytes) -> - let m = Decode.decode ~name:"" ~bytes in + let* m = Decode.decode ~name:"" ~bytes in Encode.encode m | Quoted (_, s) -> unquote (Parse.string_to_module s) in diff --git a/src/lib_webassembly/binary/decode.ml b/src/lib_webassembly/binary/decode.ml index 33e3b77c2832..3b6b70cea3ef 100644 --- a/src/lib_webassembly/binary/decode.ml +++ b/src/lib_webassembly/binary/decode.ml @@ -952,6 +952,16 @@ type ('a, 'b) vec_map_kont = type 'a vec_kont = ('a, 'a) vec_map_kont +type 'a lazy_vec_kont = Lazy_vec of {offset : int32; vector : 'a Vector.t} + +let is_end_of_vec (Lazy_vec {offset; vector}) = + Vector.num_elements vector <= offset + +let init_lazy_vec n = Lazy_vec {offset = 0l; vector = Vector.create n} + +let lazy_vec_step v (Lazy_vec {offset; vector}) = + Lazy_vec {offset = Int32.add offset 1l; vector = Vector.set offset v vector} + type pos = int (** Size checking version of {!sized} for CPS-style parsing. *) @@ -1509,7 +1519,7 @@ type _ 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 + | VecField : 'a field_type * 'a Vector.t -> field | SingleField : 'a field_type * 'a option -> field (** Module parsing steps *) @@ -1519,95 +1529,125 @@ type 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 + | MKField : 'a field_type * size * 'a lazy_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 + | MKElaborateFunc : + var Vector.t * func Vector.t * func lazy_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 + | MKBuild of func Vector.t 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 + | MKStop of module_' (** Final step of the parsing, cannot reduce. *) + (* TODO (https://gitlab.com/tezos/tezos/-/issues/3120): actually, should be module_ *) + | MKImport of import_kont * pos * size * import lazy_vec_kont (** Import section parsing. *) - | MKExport of export_kont * pos * size * export vec_kont + | MKExport of export_kont * pos * size * export lazy_vec_kont (** Export section parsing. *) | MKGlobal of - global_type * int * instr_block_kont list * size * global vec_kont + global_type * int * instr_block_kont list * size * global lazy_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 + | MKElem of elem_kont * int * size * elem_segment lazy_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 + | MKData of data_kont * int * size * data_segment lazy_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 + | MKCode of code_kont * int * size * func lazy_vec_kont (** Code section parsing, containing the current function parsing continuation, the starting position of the current function, the size of the section. *) type decode_kont = { - building_state : field list; (** Accumulated parsed sections. *) + building_state : field Vector.t; (** Accumulated parsed sections. *) module_kont : module_kont; stream : stream; } -let rec find_vec : type t. t field_type -> _ -> t list * int = - fun ty fields -> - match fields with - | [] -> assert false - | SingleField _ :: rest -> find_vec ty rest - | VecField (ty', v, len) :: rest -> ( - let v = (v, len) in - match (ty, ty') with - (* TODO (#3120): factor this out with a Leibnitz equality witness *) - | TypeField, TypeField -> v - | ImportField, ImportField -> v - | FuncField, FuncField -> v - | TableField, TableField -> v - | MemoryField, MemoryField -> v - | GlobalField, GlobalField -> v - | ExportField, ExportField -> v - | StartField, StartField -> v - | ElemField, ElemField -> v - | DataCountField, DataCountField -> v - | CodeField, CodeField -> v - | DataField, DataField -> v - | _ -> find_vec ty rest) - -let rec find_single : type t. t field_type -> _ -> t option = - fun ty fields -> - match fields with - | [] -> assert false - | VecField _ :: rest -> find_single ty rest - | SingleField (ty', v) :: rest -> ( - match (ty, ty') with - | TypeField, TypeField -> v - | ImportField, ImportField -> v - | FuncField, FuncField -> v - | TableField, TableField -> v - | MemoryField, MemoryField -> v - | GlobalField, GlobalField -> v - | ExportField, ExportField -> v - | StartField, StartField -> v - | ElemField, ElemField -> v - | DataCountField, DataCountField -> v - | CodeField, CodeField -> v - | DataField, DataField -> v - | _ -> find_single ty rest) +(* TODO: https://gitlab.com/tezos/tezos/-/issues/3366 + Check the size of the proof generated after calling `find_vec'`. *) +let rec find_vec' : + type t. t field_type -> int32 -> _ Vector.t -> t Vector.t Lwt.t = + fun ty index fields -> + (* This function is called once the whole module has been parsed. As such + each module section is available and it cannot fail. *) + let open Lwt.Syntax in + if Vector.num_elements fields <= index then invalid_arg "find_vec" + else + let* field = Vector.get index fields in + match field with + | SingleField _ -> find_vec' ty (Int32.add index 1l) fields + | VecField (ty', v) -> ( + let v = Lwt.return v in + match (ty, ty') with + (* TODO (https://gitlab.com/tezos/tezos/-/issues/3120): + factor this out with a Leibnitz equality witness *) + | TypeField, TypeField -> v + | ImportField, ImportField -> v + | FuncField, FuncField -> v + | TableField, TableField -> v + | MemoryField, MemoryField -> v + | GlobalField, GlobalField -> v + | ExportField, ExportField -> v + | StartField, StartField -> v + | ElemField, ElemField -> v + | DataCountField, DataCountField -> v + | CodeField, CodeField -> v + | DataField, DataField -> v + | _ -> find_vec' ty (Int32.succ index) fields) + +(* TODO: https://gitlab.com/tezos/tezos/-/issues/3366 + Check the size of the proof generated after calling `find_single'`. *) +let rec find_single' : + type t. t field_type -> int32 -> _ Vector.t -> t option Lwt.t = + fun ty index fields -> + (* This function is called once the whole module has been parsed. As such + each module section is available and it cannot fail. *) + let open Lwt.Syntax in + if Vector.num_elements fields <= index then invalid_arg "find_single" + else + let* field = Vector.get index fields in + match field with + | VecField _ -> find_single' ty (Int32.add index 1l) fields + | SingleField (ty', v) -> ( + let v = Lwt.return v in + match (ty, ty') with + | TypeField, TypeField -> v + | ImportField, ImportField -> v + | FuncField, FuncField -> v + | TableField, TableField -> v + | MemoryField, MemoryField -> v + | GlobalField, GlobalField -> v + | ExportField, ExportField -> v + | StartField, StartField -> v + | ElemField, ElemField -> v + | DataCountField, DataCountField -> v + | CodeField, CodeField -> v + | DataField, DataField -> v + | _ -> find_single' ty (Int32.succ index) fields) + +let find_vec ty fields = find_vec' ty 0l fields + +let find_single ty fields = find_single' ty 0l fields + +let vec_field ty (Lazy_vec {vector; _}) = VecField (ty, vector) let module_step state = - let next module_kont = {state with module_kont} in + let open Lwt.Syntax in + let next module_kont = Lwt.return {state with module_kont} in let next_with_field field module_kont = - {state with building_state = field :: state.building_state; module_kont} + Lwt.return + { + state with + building_state = Vector.cons field state.building_state; + module_kont; + } in let s = state.stream in match state.module_kont with @@ -1634,16 +1674,17 @@ let module_step state = | _ -> ( match k with | None -> - let func_types, func_types_len = - find_vec FuncField state.building_state - in - let func_bodies, func_bodies_len = - find_vec CodeField state.building_state - in - - next - @@ MKElaborateFunc - (func_types, func_bodies, Collect (func_types_len, []), true) + let* func_types = find_vec FuncField state.building_state in + let* func_bodies = find_vec CodeField state.building_state in + if Vector.(num_elements func_types <> num_elements func_bodies) + then next @@ MKBuild (None, true) + else + next + @@ MKElaborateFunc + ( func_types, + func_bodies, + init_lazy_vec (Vector.num_elements func_types), + true ) | Some (ty, tag) -> next @@ MKFieldStart (ty, tag))) | MKFieldStart (DataCountField, `DataCountSection) -> let v = data_count_section s in @@ -1655,10 +1696,7 @@ let module_step state = next_with_field (SingleField (StartField, v)) (MKSkipCustom (Some (ElemField, `ElemSection))) - (* Parsing of vectors. Fields reduce into two mutual steps: - - First collecting the elements from the vector into a list - - Then once everything as been parsed, reverse the list - *) + (* Parsing of fields vector. *) | MKFieldStart (ty, tag) -> ( match id s with | Some t when t = tag -> @@ -1666,192 +1704,161 @@ let module_step state = let size = size s in (* length of `vec` *) let l = len32 s in - next @@ MKField (ty, size, Collect (l, [])) + next @@ MKField (ty, size, init_lazy_vec (Int32.of_int l)) | _ -> let size = {size = 0; start = pos s} in - next @@ MKField (ty, size, Rev ([], [], 0))) - | MKField (ty, size, Collect (0, l)) -> - next @@ MKField (ty, size, Rev (l, [], 0)) - | MKField (ty, size, Collect (n, l)) -> ( + next @@ MKField (ty, size, init_lazy_vec 0l) + (* Transitions steps from the end of a section to the next one. + + The values accumulated from the section are accumulated into the building + state..*)) + (* TODO (https://gitlab.com/tezos/tezos/-/issues/3120): maybe we can factor-out these similarly shaped module section transitions *) + | MKField (TypeField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field TypeField vec) + (MKSkipCustom (Some (ImportField, `ImportSection))) + | MKField (ImportField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field ImportField vec) + (MKSkipCustom (Some (FuncField, `FuncSection))) + | MKField (FuncField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field FuncField vec) + (MKSkipCustom (Some (TableField, `TableSection))) + | MKField (TableField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field TableField vec) + (MKSkipCustom (Some (MemoryField, `MemorySection))) + | MKField (MemoryField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field MemoryField vec) + (MKSkipCustom (Some (GlobalField, `GlobalSection))) + | MKField (GlobalField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field GlobalField vec) + (MKSkipCustom (Some (ExportField, `ExportSection))) + | MKField (ExportField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field ExportField vec) + (MKSkipCustom (Some (StartField, `StartSection))) + | MKField (ElemField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field ElemField vec) + (MKSkipCustom (Some (DataCountField, `DataCountSection))) + | MKField (CodeField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field CodeField vec) + (MKSkipCustom (Some (DataField, `DataSection))) + | MKField (DataField, size, vec) when is_end_of_vec vec -> + check_size size s ; + next_with_field + (vec_field DataField vec) + (* All sections are parsed, time to build the module *) + (MKSkipCustom None) + | MKField (ty, size, vec) -> ( match ty with | TypeField -> let f = type_ s in - (* TODO (#3096): check if small enough to fit in a tick *) - next @@ MKField (ty, size, Collect (n - 1, f :: l)) - | ImportField -> next @@ MKImport (ImpKStart, pos s, size, Collect (n, l)) + (* TODO (https://gitlab.com/tezos/tezos/-/issues/3096): check if small enough to fit in a tick *) + next @@ MKField (ty, size, lazy_vec_step f vec) + | ImportField -> next @@ MKImport (ImpKStart, pos s, size, vec) | FuncField -> let f = at var s in (* small enough to fit in a tick *) - next @@ MKField (ty, size, Collect (n - 1, f :: l)) + next @@ MKField (ty, size, lazy_vec_step f vec) | TableField -> let f = at table s in (* small enough to fit in a tick *) - next @@ MKField (ty, size, Collect (n - 1, f :: l)) + next @@ MKField (ty, size, lazy_vec_step f vec) | MemoryField -> let f = at memory s in (* small enough to fit in a tick *) - next @@ MKField (ty, size, Collect (n - 1, f :: l)) + next @@ MKField (ty, size, lazy_vec_step f vec) | GlobalField -> let gtype = global_type s in - next @@ MKGlobal (gtype, pos s, [IKNext []], size, Collect (n, l)) - | ExportField -> next @@ MKExport (ExpKStart, pos s, size, Collect (n, l)) + next @@ MKGlobal (gtype, pos s, [IKNext []], size, vec) + | ExportField -> next @@ MKExport (ExpKStart, pos s, size, vec) | StartField -> (* not a vector *) assert false - | ElemField -> next @@ MKElem (EKStart, pos s, size, Collect (n, l)) + | ElemField -> next @@ MKElem (EKStart, pos s, size, vec) | DataCountField -> (* not a vector *) assert false - | CodeField -> next @@ MKCode (CKStart, pos s, size, Collect (n, l)) - | DataField -> next @@ MKData (DKStart, pos s, size, Collect (n, l))) + | CodeField -> next @@ MKCode (CKStart, pos s, size, vec) + | DataField -> next @@ MKData (DKStart, pos s, size, vec)) (* These sections have a distinct step mechanism. *) - | MKImport (ImpKStop import, left, size, Collect (n, l)) -> + | MKImport (ImpKStop import, left, size, vec) -> let f = Source.(import @@ region s left (pos s)) in - next @@ MKField (ImportField, size, Collect (n - 1, f :: l)) - | MKImport (_, _, _, Rev (_, _, _)) -> - (* Impossible case, there's no need for reversal. *) - assert false + next @@ MKField (ImportField, size, lazy_vec_step f vec) | MKImport (k, pos, size, curr_vec) -> next @@ MKImport (import_step s k, pos, size, curr_vec) - | MKExport (ExpKStop import, left, size, Collect (n, l)) -> + | MKExport (ExpKStop import, left, size, vec) -> let f = Source.(import @@ region s left (pos s)) in - next @@ MKField (ExportField, size, Collect (n - 1, f :: l)) - | MKExport (_, _, _, Rev (_, _, _)) -> - (* Impossible case, there's no need for reversal. *) - assert false + next @@ MKField (ExportField, size, lazy_vec_step f vec) | MKExport (k, pos, size, curr_vec) -> next @@ MKExport (export_step s k, pos, size, curr_vec) - | MKGlobal (gtype, left, [IKStop res], size, Collect (n, l)) -> + | MKGlobal (gtype, left, [IKStop res], size, vec) -> end_ s ; let ginit = Source.(res @@ region s left (pos s)) in let f = Source.({gtype; ginit} @@ region s left (pos s)) in - next @@ MKField (GlobalField, size, Collect (n - 1, f :: l)) - | MKGlobal (ty, pos, [IKStop res], _, Rev (_, _, _)) -> - (* Impossible case, there's no need for reversal. *) - assert false + next @@ MKField (GlobalField, size, lazy_vec_step f vec) | MKGlobal (ty, pos, k, size, curr_vec) -> next @@ MKGlobal (ty, pos, instr_block_step s k, size, curr_vec) - | MKElem (EKStop elem, left, size, Collect (n, l)) -> + | MKElem (EKStop elem, left, size, vec) -> let elem = Source.(elem @@ region s left (pos s)) in - next @@ MKField (ElemField, size, Collect (n - 1, elem :: l)) - | MKElem (EKStop _, _, _, Rev _) -> - (* Impossible case, there's no need for reversal. *) - assert false + next @@ MKField (ElemField, size, lazy_vec_step elem vec) | MKElem (elem_kont, pos, size, curr_vec) -> next @@ MKElem (elem_step s elem_kont, pos, size, curr_vec) - | MKData (DKStop data, left, size, Collect (n, l)) -> + | MKData (DKStop data, left, size, vec) -> let data = Source.(data @@ region s left (pos s)) in - next @@ MKField (DataField, size, Collect (n - 1, data :: l)) - | MKData (DKStop _, _, _, Rev _) -> - (* Impossible case, there's no need for reversal. *) - assert false + next @@ MKField (DataField, size, lazy_vec_step data vec) | MKData (data_kont, pos, size, curr_vec) -> next @@ MKData (data_step s data_kont, pos, size, curr_vec) - | MKCode (CKStop func, left, size, Collect (n, l)) -> - next @@ MKField (CodeField, size, Collect (n - 1, func :: l)) - | MKCode (CKStop _, _, _, Rev _) -> - (* Impossible case, there's no need for reversal. *) - assert false + | MKCode (CKStop func, left, size, vec) -> + next @@ MKField (CodeField, size, lazy_vec_step func vec) | MKCode (code_kont, pos, size, curr_vec) -> next @@ MKCode (code_step s code_kont, pos, size, curr_vec) - (* Transitions steps from the end of a section to the next one. - - The values accumulated from the section are accumulated into the `Next` - continuation that will be used to build the module.*) - | MKField (ty, size, Rev (f :: l, fs, len)) -> - next @@ MKField (ty, size, Rev (l, f :: fs, len + 1)) - (* TODO: maybe we can factor-out these similarly shaped module section transitions *) - | MKField (TypeField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (TypeField, l, len)) - (MKSkipCustom (Some (ImportField, `ImportSection))) - | MKField (ImportField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (ImportField, l, len)) - (MKSkipCustom (Some (FuncField, `FuncSection))) - | MKField (FuncField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (FuncField, l, len)) - (MKSkipCustom (Some (TableField, `TableSection))) - | MKField (TableField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (TableField, l, len)) - (MKSkipCustom (Some (MemoryField, `MemorySection))) - | MKField (MemoryField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (MemoryField, l, len)) - (MKSkipCustom (Some (GlobalField, `GlobalSection))) - | MKField (GlobalField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (GlobalField, l, len)) - (MKSkipCustom (Some (ExportField, `ExportSection))) - | MKField (ExportField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (ExportField, l, len)) - (MKSkipCustom (Some (StartField, `StartSection))) - | MKField (ElemField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (ElemField, l, len)) - (MKSkipCustom (Some (DataCountField, `DataCountSection))) - | MKField (CodeField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (CodeField, l, len)) - (MKSkipCustom (Some (DataField, `DataSection))) - | MKField (DataField, size, Rev ([], l, len)) -> - check_size size s ; - next_with_field - (VecField (DataField, l, len)) - (* All sections are parsed, time to build the module *) - (MKSkipCustom None) - | MKElaborateFunc ([], _ :: _, _, no_datas_in_func) - | MKElaborateFunc (_ :: _, [], _, no_datas_in_func) -> - (* Impossible cases where the two does not have the same legnth, which is - checked earlier. *) - next @@ MKBuild (None, no_datas_in_func) - | MKElaborateFunc ([], [], Collect (_, func_types), no_datas_in_func) -> - next @@ MKElaborateFunc ([], [], Rev (func_types, [], 0), no_datas_in_func) - | MKElaborateFunc (ft :: fts, fb :: fbs, Collect (n, fbs'), no_datas_in_func) + | MKElaborateFunc + (ft, fb, (Lazy_vec {vector = func_types; _} as vec), no_datas_in_func) + when is_end_of_vec vec -> + next @@ MKBuild (Some func_types, no_datas_in_func) + | MKElaborateFunc (fts, fbs, (Lazy_vec {offset; _} as vec), no_datas_in_func) -> + let* ft = Vector.get offset fts in + let* fb = Vector.get offset fbs in + let fb' = Source.({fb.it with ftype = ft} @@ fb.at) in next @@ MKElaborateFunc ( fts, fbs, - Collect (n - 1, Source.({fb.it with ftype = ft} @@ fb.at) :: fbs'), - no_datas_in_func ) - | MKElaborateFunc (_, _, Rev ([], funcs, _), no_datas_in_func) -> - next @@ MKBuild (Some funcs, no_datas_in_func) - | MKElaborateFunc (fts, fbs, Rev (f :: l, l', len), no_datas_in_func) -> - next - @@ MKElaborateFunc - ( fts, - fbs, - Rev (l, f :: l', len + 1), - no_datas_in_func && Free.((func f).datas = Set.empty) ) + lazy_vec_step fb' vec, + no_datas_in_func && Free.((func fb').datas = Set.empty) ) | MKBuild (funcs, no_datas_in_func) -> let fields = state.building_state in - let types, _ = find_vec TypeField fields in - let data_count = find_single DataCountField fields in - let datas, datas_len = find_vec DataField fields in - let elems, _ = find_vec ElemField fields in - let start = find_single StartField fields in - let tables, _ = find_vec TableField fields in - let memories, _ = find_vec MemoryField fields in - let globals, _ = find_vec GlobalField fields in - let imports, _ = find_vec ImportField fields in - let exports, _ = find_vec ExportField fields in + let* types = find_vec TypeField fields in + let* data_count = find_single DataCountField fields in + let* datas = find_vec DataField fields in + let* elems = find_vec ElemField fields in + let* start = find_single StartField fields in + let* tables = find_vec TableField fields in + let* memories = find_vec MemoryField fields in + let* globals = find_vec GlobalField fields in + let* imports = find_vec ImportField fields in + let* exports = find_vec ExportField fields in ignore types ; require (pos s = len s) s (len s) "unexpected content after last section" ; require - (data_count = None || data_count = Some (I32.of_int_s datas_len)) + (data_count = None || data_count = Some (Vector.num_elements datas)) s (len s) "data count and data section have inconsistent lengths" ; @@ -1871,39 +1878,44 @@ let module_step state = "data count section required" ; { state with - building_state = []; + building_state = Vector.create 0l; + (* At this point, there shouldn't be any new fields added, we can safely + reset the building state. *) module_kont = MKStop { - (* Parse directly into the Lazy_maps *) - types = types |> Vector.of_list; - tables = tables |> Vector.of_list; - memories = memories |> Vector.of_list; - globals = globals |> Vector.of_list; - funcs = funcs |> Vector.of_list; - imports = imports |> Vector.of_list; - exports = exports |> Vector.of_list; - elems = elems |> Vector.of_list; - datas = datas |> Vector.of_list; + types; + tables; + memories; + globals; + funcs; + imports; + exports; + elems; + datas; start; }; } - | MKField (StartField, _, _) -> - (* StarField is not a vector. *) - assert false - | MKField (DataCountField, _, _) -> - (* DataCountField is not a vector. *) - assert false + |> Lwt.return | MKStop _ (* Stop cannot reduce. *) -> assert false let module_ stream = + let open Lwt.Syntax in let rec loop = function - | {module_kont = MKStop m; _} -> m - | k -> loop (module_step k) + | {module_kont = MKStop m; _} -> Lwt.return m + | k -> + let* next_state = module_step k in + loop next_state in - loop {building_state = []; module_kont = MKStart; stream} + loop {building_state = Vector.create 0l; module_kont = MKStart; stream} -let decode ~name ~bytes = at module_ (make_stream ~name ~bytes) +let decode ~name ~bytes = + let open Lwt.Syntax in + let s = make_stream ~name ~bytes in + let left = pos s in + let+ m = module_ s in + let right = pos s in + Source.(m @@ region s left right) let all_custom tag s = let header = u32 s in diff --git a/src/lib_webassembly/binary/decode.mli b/src/lib_webassembly/binary/decode.mli index c8094c989dbb..00d111022c33 100644 --- a/src/lib_webassembly/binary/decode.mli +++ b/src/lib_webassembly/binary/decode.mli @@ -1,3 +1,5 @@ +module Vector = Lazy_vector.LwtInt32Vector + exception Code of Source.region * string (** Instruction parsing continuations. *) @@ -26,6 +28,11 @@ type ('a, 'b) vec_map_kont = (** Vector accumulator without mapping. *) type 'a vec_kont = ('a, 'a) vec_map_kont +(** Lazy vector accumulator, with the current offset to write the next value in + the vector. *) +type 'a lazy_vec_kont = Lazy_vec of {offset : int32; vector : 'a Vector.t} + +(** Position of a value on the stream. *) type pos = private int (** Size checking version of {!sized} for CPS-style parsing. *) @@ -146,7 +153,7 @@ type _ 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 + | VecField : 'a field_type * 'a Vector.t -> field | SingleField : 'a field_type * 'a option -> field (** Module parsing steps *) @@ -156,43 +163,41 @@ type 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 + | MKField : 'a field_type * size * 'a lazy_vec_kont -> module_kont (** Section currently parsed, accumulating each element from the underlying vector. *) | MKElaborateFunc : - Ast.var list * Ast.func list * Ast.func vec_kont * bool + Ast.var Vector.t * Ast.func Vector.t * Ast.func lazy_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 Ast.func list option * bool + | MKBuild of Ast.func Vector.t option * bool (** Accumulating the parsed sections vectors into a module and checking invariants. *) | MKStop of Ast.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 * Ast.import vec_kont + | MKImport of import_kont * pos * size * Ast.import lazy_vec_kont (** Import section parsing. *) - | MKExport of export_kont * pos * size * Ast.export vec_kont + | MKExport of export_kont * pos * size * Ast.export lazy_vec_kont (** Export section parsing. *) | MKGlobal of Types.global_type * int * instr_block_kont list * size - * Ast.global vec_kont + * Ast.global lazy_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 * Ast.elem_segment vec_kont + | MKElem of elem_kont * int * size * Ast.elem_segment lazy_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 * Ast.data_segment vec_kont + | MKData of data_kont * int * size * Ast.data_segment lazy_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 * Ast.func vec_kont + | MKCode of code_kont * int * size * Ast.func lazy_vec_kont (** Code section parsing, containing the current function parsing continuation, the starting position of the current function, the size of the section. *) @@ -202,7 +207,7 @@ type stream = {name : string; bytes : string; pos : pos ref} (** Decoding continuation step. *) type decode_kont = { - building_state : field list; + building_state : field Vector.t; (** Accumulated parsed sections, used to build the final module. *) module_kont : module_kont; (** Module continuation. *) stream : stream; (** Parsed stream. *) @@ -214,12 +219,12 @@ val make_stream : name:string -> bytes:string -> stream (** [module_step kont] takes one step of parsing from a continuation and returns a new continuation. Fails when the contination of the module is [MKStop] since it cannot reduce. *) -val module_step : decode_kont -> decode_kont +val module_step : decode_kont -> decode_kont Lwt.t (** [decode ~name ~bytes] decodes a module [name] from its [bytes] encoding. @raise Code on parsing errors. *) -val decode : name:string -> bytes:string -> Ast.module_ +val decode : name:string -> bytes:string -> Ast.module_ Lwt.t (** [decode ~name ~bytes] decodes a custom section of name [name] from its [bytes] encoding. -- GitLab