From 2657b07c3499493dd8accb2527da1ae0c4f0219d Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 5 Feb 2021 17:26:00 +0100 Subject: [PATCH 1/2] Proto V2: improve the Context.Tree.kind API to not load values And also add Context.Tree.to_value to explicitely load values. --- src/lib_protocol_environment/dummy_context.ml | 2 ++ .../environment_V0.ml | 8 ++----- .../environment_V1.ml | 8 ++----- .../environment_context.ml | 2 ++ src/lib_protocol_environment/proxy_context.ml | 22 +++++++++++-------- .../sigs/v2/context.mli | 9 +++++--- .../test/test_mem_context.ml | 6 ++--- src/lib_shell_benchmarks/io_stats.ml | 11 +++++----- src/lib_storage/context.ml | 10 ++++----- src/lib_storage/helpers/context.ml | 7 ++++-- src/lib_storage/sigs/context.ml | 9 +++++--- src/lib_storage/test/test_context.ml | 6 ++--- .../lib_protocol/raw_context_intf.ml | 9 +++++--- .../lib_protocol/storage_functors.ml | 15 +++++++------ 14 files changed, 69 insertions(+), 55 deletions(-) diff --git a/src/lib_protocol_environment/dummy_context.ml b/src/lib_protocol_environment/dummy_context.ml index 57148b40d96b..d087a45293bd 100644 --- a/src/lib_protocol_environment/dummy_context.ml +++ b/src/lib_protocol_environment/dummy_context.ml @@ -45,6 +45,8 @@ module M = struct let kind _ = assert false + let to_value _ = assert false + let find _ _ = assert false let add _ _ _ = assert false diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 7e0e03146823..56c3e2be7abf 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -885,17 +885,13 @@ struct let fold_keys s root ~init ~f = Context.fold s root ~init ~f:(fun k v acc -> let k = root @ k in - match Tree.kind v with - | `Value _ -> - f k acc - | `Tree -> - Lwt.return acc) + match Tree.kind v with `Value -> f k acc | `Tree -> Lwt.return acc) let fold t root ~init ~f = Context.fold ~depth:(`Eq 1) t root ~init ~f:(fun k v acc -> let k = root @ k in match Tree.kind v with - | `Value _ -> + | `Value -> f (`Key k) acc | `Tree -> f (`Dir k) acc) diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 10eada363cd7..89f52d085fdd 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -1072,11 +1072,7 @@ struct let fold_keys s root ~init ~f = Context.fold s root ~init ~f:(fun k v acc -> let k = root @ k in - match Tree.kind v with - | `Value _ -> - f k acc - | `Tree -> - Lwt.return acc) + match Tree.kind v with `Value -> f k acc | `Tree -> Lwt.return acc) type key_or_dir = [`Key of string list | `Dir of string list] @@ -1084,7 +1080,7 @@ struct fold ~depth:(`Eq 1) t root ~init ~f:(fun k v acc -> let k = root @ k in match Tree.kind v with - | `Value _ -> + | `Value -> f (`Key k) acc | `Tree -> f (`Dir k) acc) diff --git a/src/lib_protocol_environment/environment_context.ml b/src/lib_protocol_environment/environment_context.ml index 21323951a567..5c7faa8b8196 100644 --- a/src/lib_protocol_environment/environment_context.ml +++ b/src/lib_protocol_environment/environment_context.ml @@ -162,6 +162,8 @@ module Context = struct let kind (Tree {ops = (module Ops); tree; _}) = Ops.Tree.kind tree + let to_value (Tree {ops = (module Ops); tree; _}) = Ops.Tree.to_value tree + let equal (Tree {ops = (module Ops); tree; equality_witness; _}) (Tree t) = match equiv equality_witness t.equality_witness with | (Some Refl, Some Refl) -> diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index b0c509514c93..c32fa927b37d 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -101,7 +101,8 @@ module C = struct type elt = Key of value | Dir of Local.tree - let elt t = match Local.Tree.kind t with `Value v -> Key v | `Tree -> Dir t + let elt t = + Local.Tree.to_value t >|= function Some v -> Key v | None -> Dir t let raw_find (t : tree) k = Local.Tree.find_tree t.tree k @@ -127,7 +128,7 @@ module C = struct Local.Tree.find_tree t.tree k >|= Option.map Local.Tree.kind >>= function - | Some (`Value _) -> + | Some `Value -> Lwt.return (kind = `Value) | Some `Tree -> Lwt.return (kind = `Tree) @@ -174,8 +175,12 @@ module C = struct let find t k = data_tree t >>= fun tree -> - raw_find tree k >|= Option.map elt - >|= function Some (Key v) -> Some v | _ -> None + raw_find tree k + >>= function + | None -> + Lwt.return_none + | Some v -> ( + elt v >|= function Key v -> Some v | _ -> None ) let find_tree t k = data_tree t @@ -249,11 +254,8 @@ module C = struct let find t k = raw_find t k - >|= function - | None -> - None - | Some tree -> ( - match Local.Tree.kind tree with `Value v -> Some v | `Tree -> None ) + >>= function + | None -> Lwt.return_none | Some tree -> Local.Tree.to_value tree let find_tree t k = raw_find t k @@ -275,6 +277,8 @@ module C = struct let kind t = Local.Tree.kind t.tree + let to_value t = Local.Tree.to_value t.tree + let list = raw_list let clear ?depth t = Local.Tree.clear ?depth t.tree diff --git a/src/lib_protocol_environment/sigs/v2/context.mli b/src/lib_protocol_environment/sigs/v2/context.mli index 7e521fdef38c..01b714a34bc3 100644 --- a/src/lib_protocol_environment/sigs/v2/context.mli +++ b/src/lib_protocol_environment/sigs/v2/context.mli @@ -127,6 +127,8 @@ module type TREE = sig (** The type for context trees. *) type tree + include VIEW with type t := tree and type tree := tree + (** [empty _] is the empty tree. *) val empty : t -> tree @@ -135,7 +137,10 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> [`Value of bytes | `Tree] + val kind : tree -> [`Value | `Tree] + + (** [to_value t] is [Some v] is [t] is a leaf tree and [None] otherwise. *) + val to_value : tree -> value option Lwt.t (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t @@ -143,8 +148,6 @@ module type TREE = sig (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) val equal : tree -> tree -> bool - include VIEW with type t := tree and type tree := tree - (** {2 Caches} *) (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a diff --git a/src/lib_protocol_environment/test/test_mem_context.ml b/src/lib_protocol_environment/test/test_mem_context.ml index eb6064d33300..b75455a101a0 100644 --- a/src/lib_protocol_environment/test/test_mem_context.ml +++ b/src/lib_protocol_environment/test/test_mem_context.ml @@ -180,7 +180,7 @@ let test_replay {genesis = ctxt0; _} = let fold_keys s root ~init ~f = Context.fold s root ~init ~f:(fun k v acc -> match Context.Tree.kind v with - | `Value _ -> + | `Value -> f (root @ k) acc | `Tree -> Lwt.return acc) @@ -238,7 +238,7 @@ let test_fold {genesis = ctxt; _} = [] ~f:(fun path tree (cs, ns) -> match Context.Tree.kind tree with - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns) | `Tree -> Lwt.return (cs, path :: ns)) @@ -328,7 +328,7 @@ let test_trees {genesis = ctxt; _} = [] ~f:(fun path tree (cs, ns) -> match Context.Tree.kind tree with - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns) | `Tree -> Lwt.return (cs, path :: ns)) diff --git a/src/lib_shell_benchmarks/io_stats.ml b/src/lib_shell_benchmarks/io_stats.ml index 27f53e80a86e..073b4606bc6e 100644 --- a/src/lib_shell_benchmarks/io_stats.ml +++ b/src/lib_shell_benchmarks/io_stats.ml @@ -92,12 +92,13 @@ let load_tree context key = key ~init:Io_helpers.Key_map.empty ~f:(fun path t tree -> - match Context.Tree.kind t with - | `Value bytes -> + Context.Tree.to_value t + >|= function + | Some bytes -> let len = Bytes.length bytes in - Lwt.return (Io_helpers.Key_map.insert path len tree) - | `Tree -> - Lwt.return tree) + Io_helpers.Key_map.insert path len tree + | None -> + tree) let context_statistics base_dir context_hash = let (context, index) = diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 6d1fd6ec1d82..1954e17a6cc4 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -668,12 +668,12 @@ module Dumpable_context = struct let context_tree ctxt = ctxt.tree let tree_hash tree = - tree |> Store.Tree.destruct - |> function + let hash = Store.Tree.hash tree in + match Store.Tree.destruct tree with | `Node _ -> - `Node (Store.Tree.hash tree) - | `Contents (b, _) -> - `Blob (Store.Contents.hash b) + `Node hash + | `Contents _ -> + `Blob hash type binding = { key : string; diff --git a/src/lib_storage/helpers/context.ml b/src/lib_storage/helpers/context.ml index c0fea728b768..b905363bf396 100644 --- a/src/lib_storage/helpers/context.ml +++ b/src/lib_storage/helpers/context.ml @@ -49,11 +49,14 @@ module Make_tree (Store : DB) = struct let add t k v = Store.Tree.add t k v let kind t = + match Store.Tree.destruct t with `Contents _ -> `Value | `Node _ -> `Tree + + let to_value t = match Store.Tree.destruct t with | `Contents (c, _) -> - `Value c + Lwt.return (Some c) | `Node _ -> - `Tree + Lwt.return_none let fold ?depth t k ~init ~f = find_tree t k diff --git a/src/lib_storage/sigs/context.ml b/src/lib_storage/sigs/context.ml index 192e345457d1..96055fb0d45c 100644 --- a/src/lib_storage/sigs/context.ml +++ b/src/lib_storage/sigs/context.ml @@ -124,6 +124,8 @@ module type TREE = sig (** The type for context trees. *) type tree + include VIEW with type t := tree and type tree := tree + (** [empty _] is the empty tree. *) val empty : t -> tree @@ -132,7 +134,10 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> [`Value of bytes | `Tree] + val kind : tree -> [`Value | `Tree] + + (** [to_value t] is [Some v] is [t] is a leaf tree and [None] otherwise. *) + val to_value : tree -> value option Lwt.t (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t @@ -140,8 +145,6 @@ module type TREE = sig (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) val equal : tree -> tree -> bool - include VIEW with type t := tree and type tree := tree - (** {2 Caches} *) (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a diff --git a/src/lib_storage/test/test_context.ml b/src/lib_storage/test/test_context.ml index 36a4a5b65e7b..6e56b4fe7b0e 100644 --- a/src/lib_storage/test/test_context.ml +++ b/src/lib_storage/test/test_context.ml @@ -256,7 +256,7 @@ let test_replay {idx; genesis; _} = let fold_keys s root ~init ~f = fold s root ~init ~f:(fun k v acc -> match Tree.kind v with - | `Value _ -> + | `Value -> f (root @ k) acc | `Tree -> Lwt.return acc) @@ -356,7 +356,7 @@ let test_fold {idx; genesis; _} = match Tree.kind t with | `Tree -> Lwt.return (cs, path :: ns) - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns)) >>= fun (cs, ns) -> Assert.equal_string_list_list ~msg:__LOC__ ecs cs ; @@ -407,7 +407,7 @@ let test_trees {idx; genesis; _} = match Tree.kind t with | `Tree -> Lwt.return (cs, path :: ns) - | `Value _ -> + | `Value -> Lwt.return (path :: cs, ns)) >>= fun (cs, ns) -> Assert.equal_string_list_list ~msg:__LOC__ ecs cs ; diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index b82f376e9b55..c2e095ec9ea6 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -190,6 +190,8 @@ module type TREE = sig (** The type for context trees. *) type tree + include VIEW with type t := tree and type tree := tree + (** [empty _] is the empty tree. *) val empty : t -> tree @@ -198,7 +200,10 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> [`Value of bytes | `Tree] + val kind : tree -> [`Value | `Tree] + + (** [to_value t] is [Some v] is [t] is a leaf tree and [None] otherwise. *) + val to_value : tree -> value option Lwt.t (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t @@ -206,8 +211,6 @@ module type TREE = sig (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) val equal : tree -> tree -> bool - include VIEW with type t := tree and type tree := tree - (** {2 Caches} *) (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 2971e5ea2200..7a6af8c1504e 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -244,7 +244,7 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : let fold s ~init ~f = C.fold ~depth:(`Eq I.path_length) s [] ~init ~f:(fun file tree acc -> match C.Tree.kind tree with - | `Value _ -> ( + | `Value -> ( match I.of_path file with None -> assert false | Some p -> f p acc ) | `Tree -> Lwt.return acc) @@ -319,8 +319,9 @@ module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : let fold s ~init ~f = C.fold ~depth:(`Eq I.path_length) s [] ~init ~f:(fun file tree acc -> - match C.Tree.kind tree with - | `Value v -> ( + C.Tree.to_value tree + >>= function + | Some v -> ( match I.of_path file with | None -> assert false @@ -331,7 +332,7 @@ module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : f path v acc | Error _ -> Lwt.return acc ) ) - | `Tree -> + | None -> Lwt.return acc) let fold_keys s ~init ~f = fold s ~init ~f:(fun k _ acc -> f k acc) @@ -492,7 +493,7 @@ struct let fold_keys_unaccounted s ~init ~f = C.fold ~depth:(`Eq I.path_length) s [] ~init ~f:(fun file tree acc -> match C.Tree.kind tree with - | `Value _ -> ( + | `Value -> ( match List.rev file with | last :: _ when Compare.String.(last = len_name) -> Lwt.return acc @@ -635,7 +636,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : assert false | Some path -> f path acc ) - | `Value _ -> + | `Value -> Lwt.return acc) let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) @@ -655,7 +656,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let list t k = C.fold ~depth:(`Eq 1) t k ~init:[] ~f:(fun k t acc -> match C.Tree.kind t with - | `Value _ -> + | `Value -> Lwt.return (`Key k :: acc) | `Tree -> Lwt.return (`Dir k :: acc)) -- GitLab From 2a5979e0b6a4c863323a3df69066fd8f64beb050 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 8 Feb 2021 09:39:25 +0100 Subject: [PATCH 2/2] Proto V2: also add `Tree.of_value` --- src/lib_protocol_environment/dummy_context.ml | 2 ++ src/lib_protocol_environment/environment_context.ml | 7 +++++++ src/lib_protocol_environment/proxy_context.ml | 4 ++++ src/lib_protocol_environment/sigs/v2/context.mli | 8 +++++++- src/lib_storage/helpers/context.ml | 2 ++ src/lib_storage/helpers/context.mli | 8 +++++--- src/lib_storage/sigs/context.ml | 8 +++++++- 7 files changed, 34 insertions(+), 5 deletions(-) diff --git a/src/lib_protocol_environment/dummy_context.ml b/src/lib_protocol_environment/dummy_context.ml index d087a45293bd..a305aa50d9c1 100644 --- a/src/lib_protocol_environment/dummy_context.ml +++ b/src/lib_protocol_environment/dummy_context.ml @@ -47,6 +47,8 @@ module M = struct let to_value _ = assert false + let of_value _ _ = assert false + let find _ _ = assert false let add _ _ _ = assert false diff --git a/src/lib_protocol_environment/environment_context.ml b/src/lib_protocol_environment/environment_context.ml index 5c7faa8b8196..8ce71afbc999 100644 --- a/src/lib_protocol_environment/environment_context.ml +++ b/src/lib_protocol_environment/environment_context.ml @@ -164,6 +164,13 @@ module Context = struct let to_value (Tree {ops = (module Ops); tree; _}) = Ops.Tree.to_value tree + let of_value + (Context + {ops = (module Ops) as ops; ctxt; equality_witness; impl_name; _}) v + = + Ops.Tree.of_value ctxt v + >|= fun tree -> Tree {ops; tree; equality_witness; impl_name} + let equal (Tree {ops = (module Ops); tree; equality_witness; _}) (Tree t) = match equiv equality_witness t.equality_witness with | (Some Refl, Some Refl) -> diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index c32fa927b37d..9980b3c7697a 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -279,6 +279,10 @@ module C = struct let to_value t = Local.Tree.to_value t.tree + let of_value t v = + Local.Tree.of_value t.M.local v + >|= fun tree -> {proxy = t.proxy; path = []; tree} + let list = raw_list let clear ?depth t = Local.Tree.clear ?depth t.tree diff --git a/src/lib_protocol_environment/sigs/v2/context.mli b/src/lib_protocol_environment/sigs/v2/context.mli index 01b714a34bc3..31c82a24a1b1 100644 --- a/src/lib_protocol_environment/sigs/v2/context.mli +++ b/src/lib_protocol_environment/sigs/v2/context.mli @@ -139,9 +139,15 @@ module type TREE = sig value. *) val kind : tree -> [`Value | `Tree] - (** [to_value t] is [Some v] is [t] is a leaf tree and [None] otherwise. *) + (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] + is a leaf tree and [None] otherwise. It is equivalent to [find t + []]. *) val to_value : tree -> value option Lwt.t + (** [of_value _ v] is an Lwt promise that resolves to the leaf tree + [v]. Is is equivalent to [add (empty _) [] v]. *) + val of_value : t -> value -> tree Lwt.t + (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t diff --git a/src/lib_storage/helpers/context.ml b/src/lib_storage/helpers/context.ml index b905363bf396..3ac53a584583 100644 --- a/src/lib_storage/helpers/context.ml +++ b/src/lib_storage/helpers/context.ml @@ -58,6 +58,8 @@ module Make_tree (Store : DB) = struct | `Node _ -> Lwt.return_none + let of_value _ v = Store.Tree.add Store.Tree.empty [] v + let fold ?depth t k ~init ~f = find_tree t k >>= function diff --git a/src/lib_storage/helpers/context.mli b/src/lib_storage/helpers/context.mli index 095cb4153e35..a1fab3c68fdf 100644 --- a/src/lib_storage/helpers/context.mli +++ b/src/lib_storage/helpers/context.mli @@ -39,13 +39,15 @@ module Make_tree (DB : DB) : sig include Tezos_storage_sigs.Context.TREE with type t := DB.t - and type key := string list - and type value := bytes + and type key := DB.key + and type value := DB.contents and type tree := DB.tree val empty : _ -> DB.tree - type raw = [`Value of bytes | `Tree of raw TzString.Map.t] + val of_value : _ -> DB.contents -> DB.tree Lwt.t + + type raw = [`Value of DB.contents | `Tree of raw TzString.Map.t] val raw_encoding : raw Data_encoding.t diff --git a/src/lib_storage/sigs/context.ml b/src/lib_storage/sigs/context.ml index 96055fb0d45c..b554ea3b9297 100644 --- a/src/lib_storage/sigs/context.ml +++ b/src/lib_storage/sigs/context.ml @@ -136,9 +136,15 @@ module type TREE = sig value. *) val kind : tree -> [`Value | `Tree] - (** [to_value t] is [Some v] is [t] is a leaf tree and [None] otherwise. *) + (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] + is a leaf tree and [None] otherwise. It is equivalent to [find t + []]. *) val to_value : tree -> value option Lwt.t + (** [of_value _ v] is an Lwt promise that resolves to the leaf tree + [v]. Is is equivalent to [add (empty _) [] v]. *) + val of_value : t -> value -> tree Lwt.t + (** [hash t] is [t]'s Merkle hash. *) val hash : tree -> Context_hash.t -- GitLab