From 366fc45a1f8bf0d67d49b47ddc8a522a4beed135 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 7 Jun 2022 16:14:44 +0200 Subject: [PATCH 1/2] Add `Tree.is_val` and `Tree.Contents.is_val` functions These functions check whether the node/contents are available in memory or not (ie. if calling a function on those could incur IO costs). --- src/irmin-test/store.ml | 7 +++++++ src/irmin/tree.ml | 29 +++++++++++++++++++++++++++++ src/irmin/tree_intf.ml | 10 ++++++++++ 3 files changed, 46 insertions(+) diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index 03ff93d323..75146e510d 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -1301,6 +1301,13 @@ module Make (S : Generic_key) = struct (* Testing other tree operations. *) let v0 = S.Tree.empty () in + let b0 = S.Tree.is_val v0 [] in + Alcotest.(check bool) "empty is_val /" true b0; + let b0 = S.Tree.is_val v0 [ "foo" ] in + Alcotest.(check bool) "empty is_val /foo" true b0; + let b0 = S.Tree.is_val v0 [ "foo"; "bar" ] in + Alcotest.(check bool) "empty is_val /foo/bar" true b0; + let* c = S.Tree.to_concrete v0 in (match c with | `Tree [] -> () diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index e29ab3ee45..134986e080 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -320,6 +320,8 @@ module Make (P : Backend.S) = struct if cache then c.info.ptr <- Hash h; h) + let is_val t = match cached_value t with None -> false | Some _ -> true + let key t = match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None @@ -1227,6 +1229,20 @@ module Make (P : Backend.S) = struct let findv = findv_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + exception Lazy + + let findv' ctx t k = + findv_aux ~cache:false + ~value_of_key:(fun ~cache:_ _ _ _ -> raise Lazy) + ~return:Fun.id + ~bind:(fun x f -> f x) + ctx t k + + let is_val t = + match (cached_map t, cached_value t) with + | None, None -> false + | _ -> true + let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t = let take seq = match length with None -> seq | Some n -> Seq.take n seq @@ -1691,6 +1707,19 @@ module Make (P : Backend.S) = struct | `Node n -> (aux [@tailcall]) n path | `Contents _ -> Lwt.return_none + let is_val t path = + let rec aux node path = + match Path.decons path with + | None -> Node.is_val node + | Some (h, p) -> ( + match Node.findv' "is_val" node h with + | None -> true + | exception Node.Lazy -> false + | Some (`Contents (c, _)) -> Contents.is_val c + | Some (`Node n) -> aux n p) + in + match t with `Node n -> aux n path | `Contents (c, _) -> Contents.is_val c + let find_tree (t : t) path = let cache = true in [%log.debug "Tree.find_tree %a" pp_path path]; diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index f3ee5a7659..be47a41f58 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -82,6 +82,12 @@ module type S = sig (** [is_empty t] is true iff [t] is {!empty} (i.e. a tree node with no children). Trees with {!kind} = [`Contents] are never considered empty. *) + val is_val : t -> path -> bool + (** [is_val t k] is [true] iff the path [k] has already been forced in [t]. In + that case, that means that all the nodes traversed by [k] are loaded in + memory. If the leaf node is a contents [c], then [Contents.is_val c] + should also be [true]. *) + (** {1 Diffs} *) val diff : t -> t -> (path * (contents * metadata) Diff.t) list Lwt.t @@ -128,6 +134,10 @@ module type S = sig (** Equivalent to {!val-force}, but raises an exception if the lazy content value is not present in the underlying repository. *) + val is_val : t -> bool + (** [is_val x] is [true] iff [x] has already been forced (and so is loaded + in memory). *) + val clear : t -> unit (** [clear t] clears [t]'s cache. *) From 7114f2b7427cdfd0ce2fa5c79642188993899bf1 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 7 Jun 2022 16:58:02 +0200 Subject: [PATCH 2/2] Add tests for `is_val` functions --- src/irmin-test/store.ml | 39 ++++++++++++++++++++++++++++++++------- 1 file changed, 32 insertions(+), 7 deletions(-) diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index 75146e510d..8758cd37d5 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -1301,13 +1301,6 @@ module Make (S : Generic_key) = struct (* Testing other tree operations. *) let v0 = S.Tree.empty () in - let b0 = S.Tree.is_val v0 [] in - Alcotest.(check bool) "empty is_val /" true b0; - let b0 = S.Tree.is_val v0 [ "foo" ] in - Alcotest.(check bool) "empty is_val /foo" true b0; - let b0 = S.Tree.is_val v0 [ "foo"; "bar" ] in - Alcotest.(check bool) "empty is_val /foo/bar" true b0; - let* c = S.Tree.to_concrete v0 in (match c with | `Tree [] -> () @@ -1424,6 +1417,37 @@ module Make (S : Generic_key) = struct in run x test + let test_lazy_tree x () = + let is_val_aux v t k = + let str = Fmt.str "empty is_val %a" Irmin.Type.(pp S.path_t) k in + let b = S.Tree.is_val t k in + Alcotest.(check bool) str v b + in + let is_val = is_val_aux true in + let is_not_val = is_val_aux false in + let test repo = + let v0 = S.Tree.empty () in + is_val v0 []; + is_val v0 [ "foo" ]; + is_val v0 [ "foo"; "bar" ]; + + let* r1 = r1 ~repo in + let v1 = S.Commit.tree r1 in + is_not_val v1 []; + is_not_val v1 [ "a" ]; + + let* _ = S.Tree.find_tree v1 [ "a" ] in + is_val v1 []; + is_val v1 [ "a" ]; + + S.Tree.clear v1; + is_not_val v1 []; + is_not_val v1 [ "a" ]; + + Lwt.return () + in + run x test + let pp_proof = Irmin.Type.pp (S.Tree.Proof.t S.Tree.Proof.tree_t) let pp_stream = Irmin.Type.pp (S.Tree.Proof.t S.Tree.Proof.stream_t) @@ -2448,6 +2472,7 @@ let suite (speed, x) = suite' ([ ("High-level operations on trees", speed, T.test_trees x); + ("Test lazy trees", speed, T.test_lazy_tree x); ("Basic operations on contents", speed, T.test_contents x); ("Basic operations on nodes", speed, T.test_nodes x); ("Basic operations on commits", speed, T.test_commits x);