diff --git a/src/lib_scoru_wasm/gather_floppies.ml b/src/lib_scoru_wasm/gather_floppies.ml index b5a9bf9ebd3ba12c514a8feb1e988f6ab3df6844..d3acb5e354038b3f003c9aa1e13ed5412a29ae33 100644 --- a/src/lib_scoru_wasm/gather_floppies.ml +++ b/src/lib_scoru_wasm/gather_floppies.ml @@ -29,25 +29,34 @@ open Wasm_pvm_sig Increase the SCORU message size limit, and bump value to be 4,096. *) let chunk_size = 4_000 -exception Malformed_origination_message of Data_encoding.Binary.read_error - -exception Malformed_inbox_message of Data_encoding.Binary.read_error - exception Compute_step_expected_input exception Set_input_step_expected_compute_step exception Encoding_error of Data_encoding.Binary.write_error -exception Malformed_input_info_record - -type internal_status = Gathering_floppies | Not_gathering_floppies +type internal_status = + | Gathering_floppies of Tezos_crypto.Signature.Public_key.t + | Not_gathering_floppies let internal_status_encoding = - Data_encoding.string_enum + let open Data_encoding in + union [ - ("GatheringFloppies", Gathering_floppies); - ("NotGatheringFloppies", Not_gathering_floppies); + case + (Tag 0) + ~title:"Gathering_floppies" + (obj2 + (req "kind" (constant "gathering_floppies")) + (req "public_key" Tezos_crypto.Signature.Public_key.encoding)) + (function Gathering_floppies pk -> Some ((), pk) | _ -> None) + (fun ((), pk) -> Gathering_floppies pk); + case + (Tag 1) + ~title:"Not_gathering_floppies" + (obj1 (req "kind" (constant "Not_gathering_floppies"))) + (function Not_gathering_floppies -> Some () | _ -> None) + (fun () -> Not_gathering_floppies); ] type chunk = bytes @@ -92,156 +101,112 @@ let origination_message_encoding = (* STORAGE KEYS *) +module type S = sig + include Wasm_pvm_sig.S + + module Internal_for_tests : sig + val initial_tree_from_boot_sector : empty_tree:tree -> string -> tree Lwt.t + end +end + module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : - Wasm_pvm_sig.S with type tree = T.tree = struct + S with type tree = T.tree = struct type tree = Wasm.tree - type 'a value = 'a Thunk.value - - module Thunk = Thunk.Make (T) - module Decoding = Tree_decoding.Make (T) - - (** The [state] type is a phantom type that is used to describe the - data model of our PVM instrumentation. That is, values of type - [state] are never constructed. On the contrary, we manipulate - values of type [state Thunk.t]. *) - type state = - (internal_status value * Tezos_crypto.Signature.Public_key.t value) - * string value - * input_info value - * Z.t value - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3362 - Replace the [lazy_list] with [Chunked_byte_vector] to compose - better with the [lib_webassembly]. *) - * bytes value Thunk.Lazy_list.t - - (** This [schema] decides how our data-model are encoded in a tree. *) - let state_schema : state Thunk.schema = - let open Thunk.Schema in - obj5 - (req - "pvm" - (obj2 - (req "status" @@ encoding internal_status_encoding) - (req "public-key" - @@ encoding Tezos_crypto.Signature.Public_key.encoding))) - (req "boot-sector" @@ encoding Data_encoding.string) - (req "last-input-info" @@ encoding input_info_encoding) - (req "internal-loading-kernel-tick" @@ encoding Data_encoding.n) - (req "durable" - @@ folders ["kernel"; "boot.wasm"] - @@ Thunk.Lazy_list.schema (encoding chunk_encoding)) - - (** [status_l] is a lens to access the current [internal_status] of - the instrumented PVM. The instrumented PVM is either in the - process of gathering floppies, or is done with this pre-boot - step. *) - let status_l : (state, internal_status value) Thunk.lens = - Thunk.(tup5_0 ^. tup2_0) - - (** [public_key_l] is a lens to access the public key incoming - chunks of kernel are expected to be signed with. The public key - is submitted in the [origination_message], and used as long as - the instrumented PVM is in the [Gather_floppies] state. *) - let public_key_l : - (state, Tezos_crypto.Signature.Public_key.t value) Thunk.lens = - Thunk.(tup5_0 ^. tup2_1) - - (** [boot_sector_l] is a lens to access the [origination_message] - provided at the origination of the rollup. This message is - either a complete kernel, or a chunk of a kernel with a public - key. *) - let boot_sector_l : (state, string value) Thunk.lens = Thunk.tup5_1 - - (** [last_input_info_l] is a lens to access the input that was last - provided to the PVM, along with some metadata. It is updated - after each chunk of kernel is received. *) - let last_input_info_l : (state, input_info value) Thunk.lens = Thunk.tup5_2 - - (** [interal_tick_l] is a lens to access the number of ticks - performed by the “gather floppies” instrumentation, before the - PVM starts its real execution. *) - let internal_tick_l : (state, Z.t value) Thunk.lens = Thunk.tup5_3 - - (** [chunks_l] is a lens to access the collection of chunks (saved - as a so-called [Thunk.Lazy_map.t]) already received by the - instrumented PVM. *) - let chunks_l : (state, bytes value Thunk.Lazy_list.t) Thunk.lens = - Thunk.tup5_4 - - (** [check_signature payload signature state] returns [true] iff - [signature] is a correct signature for [payload], that is, it - has been computed with the companion secret key of the public - key submitted in the [origination_message], and stored in - [state] (see {!public_key_l}). *) - let check_signature payload signature state = - let open Lwt_syntax in - let open Thunk.Syntax in - let*^ pk = state ^-> public_key_l in - return @@ Tezos_crypto.Signature.check pk signature payload - - (** [store_chunk state chunk] adds [chunk] in the collection of - chunks already collected by the instrumented PVM and stored in - [state] (see {!chunks_l}). *) - let store_chunk state chunk = - let open Lwt_syntax in - let open Thunk.Syntax in - let* chunks = state ^-> chunks_l in - let* _ = Thunk.Lazy_list.cons chunks chunk in - return () - - (** [store_bytes state bytes] slices [bytes] into individual chunks, - and adds them in the collection of chunks stored in [state] (see - {!store_chunk}). *) - let store_bytes state : bytes -> unit Lwt.t = - let rec aux bytes = - let open Lwt_syntax in - let open Thunk.Syntax in - let len = Bytes.length bytes in - let* chunks = state ^-> chunks_l in - if len = 0 then return () - else if len < chunk_size then - let* _ = Thunk.Lazy_list.cons chunks bytes in - return () - else - let chunk = Bytes.sub bytes 0 chunk_size in - let rst = Bytes.sub bytes chunk_size (len - chunk_size) in - let* _ = Thunk.Lazy_list.cons chunks chunk in - aux rst - in - aux - - (** [get_internal_ticks state] returns the number of ticks as stored - in [state], or [0] if the values has not been initialized - yet. *) - let get_internal_ticks state = - let open Lwt_syntax in - let open Thunk.Syntax in - let*^? tick = state ^-> internal_tick_l in - return @@ Option.value ~default:Z.zero tick + open Tezos_webassembly_interpreter + module Merklizer = + Tree_encoding_decoding.Make (Lazy_map.LwtIntMap) (Lazy_vector.LwtIntVector) + (Chunked_byte_vector.Lwt) + (T) + + (** The tick state of the [Gathering_floppies] instrumentation. *) + type state = { + internal_status : internal_status; + (** The instrumented PVM is either in the process of gathering + floppies, or is done with this pre-boot step. *) + last_input_info : input_info option; + (** This field is updated after each [read_input] step to + reflect the progression of the PVM. *) + kernel : Chunked_byte_vector.Lwt.t; + (** The kernel being incrementally loaded into memory. *) + internal_tick : Z.t; + (** A counter updated after each small step execution of the + PVM. *) + } + + let boot_sector_merklizer : string Merklizer.t = + Merklizer.(value ["boot-sector"] Data_encoding.string) + + let state_merklizer : state Merklizer.t = + let open Merklizer in + conv + (fun (internal_status, last_input_info, internal_tick, kernel) -> + {internal_status; last_input_info; internal_tick; kernel}) + (fun {internal_status; last_input_info; internal_tick; kernel} -> + (internal_status, last_input_info, internal_tick, kernel)) + @@ tup4 + ~flatten:true + (value ["gather-floppies"; "status"] internal_status_encoding) + (value ["gather-floppies"; "last-input-info"] + @@ Data_encoding.option input_info_encoding) + (value ["gather-floppies"; "internal-tick"] Data_encoding.n) + (scope ["durable"; "kernel"; "boot.wasm"] chunked_byte_vector) (** [increment_ticks state] increments the number of ticks as stored in [state], or set it to [1] in case it has not been initialized yet. *) let increment_ticks state = + {state with internal_tick = Z.succ state.internal_tick} + + type status = + | Halted of string + (** The PVM has not started yet, meaning the boot sector is + still to be interpreted as an [origination_message]. *) + | Running of state + (** The boot sector has been correctly interpreted, and the + PVM is running as expected. *) + | Broken of {current_tick : Z.t} + (** The boot sector was not a correctly encoded + [originatiom_message], causing the PVM to enter a broken + state. *) + + (** [broken_merklizer] is a partial schema to be used to encode the + number of ticks of the PVM when it is stuck. + + It only tries to fetch the current tick (with the same key as + the one used in [state_merklizer]. *) + let broken_merklizer = + Merklizer.value ["gather-floppies"; "internal-tick"] Data_encoding.n + + (** [read_state tree] fetches the current state of the PVM from + [tree]. *) + let read_state tree = let open Lwt_syntax in - let open Thunk.Syntax in - let* tick = get_internal_ticks state in - (state ^-> internal_tick_l) ^:= Z.succ tick + Lwt.catch + (fun () -> + (* First, we try to interpret [tree] as a [state]. *) + let+ state = Merklizer.decode state_merklizer tree in + Running state) + (fun _exn -> + Lwt.catch + (fun () -> + (* If it fails, it means the PVM may be stuck. *) + let+ current_tick = Merklizer.decode broken_merklizer tree in + Broken {current_tick}) + (fun _exn -> + (* In case both previous attempts have failed, it means + this is probably the very first tick of the PVM. *) + let+ boot_sector = Merklizer.decode boot_sector_merklizer tree in + Halted boot_sector)) (* PROCESS MESSAGES *) - (** [origination_kernel_loading_step state] processes and stores the - (potentially incomplete) kernel image contained in the - origination message. - - This message contains either the entire (small) kernel image or - the first chunk of it (see {!origination_message}). *) - let origination_kernel_loading_step state = - let open Lwt_syntax in - let open Thunk.Syntax in - let* () = increment_ticks state in - let*^ boot_sector = state ^-> boot_sector_l in + (** [origination_kernel_loading_step boot_sector] implements the + tick consisting in initializing the [state] of the PVM from the + [boot_sector] supplied at origination time, or [None] iff + [boot_sector] cannot be decoded as a valid + [origination_message]. *) + let origination_kernel_loading_step boot_sector = let boot_sector = Data_encoding.Binary.of_string_opt origination_message_encoding @@ -249,64 +214,93 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : in match boot_sector with | Some (Complete_kernel kernel) -> - let* () = store_bytes state kernel in - (state ^-> status_l) ^:= Not_gathering_floppies - | Some (Incomplete_kernel (chunk, _boot_pk)) - when Bytes.length chunk < chunk_size -> - (* Despite claiming the boot sector is not a complete kernel, - it is not large enough to fill a chunk. *) - let* () = store_chunk state chunk in - (state ^-> status_l) ^:= Not_gathering_floppies - | Some (Incomplete_kernel (chunk, boot_pk)) -> - let* () = store_chunk state chunk in - let* () = (state ^-> public_key_l) ^:= boot_pk in - (state ^-> status_l) ^:= Gathering_floppies - | None -> - (* TODO: Add a proper [status] constructor *) - return () - - (** [kernel_loading_step input_info message state] processes the - sub-sequent kernel image chunk encoded in [message], as part of - an input tick described by [input_info]. - - If the chunk is not strictly equal to [chunk_size], then it is - considered as the very last chunk of the kernel, meaning the - instrumented PVM will update its status to start the regular - execution of the PVM. An empty chunk is also allowed. *) - let kernel_loading_step input message state = - let open Lwt_syntax in - let open Thunk.Syntax in - let* () = (state ^-> last_input_info_l) ^:= input in - let* () = increment_ticks state in - if 0 < String.length message then + let kernel = Chunked_byte_vector.Lwt.of_bytes kernel in + Some + { + internal_status = Not_gathering_floppies; + last_input_info = None; + internal_tick = Z.one; + kernel; + } + | Some (Incomplete_kernel (chunk, _pk)) when Bytes.length chunk < chunk_size + -> + let kernel = Chunked_byte_vector.Lwt.of_bytes chunk in + Some + { + internal_status = Not_gathering_floppies; + last_input_info = None; + internal_tick = Z.one; + kernel; + } + | Some (Incomplete_kernel (chunk, pk)) -> + let kernel = Chunked_byte_vector.Lwt.of_bytes chunk in + Some + { + internal_status = Gathering_floppies pk; + last_input_info = None; + internal_tick = Z.one; + kernel; + } + | None -> None + + let read_floppy message = + let message_len = String.length message in + if 0 < message_len then (* It is safe to read the very first character stored in [message], that is [String.get] will not raise an exception. *) match ( String.get message 0, - Data_encoding.Binary.read - floppy_encoding - message - 1 - (String.length message - 1) ) + Data_encoding.Binary.read floppy_encoding message 1 (message_len - 1) + ) with - | '\001', Ok (_, {chunk; signature}) -> - let* check = check_signature chunk signature state in - if check then - let* () = - if 0 < Bytes.length chunk then store_chunk state chunk - else return () - in - if Bytes.length chunk < chunk_size then - (state ^-> status_l) ^:= Not_gathering_floppies - else return () - else return () - | '\001', Error error -> raise (Malformed_inbox_message error) - | _, _ -> - (* [message] is not an external message (its tag is not - [0x01]), that is it is not a valid input. *) - return () + | '\001', Ok (_offset, floppy) -> Some floppy + | '\001', Error _error -> None + | _, _ -> None else (* [message] is empty, that is it is not a valid input. *) - return () + None + + (** [process_input_step input message state] interprets the incoming + [message] as part of the input tick characterized by + [input_info], and computes a new state for the instrumented PVM. + + It is expected that the instrumented PVM is expected to gather + floppies, that is [exists pk. state.status = Gathering_floppies + pk]. + + If the chunk encoded in [message] is not strictly equal to + {!chunk_size}, the instrumented PVM will consider the kernel to + be completed, and switch to [Not_gathering_floppies]. *) + let process_input_step input message state = + let open Lwt_syntax in + match state.internal_status with + | Gathering_floppies pk -> ( + match read_floppy message with + | Some {chunk; signature} -> + let state = {state with last_input_info = Some input} in + let offset = Chunked_byte_vector.Lwt.length state.kernel in + let len = Bytes.length chunk in + if Tezos_crypto.Signature.check pk signature chunk then + let* () = + if 0 < len then ( + Chunked_byte_vector.Lwt.grow state.kernel (Int64.of_int len) ; + Chunked_byte_vector.Lwt.store_bytes state.kernel offset chunk) + else return_unit + in + return + { + state with + internal_status = + (if len < chunk_size then Not_gathering_floppies + else state.internal_status); + } + else + (* The incoming message does not come with a correct + signature: we ignore it. *) + return state + | None -> + (* [message] is empty, that is it is not a valid input. *) + return state) + | Not_gathering_floppies -> raise (Invalid_argument "process_input_step") (* Encapsulated WASM *) @@ -314,7 +308,7 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : current status of the PVM. {ul - {li If the status has not yet been initialized, it means it is + {li If the state has not yet been initialized, it means it is the very first step of the rollup, and we interpret the [origination_message] that was provided at origination time.} @@ -326,15 +320,22 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : [Wasm.compute_step] is called.}} *) let compute_step tree = let open Lwt_syntax in - let open Thunk.Syntax in - let state = Thunk.decode state_schema tree in - let*^? status = state ^-> status_l in - match status with - | Some Gathering_floppies -> raise Compute_step_expected_input - | Some Not_gathering_floppies -> Wasm.compute_step tree - | None -> - let* () = origination_kernel_loading_step state in - Thunk.encode tree state + let* state = read_state tree in + match state with + | Broken {current_tick} -> + Merklizer.encode broken_merklizer (Z.succ current_tick) tree + | Halted origination_message -> ( + match origination_kernel_loading_step origination_message with + | Some state -> Merklizer.encode state_merklizer state tree + | None -> + (* We could not interpret [origination_message], + meaning the PVM is stuck. *) + Merklizer.encode broken_merklizer Z.one tree) + | Running state -> ( + let state = increment_ticks state in + match state.internal_status with + | Gathering_floppies _ -> raise Compute_step_expected_input + | Not_gathering_floppies -> Wasm.compute_step tree) (** [set_input_step input message tree] instruments [Wasm.set_input_step] to interpret incoming input messages as @@ -347,57 +348,72 @@ module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : the origination message has yet to be interpreted. *) let set_input_step input message tree = let open Lwt_syntax in - let open Thunk.Syntax in - let state = Thunk.decode state_schema tree in - let*^? status = state ^-> status_l in - match status with - | Some Gathering_floppies -> - let* () = kernel_loading_step input message state in - Thunk.encode tree state - | Some Not_gathering_floppies -> Wasm.set_input_step input message tree - | None -> raise Set_input_step_expected_compute_step + let* state = read_state tree in + match state with + | Halted _ | Broken _ -> raise Set_input_step_expected_compute_step + | Running state -> ( + let state = increment_ticks state in + match state.internal_status with + | Gathering_floppies _ -> + let* state = process_input_step input message state in + Merklizer.encode state_merklizer state tree + | Not_gathering_floppies -> Wasm.set_input_step input message tree) let get_output = Wasm.get_output let get_info tree = let open Lwt_syntax in - let open Thunk.Syntax in - let state = Thunk.decode state_schema tree in - let*^? status = state ^-> status_l in - let* ticks = get_internal_ticks state in - let*^? last_boot_read = state ^-> last_input_info_l in - match status with - | Some Gathering_floppies -> + let* state = read_state tree in + match state with + | Broken {current_tick} -> return { - current_tick = ticks; - last_input_read = last_boot_read; - input_request = Input_required; - } - | Some Not_gathering_floppies -> - let* inner_info = Wasm.get_info tree in - return - { - inner_info with - current_tick = - (* We consider [Wasm] as a black box. In particular, we - don’t know where [Wasm] is storing the number of - internal ticks it has interpreted, hence the need to - add both tick counters (the one introduced by our - instrumentation, and the one maintained by - [Wasm]). *) - Z.(add inner_info.current_tick ticks); - last_input_read = - Option.fold - ~none:last_boot_read - ~some:(fun x -> Some x) - inner_info.last_input_read; + current_tick; + last_input_read = None; + input_request = No_input_required; } - | None -> + | Halted _ -> return { - current_tick = ticks; + current_tick = Z.zero; last_input_read = None; input_request = No_input_required; } + | Running state -> ( + match state.internal_status with + | Gathering_floppies _ -> + return + { + current_tick = state.internal_tick; + last_input_read = state.last_input_info; + input_request = Input_required; + } + | Not_gathering_floppies -> + let* inner_info = Wasm.get_info tree in + return + { + inner_info with + current_tick = + (* We consider [Wasm] as a black box. In particular, we + don’t know where [Wasm] is storing the number of + internal ticks it has interpreted, hence the need to + add both tick counters (the one introduced by our + instrumentation, and the one maintained by + [Wasm]). *) + Z.(add inner_info.current_tick state.internal_tick); + last_input_read = + Option.fold + ~none:state.last_input_info + ~some:(fun x -> Some x) + inner_info.last_input_read; + }) + + module Internal_for_tests = struct + let initial_tree_from_boot_sector ~empty_tree boot_sector = + match origination_kernel_loading_step boot_sector with + | Some state -> Merklizer.encode state_merklizer state empty_tree + | None -> + raise + (Invalid_argument "initial_tree_from_boot_sector: wrong boot sector") + end end diff --git a/src/lib_scoru_wasm/gather_floppies.mli b/src/lib_scoru_wasm/gather_floppies.mli index 5af9e72ba01d763a422a7f6e618f6519259778d8..d78163ea7b234e8293dba2b3c88904165315d053 100644 --- a/src/lib_scoru_wasm/gather_floppies.mli +++ b/src/lib_scoru_wasm/gather_floppies.mli @@ -23,14 +23,6 @@ (* *) (*****************************************************************************) -(** Raised when the origination message contains neither a complete nor an - incomplete kernel message. *) -exception Malformed_origination_message of Data_encoding.Binary.read_error - -(** Raised when a message containing a kernel image chunk was expected, but - the message in the inbox contained something else. *) -exception Malformed_inbox_message of Data_encoding.Binary.read_error - (** Raised when [compute_step] was called when the floppy gathering module expected input. *) exception Compute_step_expected_input @@ -43,14 +35,12 @@ exception Set_input_step_expected_compute_step (** Generic internal error. Some data in storage had errornous encoding. *) exception Encoding_error of Data_encoding.Binary.write_error -(** Internal error. Raised if the [input_info] record that is stored somehow - gets overwritten with something malformed. *) -exception Malformed_input_info_record - (** The instrumented PVM is either in a pre-boot state ([Gathering_floppies]), or in its regular functioning state ([Not_gathering_floppies]). *) -type internal_status = Gathering_floppies | Not_gathering_floppies +type internal_status = + | Gathering_floppies of Tezos_crypto.Signature.Public_key.t + | Not_gathering_floppies val internal_status_encoding : internal_status Data_encoding.t @@ -65,14 +55,22 @@ type floppy = {chunk : chunk; signature : Tezos_crypto.Signature.t} val floppy_encoding : floppy Data_encoding.t type origination_message = - | Complete_kernel of chunk + | Complete_kernel of bytes | Incomplete_kernel of chunk * Tezos_crypto.Signature.Public_key.t val origination_message_encoding : origination_message Data_encoding.t +module type S = sig + include Wasm_pvm_sig.S + + module Internal_for_tests : sig + val initial_tree_from_boot_sector : empty_tree:tree -> string -> tree Lwt.t + end +end + (** [Make] encapsulates a WASM PVM to give it the ability to load a kernel image as either a complete kernel in the origination message or a kernel image divided into chunks and provided via both origination- and inbox- messages. *) module Make (T : Tree.S) (Wasm : Wasm_pvm_sig.S with type tree = T.tree) : - Wasm_pvm_sig.S with type tree = T.tree + S with type tree = T.tree diff --git a/src/lib_scoru_wasm/test/test_input.ml b/src/lib_scoru_wasm/test/test_input.ml index 5a942d6be8903dbb5ba9bb435fd6de985c2e8885..6f0d2535fc6544665f218742fa7368fc9f57defe 100644 --- a/src/lib_scoru_wasm/test/test_input.ml +++ b/src/lib_scoru_wasm/test/test_input.ml @@ -195,7 +195,9 @@ let current_tick_encoding = let status_encoding = EncDec.value ["input"; "consuming"] Data_encoding.bool let floppy_encoding = - EncDec.value ["pvm"; "status"] Gather_floppies.internal_status_encoding + EncDec.value + ["gather-floppies"; "status"] + Gather_floppies.internal_status_encoding let level_encoding = EncDec.value ["input"; "level"] Bounded.Int32.NonNegative.encoding @@ -214,7 +216,18 @@ let zero = [gather_floppies] *) let initialise_tree () = let open Lwt_syntax in - let* tree = Test_encoding.empty_tree () in + let* empty_tree = Test_encoding.empty_tree () in + let boot_sector = + Data_encoding.Binary.to_string_exn + Gather_floppies.origination_message_encoding + (Complete_kernel (Bytes.of_string "some boot sector")) + in + let* tree = + Wasm.Internal_for_tests.initial_tree_from_boot_sector + ~empty_tree + boot_sector + in + let* tree = EncDec.encode current_tick_encoding Z.zero tree in let* tree = EncDec.encode floppy_encoding Gather_floppies.Not_gathering_floppies tree @@ -240,7 +253,7 @@ let test_get_info () = let expected_info = let open Wasm_pvm_sig in let last_input_read = Some {inbox_level = zero; message_counter = Z.zero} in - {current_tick = Z.zero; last_input_read; input_request = Input_required} + {current_tick = Z.one; last_input_read; input_request = Input_required} in let* actual_info = Wasm.get_info tree in assert (actual_info.last_input_read = None) ; @@ -269,7 +282,11 @@ let test_set_input () = let expected_info = let open Wasm_pvm_sig in let last_input_read = Some {inbox_level = zero; message_counter = Z.zero} in - {current_tick = Z.one; last_input_read; input_request = No_input_required} + { + current_tick = Z.(succ one); + last_input_read; + input_request = No_input_required; + } in let* actual_info = Wasm.get_info tree in assert (actual_info = expected_info) ; diff --git a/src/lib_scoru_wasm/thunk.ml b/src/lib_scoru_wasm/thunk.ml deleted file mode 100644 index 8abcf5cc7008ba57c665cf9590432470b5e69b14..0000000000000000000000000000000000000000 --- a/src/lib_scoru_wasm/thunk.ml +++ /dev/null @@ -1,659 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* The use of polymorphic variant in these two (opaque) phantom types - is motivated by the need to circumvent warning 37 - ([unused-constructor]). *) - -type 'a value = [`Value of 'a] - -type ('a, 'b) dict = [`Dict of 'a * 'b] - -module Make (T : Tree.S) = struct - type tree = T.tree - - module Schema = struct - type 'a decoder = tree -> 'a option Lwt.t - - type 'a encoder = tree -> string list -> 'a -> tree Lwt.t - - type !'a t = {folders : string list; descr : 'a schema} - - and !'a schema = - | Value_s : 'a encoder * 'a decoder -> 'a value 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 - | Tup5_s : - 'a field * 'b field * 'c field * 'd field * 'e field - -> ('a * 'b * 'c * 'd * 'e) schema - | Dict_s : ('a -> string) * 'b t -> ('a, 'b) dict schema - - and !'a field = {directory : string; schema : 'a t} - - let encoding : 'a Data_encoding.t -> 'a value 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_syntax in - let* bytes = T.find tree [] in - match bytes with - | Some bytes -> - Lwt.return - @@ Some (Data_encoding.Binary.of_bytes_exn encoding bytes) - | None -> Lwt.return None - in - {folders = []; descr = Value_s (encoder, decoder)} - - let custom ~encoder ~decoder = - {folders = []; descr = Value_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 obj5 b1 b2 b3 b4 b5 = - {folders = []; descr = Tup5_s (b1, b2, b3, b4, b5)} - - let dict encoder schema = {folders = []; descr = Dict_s (encoder, schema)} - end - - type 'a schema = 'a Schema.t - - type !'a shallow = - | Shallow : tree option -> 'a shallow - (** [Shalow (Some tree)] encodes a piece of data that has not - been fetched from [tree]. [Shallow None] encodes a piece - of data that is absent from the original tree, or that has - been cut from the tree. *) - | 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 - | Tup5 : - 'a t * 'b t * 'c t * 'd t * 'e t - -> ('a * 'b * 'c * 'd * 'e) shallow - | Value : 'a -> 'a value shallow - | Dict : tree option * ('a * 'b t) list -> ('a, 'b) dict shallow - - and !'a t = {value : 'a shallow ref; schema : 'a schema} - - type !'a thunk = 'a t - - let shallow_t tree schema = {value = ref (Shallow tree); schema} - - 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 tree_prefix = prefix in - let value_prefix = thunk.schema.folders @ tree_prefix in - match (!(thunk.value), thunk.schema.descr) with - | Shallow (Some tree'), _ -> - let* tree = T.add_tree tree (List.rev tree_prefix) tree' in - return tree - | Shallow None, _ -> - let* tree = T.remove tree (List.rev tree_prefix) in - return tree - | Value x, Value_s (encoder, _) -> - let* tree = encoder tree (List.rev value_prefix) x in - return tree - | Dict (Some tree', assoc), Dict_s (key_encoder, _schema) -> - let* tree' = - Lwt_list.fold_left_s - (fun tree' (k, v) -> - encode (key_encoder k :: thunk.schema.folders) tree' v) - tree' - assoc - in - let* tree = T.add_tree tree (List.rev tree_prefix) tree' in - return tree - | Dict (None, assoc), Dict_s (key_encoder, _schema) -> - let* tree = T.remove tree (List.rev tree_prefix) in - let* tree = - Lwt_list.fold_left_s - (fun tree (k, v) -> encode (key_encoder k :: value_prefix) tree v) - tree - assoc - in - return tree - | Tup2 (x, y), Tup2_s (fst, snd) -> - let* tree = encode (fst.directory :: value_prefix) tree x in - let* tree = encode (snd.directory :: value_prefix) tree y in - return tree - | Tup3 (x, y, z), Tup3_s (fst, snd, thd) -> - let* tree = encode (fst.directory :: value_prefix) tree x in - let* tree = encode (snd.directory :: value_prefix) tree y in - let* tree = encode (thd.directory :: value_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 :: value_prefix) tree a in - let* tree = encode (b_s.directory :: value_prefix) tree b in - let* tree = encode (c_s.directory :: value_prefix) tree c in - let* tree = encode (d_s.directory :: value_prefix) tree d in - return tree - | Tup5 (a, b, c, d, e), Tup5_s (a_s, b_s, c_s, d_s, e_s) -> - let* tree = encode (a_s.directory :: value_prefix) tree a in - let* tree = encode (b_s.directory :: value_prefix) tree b in - let* tree = encode (c_s.directory :: value_prefix) tree c in - let* tree = encode (d_s.directory :: value_prefix) tree d in - let* tree = encode (e_s.directory :: value_prefix) tree e in - return tree - in - encode [] tree - - let find : type a. a value t -> a option Lwt.t = - fun thunk -> - let open Lwt_syntax in - match (!(thunk.value), thunk.schema.descr) with - | Value x, Value_s (_, _) -> return (Some x) - | Shallow (Some tree), Value_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 -> Value x | None -> Shallow None) ; - return x - | None -> return None) - | Shallow None, Value_s (_, _decoder) -> return None - - let get thunk = - let open Lwt_syntax in - let* x = find thunk in - match x with - | Some x -> return x - | None -> raise (Invalid_argument "get: missing value") - - let set : type a. a value t -> a -> unit = - fun thunk x -> - match !(thunk.value) with Value _ | Shallow _ -> thunk.value := Value x - - let cut : type a. a t -> unit = fun thunk -> thunk.value := Shallow None - - type ('a, 'b) lens = 'a thunk -> 'b thunk Lwt.t - - let ( ^. ) : ('a, 'b) lens -> ('b, 'c) lens -> ('a, 'c) lens = - fun l1 l2 thunk -> - let open Lwt_syntax in - let* thunk = l1 thunk in - l2 thunk - - let tup2_0 : type a b. (a * b, a) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix x.directory) in - let* tree_y = T.find_tree tree (prefix y.directory) 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 - - let tup2_1 : type a b. (a * b, b) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix x.directory) in - let* tree_y = T.find_tree tree (prefix y.directory) 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 - - let tup3_0 : type a b c. (a * b * c, a) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix x.directory) in - let* tree_y = T.find_tree tree (prefix y.directory) in - let* tree_z = T.find_tree tree (prefix z.directory) 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 - - let tup3_1 : type a b c. (a * b * c, b) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix x.directory) in - let* tree_y = T.find_tree tree (prefix y.directory) in - let* tree_z = T.find_tree tree (prefix z.directory) 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 - - let tup3_2 : type a b c. (a * b * c, c) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix x.directory) in - let* tree_y = T.find_tree tree (prefix y.directory) in - let* tree_z = T.find_tree tree (prefix z.directory) 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 - - let tup4_0 : type a b c d. (a * b * c * d, a) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) 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 - - let tup4_1 : type a b c d. (a * b * c * d, b) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) 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 - - let tup4_2 : type a b c d. (a * b * c * d, c) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) 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 - - let tup4_3 : type a b c d. (a * b * c * d, d) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) 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 (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) 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 - - let tup5_0 : type a b c d e. (a * b * c * d * e, a) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in - match (!(thunk.value), thunk.schema.descr) with - | Tup5 (a, _b, _c, _d, _e), _ -> return a - | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> - let* tree_a = T.find_tree tree (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) in - let* tree_e = T.find_tree tree (prefix e_f.directory) 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 - let e = shallow_t tree_e e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return a - | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_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 - let e = shallow_t None e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return a - - let tup5_1 : type a b c d e. (a * b * c * d * e, b) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in - match (!(thunk.value), thunk.schema.descr) with - | Tup5 (_a, b, _c, _d, _e), _ -> return b - | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> - let* tree_a = T.find_tree tree (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) in - let* tree_e = T.find_tree tree (prefix e_f.directory) 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 - let e = shallow_t tree_e e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return b - | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_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 - let e = shallow_t None e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return b - - let tup5_2 : type a b c d e. (a * b * c * d * e, c) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in - match (!(thunk.value), thunk.schema.descr) with - | Tup5 (_a, _b, c, _d, _e), _ -> return c - | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> - let* tree_a = T.find_tree tree (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) in - let* tree_e = T.find_tree tree (prefix e_f.directory) 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 - let e = shallow_t tree_e e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return c - | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_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 - let e = shallow_t None e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return c - - let tup5_3 : type a b c d e. (a * b * c * d * e, d) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in - match (!(thunk.value), thunk.schema.descr) with - | Tup5 (_a, _b, _c, d, _e), _ -> return d - | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> - let* tree_a = T.find_tree tree (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) in - let* tree_e = T.find_tree tree (prefix e_f.directory) 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 - let e = shallow_t tree_e e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return d - | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_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 - let e = shallow_t None e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return d - - let tup5_4 : type a b c d e. (a * b * c * d * e, e) lens = - fun thunk -> - let open Lwt_syntax in - let prefix dir = List.rev @@ (dir :: thunk.schema.folders) in - match (!(thunk.value), thunk.schema.descr) with - | Tup5 (_a, _b, _c, _d, e), _ -> return e - | Shallow (Some tree), Tup5_s (a_f, b_f, c_f, d_f, e_f) -> - let* tree_a = T.find_tree tree (prefix a_f.directory) in - let* tree_b = T.find_tree tree (prefix b_f.directory) in - let* tree_c = T.find_tree tree (prefix c_f.directory) in - let* tree_d = T.find_tree tree (prefix d_f.directory) in - let* tree_e = T.find_tree tree (prefix e_f.directory) 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 - let e = shallow_t tree_e e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return e - | Shallow None, Tup5_s (a_f, b_f, c_f, d_f, e_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 - let e = shallow_t None e_f.schema in - thunk.value := Tup5 (a, b, c, d, e) ; - return e - - let entry : type a b. a -> ((a, b) dict, b) lens = - fun k thunk -> - let open Lwt_syntax in - match (!(thunk.value), thunk.schema.descr) with - | Dict (Some tree, assoc), Dict_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 := Dict (Some tree, (k, v) :: assoc) ; - return v) - | Shallow (Some tree), Dict_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 := Dict (Some tree, [(k, v)]) ; - return v - | (Dict (None, []) | Shallow None), Dict_s (_encoder, schema) -> - let v = shallow_t None schema in - thunk.value := Dict (None, [(k, v)]) ; - return v - | Dict (None, assoc), Dict_s (_encoder, schema) -> ( - match List.assq_opt k assoc with - | Some v -> return v - | None -> - let v = shallow_t None schema in - thunk.value := Dict (None, (k, v) :: assoc) ; - return v) - - module Lazy_list = struct - type 'a t = int32 value * (int32, 'a) dict - - let schema : 'a schema -> 'a t schema = - fun schema -> - let open Schema in - obj2 - (req "len" @@ encoding Data_encoding.int32) - (req "contents" (dict Int32.to_string schema)) - - let length : 'a t thunk -> int32 Lwt.t = - fun thunk -> - let open Lwt_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_syntax in - let* c = length thunk in - if (not check) || idx < c then - (tup2_1 ^. entry Int32.(pred @@ sub c idx)) thunk - else - raise - (Invalid_argument - ("nth: index " ^ Int32.to_string idx ^ " out of bound")) - - let alloc_cons : 'a t thunk -> (int32 * 'a thunk) Lwt.t = - fun thunk -> - let open Lwt_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 value t thunk -> 'a -> int32 Lwt.t = - fun thunk x -> - let open Lwt_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_syntax in - let* x = x in - let* x = find x in - k x - - let ( let*^ ) x k = - let open Lwt_syntax in - let* x = x in - let* x = get x in - k x - - let ( ^:= ) x v = - let open Lwt_syntax in - let* x = x in - set x v ; - return () - end -end diff --git a/src/lib_scoru_wasm/thunk.mli b/src/lib_scoru_wasm/thunk.mli deleted file mode 100644 index f59b84326e63d9761dd66acb312a804683d125f1..0000000000000000000000000000000000000000 --- a/src/lib_scoru_wasm/thunk.mli +++ /dev/null @@ -1,165 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/3388 - Provide a docstring for every functions and types introduced by - this module. *) - -(** This module provides a means of transparently manipulating a - hierarchy of values stored in a tree. These values are lazily - loaded on demand, modified in-place, and then encoded back in the - tree once the computation is done. - - In a nutshell, a ['a thunk] is a lazily loaded collection of - values whose hierarchy is determined by ['a]. A ['a schema] is a - declarative description of your data model, that is how to encode - and decode your values. Developers familiar with [Data_encoding] - will find the API of [schema] familiar. Then, ['a lens] is a way - to traverse a [thunk], reading what’s needing from a tree, and - modifying in-place your datas. *) - -(** ['a value] denotes a value in a data-model of type ['a] that can be - read from and write to a tree. *) -type 'a value - -(** [('a, 'b) dict] denotes a dictionary in a data-model that - associates sub-hierarchies of value determined by type [b] to keys - of type [a] (said keys need to be serializable to [string]). *) -type ('a, 'b) dict - -module Make (T : Tree.S) : sig - type tree = T.tree - - module Schema : sig - type !'a t - - val encoding : 'a Data_encoding.t -> 'a value t - - val custom : - encoder:(tree -> string list -> 'a -> tree Lwt.t) -> - decoder:(tree -> 'a option Lwt.t) -> - 'a value 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 obj5 : - 'a field -> - 'b field -> - 'c field -> - 'd field -> - 'e field -> - ('a * 'b * 'c * 'd * 'e) t - - val dict : ('a -> string) -> 'b t -> ('a, 'b) dict 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 value thunk -> 'a option Lwt.t - - val get : 'a value thunk -> 'a Lwt.t - - val set : 'a value thunk -> 'a -> unit - - val cut : 'a thunk -> unit - - type ('a, 'b) lens = 'a thunk -> 'b thunk 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 tup5_0 : ('a * 'b * 'c * 'd * 'e, 'a) lens - - val tup5_1 : ('a * 'b * 'c * 'd * 'e, 'b) lens - - val tup5_2 : ('a * 'b * 'c * 'd * 'e, 'c) lens - - val tup5_3 : ('a * 'b * 'c * 'd * 'e, 'd) lens - - val tup5_4 : ('a * 'b * 'c * 'd * 'e, 'e) lens - - val entry : 'a -> (('a, 'b) dict, 'b) lens - - module Lazy_list : sig - type !'a t - - val schema : 'a schema -> 'a t schema - - val length : 'a t thunk -> int32 Lwt.t - - val nth : check:bool -> int32 -> ('a t, 'a) lens - - val alloc_cons : 'a t thunk -> (int32 * 'a thunk) Lwt.t - - val cons : 'a value t thunk -> 'a -> int32 Lwt.t - end - - module Syntax : sig - val ( ^-> ) : 'a thunk -> ('a, 'b) lens -> 'b thunk Lwt.t - - val ( let*^ ) : 'a value thunk Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t - - val ( let*^? ) : 'a value thunk Lwt.t -> ('a option -> 'b Lwt.t) -> 'b Lwt.t - - val ( ^:= ) : 'a value thunk Lwt.t -> 'a -> unit Lwt.t - end -end diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml index a630e509b5db63f0ea8dc5485294ac287b7c3e7a..1cc067a8b9c8da22739bdfe6de520f5ad6a171e2 100644 --- a/src/lib_scoru_wasm/wasm_pvm.ml +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -32,7 +32,7 @@ open Tezos_webassembly_interpreter -module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree = struct +module Make (T : Tree.S) : Gather_floppies.S with type tree = T.tree = struct include Gather_floppies.Make (T) diff --git a/src/lib_scoru_wasm/wasm_pvm.mli b/src/lib_scoru_wasm/wasm_pvm.mli index 02836dc26c6b00c022a183bfe201f52d0a9110c9..9fc5ddae55fc6c270160343330c0cc14c6ffd2ae 100644 --- a/src/lib_scoru_wasm/wasm_pvm.mli +++ b/src/lib_scoru_wasm/wasm_pvm.mli @@ -25,4 +25,4 @@ (** Builds a WASM VM given a concrete implementation of {!Tree.S}. *) -module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree +module Make (T : Tree.S) : Gather_floppies.S with type tree = T.tree diff --git a/src/lib_scoru_wasm/wasm_pvm_sig.ml b/src/lib_scoru_wasm/wasm_pvm_sig.ml index 0f8b00ba52490d60c055f5469c785f2474f7417f..43cf63465df26b2538716aaeb39acab8e512f3cb 100644 --- a/src/lib_scoru_wasm/wasm_pvm_sig.ml +++ b/src/lib_scoru_wasm/wasm_pvm_sig.ml @@ -63,8 +63,8 @@ module type S = sig (** [set_input_step] forwards the VM by one input tick. If the VM is not expecting input, it gets stuck. If the VM is already stuck, this function - may raise an exception. Note at this point the function raises an - exception if the VM is not expecting input. WHen we implement astuck + may raise an exception. Note at this point the function raises an + exception if the VM is not expecting input. WHen we implement astuck state this needs to be slightly changed.*) val set_input_step : input_info -> string -> tree -> tree Lwt.t diff --git a/src/lib_webassembly/util/chunked_byte_vector.ml b/src/lib_webassembly/util/chunked_byte_vector.ml index 2f0bfed5f8e1643e84d097801d65a17e7c6512c5..8a6e66153dd4ed610b20dc53cd05fa2404bf713f 100644 --- a/src/lib_webassembly/util/chunked_byte_vector.ml +++ b/src/lib_webassembly/util/chunked_byte_vector.ml @@ -74,7 +74,7 @@ module type S = sig val of_string : string -> t - val of_bytes : bytes -> t effect + val of_bytes : bytes -> t val to_string : t -> string effect @@ -109,7 +109,7 @@ module Make (Effect : Effect.S) : S with type 'a effect = 'a Effect.t = struct {length; chunks} let grow vector size_delta = - if Int64.compare size_delta 0L > 0 then ( + if 0L < size_delta then ( let new_size = Int64.add vector.length size_delta in let new_chunks = Chunk.num_needed new_size in let current_chunks = Vector.num_elements vector.chunks in @@ -175,9 +175,25 @@ module Make (Effect : Effect.S) : S with type 'a effect = 'a Effect.t = struct vector let of_bytes bytes = - let open Effect in - let vector = Bytes.length bytes |> Int64.of_int |> create in - let+ () = store_bytes vector 0L bytes in + (* See [of_string] heading comment *) + let len = Bytes.length bytes in + let vector = create (Int64.of_int len) in + let _ = + List.init + (Vector.num_elements vector.chunks |> Int64.to_int) + (fun index -> + let index = Int64.of_int index in + let chunk = Chunk.alloc () in + let _ = + List.init (Chunk.size |> Int64.to_int) (fun offset -> + let offset = Int64.of_int offset in + let address = Chunk.address ~index ~offset |> Int64.to_int in + if address < len then + let c = Bytes.get bytes address in + Array1_64.set chunk offset (Char.code c)) + in + Vector.set index chunk vector.chunks) + in vector let to_bytes vector = diff --git a/src/lib_webassembly/util/chunked_byte_vector.mli b/src/lib_webassembly/util/chunked_byte_vector.mli index eac710773f7f06b9e9e9ada9ad034dc2dda86549..9ec87bfcfb8b1ec3add572f74d3546ee90628155 100644 --- a/src/lib_webassembly/util/chunked_byte_vector.mli +++ b/src/lib_webassembly/util/chunked_byte_vector.mli @@ -45,7 +45,7 @@ module type S = sig underlying memory is effectively copied - further modifications to [bytes] are not reflected in the chunked byte vector. Use this over [of_string] when turning your [bytes] into a [string] would be potentially expensive. *) - val of_bytes : bytes -> t effect + val of_bytes : bytes -> t (** [to_string vector] creates a string from the given [vector]. *) val to_string : t -> string effect 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 b0619b5aa351e09d561361fee2c9d59edc788023..99ff45f6802fb5b97ce725d35b54e9d87e8ff5da 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 @@ -143,7 +143,7 @@ let checked_set_input ~loc context input s = let complete_boot_sector sector : Tezos_scoru_wasm.Gather_floppies.origination_message = - Complete_kernel (Bytes.of_string sector) + Complete_kernel sector let incomplete_boot_sector sector Account.{pk; _} : Tezos_scoru_wasm.Gather_floppies.origination_message = @@ -151,23 +151,26 @@ let incomplete_boot_sector sector Account.{pk; _} : let find tree key encoding = let open Lwt.Syntax in + Format.printf "f %s\n" (String.concat "/" key) ; let+ value = Context_binary.Tree.find tree key in match value with - | Some bytes -> Some (Data_encoding.Binary.of_bytes_exn encoding bytes) + | Some bytes -> + Format.printf "v %S\n" (Bytes.to_string bytes) ; + Some (Data_encoding.Binary.of_bytes_exn encoding bytes) | None -> None let find_status tree = find tree - ["pvm"; "status"] + ["gather-floppies"; "status"] Tezos_scoru_wasm.Gather_floppies.internal_status_encoding let get_chunks_count tree = let open Lwt.Syntax in let+ len = - find tree ["durable"; "kernel"; "boot.wasm"; "len"] Data_encoding.int32 + find tree ["durable"; "kernel"; "boot.wasm"; "length"] Data_encoding.int64 in - Option.value ~default:0l len + Option.fold ~none:0 ~some:Int64.to_int len let check_status tree expected = let open Lwt.Syntax in @@ -183,11 +186,7 @@ let check_chunks_count tree expected = let open Lwt.Syntax in let* count = get_chunks_count tree in if count = expected then Lwt_result.return () - else - failwith - "wrong chunks counter, expected %d, got %d" - (Int32.to_int expected) - (Int32.to_int count) + else failwith "wrong chunks counter, expected %d, got %d" expected count let operator () = match Account.generate_accounts 1 with @@ -200,12 +199,9 @@ let should_boot_complete_boot_sector boot_sector () = let*! index = Context_binary.init "/tmp" in let context = Context_binary.empty index in (* The number of chunks necessary to store the kernel. *) - let nb_chunk_i32 = + let boot_sector_len = match boot_sector with - | Complete_kernel bytes | Incomplete_kernel (bytes, _) -> - let len = Bytes.length bytes |> Int32.of_int in - let empty = if 0l < Int32.rem len 4_000l then 1l else 0l in - Int32.(add (div len 4_000l) empty) + | Complete_kernel bytes | Incomplete_kernel (bytes, _) -> Bytes.length bytes in let boot_sector = Data_encoding.Binary.to_string_exn origination_message_encoding boot_sector @@ -217,14 +213,14 @@ let should_boot_complete_boot_sector boot_sector () = "/boot-sector", and nothing more. As a consequence, most of the step of the [Gather_floppies] instrumentation is not set. *) let*! () = check_status s None in - let* () = check_chunks_count s 0l in + let* () = check_chunks_count s 0 in (* At this step, the [eval] function of the PVM will interpret the origination message encoded in [boot_sector]. *) let* s = checked_eval ~loc:__LOC__ context s in (* We expect that the WASM does not expect more floppies, and that the kernel as been correctly splitted into several chunks. *) let*! () = check_status s (Some Not_gathering_floppies) in - let* () = check_chunks_count s nb_chunk_i32 in + let* () = check_chunks_count s boot_sector_len in return_unit let floppy_input i operator chunk = @@ -269,13 +265,13 @@ let should_interpret_empty_chunk () = let*! s = Prover.install_boot_sector s origination_message in (* Intererptation of the origination message *) let* s = checked_eval ~loc:__LOC__ context s in - let*! () = check_status s (Some Gathering_floppies) in - let* () = check_chunks_count s 1l in + let*! () = check_status s (Some (Gathering_floppies op.pk)) in + let* () = check_chunks_count s chunk_size in (* Try to interpret the empty input (correctly signed) *) let* s = checked_set_input ~loc:__LOC__ context correct_input s in let*! () = check_status s (Some Not_gathering_floppies) in (* We still have 1 chunk. *) - let* () = check_chunks_count s 1l in + let* () = check_chunks_count s chunk_size in return_unit let should_refuse_chunks_with_incorrect_signature () = @@ -299,18 +295,18 @@ let should_refuse_chunks_with_incorrect_signature () = let*! s = Prover.install_boot_sector s origination_message in (* Intererptation of the origination message *) let* s = checked_eval ~loc:__LOC__ context s in - let*! () = check_status s (Some Gathering_floppies) in - let* () = check_chunks_count s 1l in + let*! () = check_status s (Some (Gathering_floppies good_op.pk)) in + let* () = check_chunks_count s chunk_size in (* Try to interpret the incorrect input (badly signed) *) let* s = checked_set_input ~loc:__LOC__ context incorrect_input s in - let*! () = check_status s (Some Gathering_floppies) in + let*! () = check_status s (Some (Gathering_floppies good_op.pk)) in (* We still have 1 chunk. *) - let* () = check_chunks_count s 1l in + let* () = check_chunks_count s chunk_size in (* Try to interpret the correct input (correctly signed) *) let* s = checked_set_input ~loc:__LOC__ context correct_input s in - let*! () = check_status s (Some Gathering_floppies) in + let*! () = check_status s (Some (Gathering_floppies good_op.pk)) in (* We now have 2 chunks. *) - let* () = check_chunks_count s 2l in + let* () = check_chunks_count s (2 * chunk_size) in return_unit let should_boot_incomplete_boot_sector kernel () = @@ -349,6 +345,7 @@ let should_boot_incomplete_boot_sector kernel () = |> List.map Bytes.of_string in let final_chunk = Bytes.of_string @@ List.last "" rem_chunks in + let final_chunk_size = Bytes.length final_chunk in let*! index = Context_binary.init "/tmp" in let context = Context_binary.empty index in @@ -356,14 +353,13 @@ let should_boot_incomplete_boot_sector kernel () = let*! s = Prover.install_boot_sector s initial_chunk in let* () = check_proof_size ~loc:__LOC__ context None s in let*! () = check_status s None in - let* () = check_chunks_count s 0l in + let* () = check_chunks_count s 0 in (* First tick, to interpret the boot sector. One chunk have been provided, and the PVM expects more chunk to come. *) - (* First tick, to interpret the boot sector*) let* s = checked_eval ~loc:__LOC__ context s in - let*! () = check_status s (Some Gathering_floppies) in - let* () = check_chunks_count s 1l in - (* Then, installing the additional chunks *) + let*! () = check_status s (Some (Gathering_floppies operator.pk)) in + let* () = check_chunks_count s chunk_size in + (* Then, installing the additional chunks. *) let* s = List.fold_left_i_es (fun i s chunk -> @@ -372,8 +368,7 @@ let should_boot_incomplete_boot_sector kernel () = let* input = floppy_input i operator chunk in let* s = checked_set_input ~loc:__LOC__ context input s in (* We have [i+2] chunks. *) - let*! () = check_status s (Some Gathering_floppies) in - let* () = check_chunks_count s Int32.(of_int @@ (i + 2)) in + let* () = check_chunks_count s ((i + 2) * chunk_size) in return s) s chunks @@ -383,7 +378,9 @@ let should_boot_incomplete_boot_sector kernel () = let* input = floppy_input len operator final_chunk in let* s = checked_set_input ~loc:__LOC__ context input s in let*! () = check_status s (Some Not_gathering_floppies) in - let* () = check_chunks_count s Int32.(of_int @@ (len + 2)) in + let* () = + check_chunks_count s (((len + 1) * chunk_size) + final_chunk_size) + in return_unit (* Read the chosen `wasm_kernel` into memory. *) @@ -403,7 +400,7 @@ let tests = [ Tztest.tztest "should boot a complete boot sector" `Quick @@ should_boot_complete_boot_sector - (complete_boot_sector @@ computation_kernel ()); + (complete_boot_sector (Bytes.of_string @@ computation_kernel ())); ( Tztest.tztest "should boot an incomplete but too small boot sector" `Quick @@ fun () -> let operator = operator () in