From 33695cff0badd84a9d740604d86b3b7b4e57a599 Mon Sep 17 00:00:00 2001 From: Yann Regis-Gianas Date: Tue, 26 Apr 2022 10:42:56 +0200 Subject: [PATCH 1/5] Proto,SCORU: Hoist a piece of code Signed-off-by: Yann Regis-Gianas --- .../lib_protocol/sc_rollup_arith.ml | 107 +++++++++++++++++- 1 file changed, 101 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 67d40d068be5..5803b8fafe7f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -67,7 +67,10 @@ module type S = sig val get_status : state -> status Lwt.t - type instruction = IPush : int -> instruction | IAdd : instruction + type instruction = + | IPush : int -> instruction + | IAdd : instruction + | IStore : string -> instruction val equal_instruction : instruction -> instruction -> bool @@ -79,6 +82,8 @@ module type S = sig val get_stack : state -> int list Lwt.t + val get_var : state -> string -> int option Lwt.t + val get_evaluation_result : state -> bool option Lwt.t val get_is_stuck : state -> string option Lwt.t @@ -110,17 +115,22 @@ module Make (Context : P) : type status = Halted | WaitingForInputMessage | Parsing | Evaluating - type instruction = IPush : int -> instruction | IAdd : instruction + type instruction = + | IPush : int -> instruction + | IAdd : instruction + | IStore : string -> instruction let equal_instruction i1 i2 = match (i1, i2) with | (IPush x, IPush y) -> Compare.Int.(x = y) | (IAdd, IAdd) -> true + | (IStore x, IStore y) -> Compare.String.(x = y) | (_, _) -> false let pp_instruction fmt = function | IPush x -> Format.fprintf fmt "push(%d)" x | IAdd -> Format.fprintf fmt "add" + | IStore x -> Format.fprintf fmt "store(%s)" x (* @@ -170,6 +180,8 @@ module Make (Context : P) : val find_value : Tree.key -> 'a Data_encoding.t -> 'a option t + val children : Tree.key -> 'a Data_encoding.t -> (string * 'a) list t + val get_value : default:'a -> Tree.key -> 'a Data_encoding.t -> 'a t val set_value : Tree.key -> 'a Data_encoding.t -> 'a -> unit t @@ -206,15 +218,41 @@ module Make (Context : P) : let* tree = Tree.remove tree key in return (tree, Some ()) + let decode encoding bytes state = + let open Lwt_syntax in + match Data_encoding.Binary.of_bytes_opt encoding bytes with + | None -> internal_error "Error during decoding" state + | Some v -> return (state, Some v) + let find_value key encoding state = let open Lwt_syntax in let* obytes = Tree.find state key in match obytes with | None -> return (state, Some None) - | Some bytes -> ( - match Data_encoding.Binary.of_bytes_opt encoding bytes with - | None -> internal_error "Internal_Error during decoding" state - | Some v -> return (state, Some (Some v))) + | Some bytes -> + let* (state, value) = decode encoding bytes state in + return (state, Some value) + + let children key encoding state = + let open Lwt_syntax in + let* children = Tree.list state key in + let rec aux = function + | [] -> return (state, Some []) + | (key, tree) :: children -> ( + let* obytes = Tree.to_value tree in + match obytes with + | None -> internal_error "Invalid children" state + | Some bytes -> ( + let* (state, v) = decode encoding bytes state in + match v with + | None -> return (state, None) + | Some v -> ( + let* (state, l) = aux children in + match l with + | None -> return (state, None) + | Some l -> return (state, Some ((key, v) :: l))))) + in + aux children let get_value ~default key encoding = let open Syntax in @@ -265,6 +303,31 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end + module MakeDict (P : sig + type t + + val name : string + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t + end) = + struct + let key k = [P.name; k] + + let get k = find_value (key k) P.encoding + + let set k v = set_value (key k) P.encoding v + + let pp = + let open Monad.Syntax in + let* l = children [P.name] P.encoding in + let pp_elem fmt (key, value) = + Format.fprintf fmt "@[%s : %a@]" key P.pp value + in + return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l + end + module MakeDeque (P : sig type t @@ -297,6 +360,17 @@ module Make (Context : P) : let idx_key idx = [P.name; Z.to_string idx] + let top = + let open Monad.Syntax in + let* head_idx = get_head in + let* end_idx = get_end in + let* v = find_value (idx_key head_idx) P.encoding in + if Z.(leq end_idx head_idx) then return None + else + match v with + | None -> (* By invariants of the Deque. *) assert false + | Some x -> return (Some x) + let push x = let open Monad.Syntax in let* head_idx = get_head in @@ -349,6 +423,16 @@ module Make (Context : P) : let name = "tick" end) + module Vars = MakeDict (struct + type t = int + + let name = "vars" + + let encoding = Data_encoding.int31 + + let pp fmt x = Format.fprintf fmt "%d" x + end) + module Stack = MakeDeque (struct type t = int @@ -378,6 +462,12 @@ module Make (Context : P) : Data_encoding.unit (function IAdd -> Some () | _ -> None) (fun () -> IAdd); + case + ~title:"store" + (Tag 1) + Data_encoding.string + (function IStore x -> Some x | _ -> None) + (fun x -> IStore x); ]) end) @@ -626,6 +716,8 @@ module Make (Context : P) : let get_stack = result_of ~default:[] @@ Stack.to_list + let get_var state k = (result_of ~default:None @@ Vars.get k) @@ state + let get_evaluation_result = result_of ~default:None @@ EvaluationResult.get let get_is_stuck = result_of ~default:None @@ is_stuck @@ -771,6 +863,9 @@ module Make (Context : P) : match i with | None -> stop_evaluating true | Some (IPush x) -> Stack.push x + | Some (IStore x) -> ( + let* v = Stack.top in + match v with None -> return () | Some v -> Vars.set x v) | Some IAdd -> ( let* v = Stack.pop in match v with -- GitLab From efbc9d09c63f298a28e4557b55f6144535d8ba68 Mon Sep 17 00:00:00 2001 From: Yann Regis-Gianas Date: Fri, 29 Apr 2022 18:00:19 +0200 Subject: [PATCH 2/5] Proto,SCORU: Add an ISTORE instruction to the arithmetic PVM Signed-off-by: Yann Regis-Gianas --- .../lib_protocol/sc_rollup_arith.ml | 50 +++++++++++++++++-- .../lib_protocol/sc_rollup_arith.mli | 14 +++++- .../test/unit/test_sc_rollup_arith.ml | 44 +++++++++++----- 3 files changed, 88 insertions(+), 20 deletions(-) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 5803b8fafe7f..c4d3efae1aad 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -464,7 +464,7 @@ module Make (Context : P) : (fun () -> IAdd); case ~title:"store" - (Tag 1) + (Tag 2) Data_encoding.string (function IStore x -> Some x | _ -> None) (fun x -> IStore x); @@ -546,7 +546,7 @@ module Make (Context : P) : | Some s -> Format.fprintf fmt "Some %s" s end) - type parser_state = ParseInt | SkipLayout + type parser_state = ParseInt | ParseVar | SkipLayout module LexerState = MakeVar (struct type t = int * int @@ -570,10 +570,15 @@ module Make (Context : P) : let encoding = Data_encoding.string_enum - [("ParseInt", ParseInt); ("SkipLayout", SkipLayout)] + [ + ("ParseInt", ParseInt); + ("ParseVar", ParseVar); + ("SkipLayout", SkipLayout); + ] let pp fmt = function | ParseInt -> Format.fprintf fmt "Parsing int" + | ParseVar -> Format.fprintf fmt "Parsing var" | SkipLayout -> Format.fprintf fmt "Skipping layout" end) @@ -616,10 +621,11 @@ module Make (Context : P) : let* parser_state_pp = ParserState.pp in let* lexer_state_pp = LexerState.pp in let* evaluation_result_pp = EvaluationResult.pp in + let* vars_pp = Vars.pp in return @@ fun fmt () -> Format.fprintf fmt - "@[@;%a@;%a@;%a@;%a@;%a@;%a@;%a@]" + "@[@;%a@;%a@;%a@;%a@;%a@;%a@;%a@;%a@]" status_pp () message_counter_pp @@ -634,6 +640,8 @@ module Make (Context : P) : () evaluation_result_pp () + vars_pp + () end open State @@ -785,6 +793,11 @@ module Make (Context : P) : | Some x -> Code.inject (IPush x) | None -> (* By validity of int parsing. *) assert false + let push_var = + let open Monad.Syntax in + let* s = lexeme in + Code.inject (IStore s) + let start_parsing : unit t = let open Monad.Syntax in let* () = Status.set Parsing in @@ -825,7 +838,13 @@ module Make (Context : P) : let* () = ParserState.set SkipLayout in return () in + let produce_var = + let* () = push_var in + let* () = ParserState.set SkipLayout in + return () + in let is_digit d = Compare.Char.(d >= '0' && d <= '9') in + let is_letter d = Compare.Char.(d >= 'a' && d <= 'z') in let* parser_state = ParserState.get in match parser_state with | ParseInt -> ( @@ -844,6 +863,22 @@ module Make (Context : P) : let* () = push_int_literal in stop_parsing true | _ -> stop_parsing false) + | ParseVar -> ( + let* char = current_char in + match char with + | Some d when is_letter d -> next_char + | Some '+' -> + let* () = produce_var in + let* () = produce_add in + return () + | Some ' ' -> + let* () = produce_var in + let* () = next_char in + return () + | None -> + let* () = push_var in + stop_parsing true + | _ -> stop_parsing false) | SkipLayout -> ( let* char = current_char in match char with @@ -854,6 +889,11 @@ module Make (Context : P) : let* () = next_char in let* () = ParserState.set ParseInt in return () + | Some d when is_letter d -> + let* _ = lexeme in + let* () = next_char in + let* () = ParserState.set ParseVar in + return () | None -> stop_parsing true | _ -> stop_parsing false) @@ -865,7 +905,7 @@ module Make (Context : P) : | Some (IPush x) -> Stack.push x | Some (IStore x) -> ( let* v = Stack.top in - match v with None -> return () | Some v -> Vars.set x v) + match v with None -> stop_evaluating false | Some v -> Vars.set x v) | Some IAdd -> ( let* v = Stack.pop in match v with diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.mli b/src/proto_alpha/lib_protocol/sc_rollup_arith.mli index ec7706492a39..61bf9fa50e86 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.mli @@ -34,6 +34,9 @@ - a number [x] is interpreted as pushing [x] on the stack ; + - a variable [a] is interpreted as storing the topmost element of the + stack in the storage under the name "a" ; + - a symbol [+] pops two integers [x] and [y] and pushes [x + y] on the stack. @@ -78,8 +81,11 @@ module type S = sig (** [get_status state] returns the machine status in [state]. *) val get_status : state -> status Lwt.t - (** The machine has only two instructions. *) - type instruction = IPush : int -> instruction | IAdd : instruction + (** The machine has only three instructions. *) + type instruction = + | IPush : int -> instruction + | IAdd : instruction + | IStore : string -> instruction (** [equal_instruction i1 i2] is [true] iff [i1] equals [i2]. *) val equal_instruction : instruction -> instruction -> bool @@ -100,6 +106,10 @@ module type S = sig (** [get_stack state] returns the current stack. *) val get_stack : state -> int list Lwt.t + (** [get_var state x] returns the current value of variable [x]. + Returns [None] if [x] does not exist. *) + val get_var : state -> string -> int option Lwt.t + (** [get_evaluation_result state] returns [Some true] if the current message evaluation succeeds, [Some false] if it failed, and [None] if the evaluation has not been done yet. *) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml index 0ddece927568..1ce6661de785 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml @@ -142,7 +142,7 @@ let syntactically_valid_messages = ] let syntactically_invalid_messages = - List.map (fun s -> (s, [])) ["a"; " a"; " a "; "---"; "12 +++ --"] + List.map (fun s -> (s, [])) ["@"; " @"; " @ "; "---"; "12 +++ --"] let test_parsing_messages () = List.iter_es (test_parsing_message ~valid:true) syntactically_valid_messages @@ -151,7 +151,8 @@ let test_parsing_messages () = (test_parsing_message ~valid:false) syntactically_invalid_messages -let test_evaluation_message ~valid (boot_sector, source, expected_stack) = +let test_evaluation_message ~valid + (boot_sector, source, expected_stack, expected_vars) = let open Sc_rollup_PVM_sem in boot boot_sector @@ fun state -> let input = @@ -169,6 +170,20 @@ let test_evaluation_message ~valid (boot_sector, source, expected_stack) = Format.(pp_print_list (fun fmt -> fprintf fmt "%d;@;")) expected_stack stack + >>=? fun () -> + List.iter_es + (fun (x, v) -> + get_var state x >>= function + | None -> failwith "The variable %s cannot be found." x + | Some v' -> + Assert.equal + ~loc:__LOC__ + Compare.Int.equal + (Printf.sprintf "The variable %s has not the right value: " x) + (fun fmt x -> Format.fprintf fmt "%d" x) + v + v') + expected_vars else get_evaluation_result state >>= function | Some true -> failwith "This code should lead to an evaluation error." @@ -177,20 +192,23 @@ let test_evaluation_message ~valid (boot_sector, source, expected_stack) = let valid_messages = [ - ("", "0", [0]); - ("", "1 2", [2; 1]); - ("", "1 2 +", [3]); - ("", "1 2 + 3 +", [6]); - ("", "1 2 + 3 + 1 1 + +", [8]); - ("0 ", "", [0]); - ("1 ", "2", [2; 1]); - ("1 2 ", "+", [3]); - ("1 2 + ", "3 +", [6]); - ("1 2 + ", "3 + 1 1 + +", [8]); + ("", "0", [0], []); + ("", "1 2", [2; 1], []); + ("", "1 2 +", [3], []); + ("", "1 2 + 3 +", [6], []); + ("", "1 2 + 3 + 1 1 + +", [8], []); + ("0 ", "", [0], []); + ("1 ", "2", [2; 1], []); + ("1 2 ", "+", [3], []); + ("1 2 + ", "3 +", [6], []); + ("1 2 + ", "3 + 1 1 + +", [8], []); + ("", "1 a", [1], [("a", 1)]); + ("", "1 a 2 + b 3 +", [6], [("a", 1); ("b", 3)]); + ("", "1 a 2 + b 3 + result", [6], [("a", 1); ("b", 3); ("result", 6)]); ] let invalid_messages = - List.map (fun s -> ("", s, [])) ["+"; "1 +"; "1 1 + +"; "1 1 + 1 1 + + +"] + List.map (fun s -> ("", s, [], [])) ["+"; "1 +"; "1 1 + +"; "1 1 + 1 1 + + +"] let test_evaluation_messages () = List.iter_es (test_evaluation_message ~valid:true) valid_messages -- GitLab From c74e968c184fec6caff2d89ad50aec1e44f31cde Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Tue, 3 May 2022 07:30:07 +0000 Subject: [PATCH 3/5] Proto,SCORU: Add more tests for the store instruction --- .../lib_protocol/test/unit/test_sc_rollup_arith.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml index 1ce6661de785..4f72496c0346 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml @@ -139,10 +139,13 @@ let syntactically_valid_messages = ("1 2+", [IPush 1; IPush 2; IAdd]); ("1 2 3++3+", [IPush 1; IPush 2; IPush 3; IAdd; IAdd; IPush 3; IAdd]); ("", []); + ("1 a", [IPush 1; IStore "a"]); ] let syntactically_invalid_messages = - List.map (fun s -> (s, [])) ["@"; " @"; " @ "; "---"; "12 +++ --"] + List.map + (fun s -> (s, [])) + ["@"; " @"; " @ "; "---"; "12 +++ --"; "1a"; "a1"] let test_parsing_messages () = List.iter_es (test_parsing_message ~valid:true) syntactically_valid_messages @@ -205,10 +208,17 @@ let valid_messages = ("", "1 a", [1], [("a", 1)]); ("", "1 a 2 + b 3 +", [6], [("a", 1); ("b", 3)]); ("", "1 a 2 + b 3 + result", [6], [("a", 1); ("b", 3); ("result", 6)]); + ("1 a ", "2 b", [2; 1], [("a", 1); ("b", 2)]); + ("1 a ", "2 a", [2; 1], [("a", 2)]); + ("", "1 a 2 a + a", [3], [("a", 3)]); + ("", "1 a b", [1], [("a", 1); ("b", 1)]); + ("1 a", "", [1], [("a", 1)]); ] let invalid_messages = - List.map (fun s -> ("", s, [], [])) ["+"; "1 +"; "1 1 + +"; "1 1 + 1 1 + + +"] + List.map + (fun s -> ("", s, [], [])) + ["+"; "1 +"; "1 1 + +"; "1 1 + 1 1 + + +"; "a"] let test_evaluation_messages () = List.iter_es (test_evaluation_message ~valid:true) valid_messages -- GitLab From 7e9e2527fd1fd7cb799ebc648ae7e7778694e1fd Mon Sep 17 00:00:00 2001 From: Yann Regis-Gianas Date: Tue, 3 May 2022 21:44:33 +0200 Subject: [PATCH 4/5] Proto,SCORU: Enforce convention about monadic syntax usage in code Signed-off-by: Yann Regis-Gianas --- src/proto_alpha/lib_protocol/sc_rollup_arith.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index c4d3efae1aad..7c568f68dbd0 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -269,7 +269,6 @@ module Make (Context : P) : end open Monad - open Monad.Syntax module MakeVar (P : sig type t @@ -288,6 +287,7 @@ module Make (Context : P) : let create = set_value key P.encoding P.initial let get = + let open Monad.Syntax in let* v = find_value key P.encoding in match v with | None -> -- GitLab From b22237ed8ceb8ac31c6beff646a8064846180a52 Mon Sep 17 00:00:00 2001 From: Yann Regis-Gianas Date: Tue, 3 May 2022 21:45:50 +0200 Subject: [PATCH 5/5] Proto,SCORU: Remove useless occurrence of @@ Signed-off-by: Yann Regis-Gianas --- src/proto_alpha/lib_protocol/sc_rollup_arith.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 7c568f68dbd0..4122a2b17896 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -724,7 +724,7 @@ module Make (Context : P) : let get_stack = result_of ~default:[] @@ Stack.to_list - let get_var state k = (result_of ~default:None @@ Vars.get k) @@ state + let get_var state k = (result_of ~default:None @@ Vars.get k) state let get_evaluation_result = result_of ~default:None @@ EvaluationResult.get -- GitLab