diff --git a/bench/irmin-pack/bench_common.ml b/bench/irmin-pack/bench_common.ml index 943b6c2a2a..91458ca49e 100644 --- a/bench/irmin-pack/bench_common.ml +++ b/bench/irmin-pack/bench_common.ml @@ -93,7 +93,13 @@ let with_progress_bar ~message ~n ~unit = in with_reporter ~config bar -module Conf = Irmin_tezos.Conf +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = None + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end module Schema = struct open Irmin diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000000..50626bd585 --- /dev/null +++ b/bin/dune @@ -0,0 +1,12 @@ +(executable + (public_name irmin-inlined) + (name main) + (package irmin-pack) + (libraries unix eio eio_main irmin irmin-pack irmin-pack.unix lavyek) + (preprocess + (pps ppx_irmin.internal))) + +(env + (dev + (flags + (:standard -warn-error -A)))) diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000000..8af4299a2c --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,77 @@ +module Contents = Irmin.Contents.String + +module Conf = struct + let entries = 4 + let stable_hash = 256 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end + +let root = "/tmp/irmin-db" + +let config ~fresh ~sw ~fs = + Irmin_pack.config ~fresh ~sw ~fs Eio.Path.(fs / root) + +module StoreMaker = Irmin_pack_unix.KV (Conf) +module Store = StoreMaker.Make (Contents) + +let date = ref 0L + +let info () = + let info = Store.Info.v ~author:"foo" ~message:"bar" !date in + date := Int64.add !date 3600L; + info + +let set sw fs = + let conf = config ~fresh:true ~sw ~fs in + Fmt.pr "Store.Repo.v@."; + let repo = Store.Repo.v conf in + Fmt.pr "Store.main@."; + let main = Store.main repo in + let tree = Store.tree main in + let tree = Store.Tree.add tree [ "a"; "b" ] "Hello" in + let tree = Store.Tree.add tree [ "a"; "c" ] "!" in + (* let tree = Store.Tree.add tree [ "a"; "d"; "e" ] "World" in + let tree = Store.Tree.add tree [ "a"; "f" ] "!" in *) + Store.set_tree_exn ~info main [] tree; + Fmt.pr "Store.close@."; + Store.Repo.close repo + +(* let get sw fs = + let conf = config ~fresh:false ~sw ~fs in + Fmt.pr "Store.Repo.v@."; + let repo = Store.Repo.v conf in + Fmt.pr "Store.main@."; + let main = Store.main repo in + let value = "Hello" in + Fmt.pr "Store.get_exn %S@." value; + let s = Store.get main [ "a"; "b"; "c" ] in + assert (s = value); + let value = "World" in + Fmt.pr "Store.get_exn %S@." value; + let s = Store.get main [ "a"; "b"; "d" ] in + assert (s = value); + let value = "!" in + Fmt.pr "Store.get_exn %S@." value; + let s = Store.get main [ "a"; "e" ] in + assert (s = value); + Fmt.pr "Store.close@."; + Store.Repo.close repo *) + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.fs env in + Fmt_tty.setup_std_outputs (); + Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty (); + (* Logs.set_reporter (Logs_fmt.reporter ()); *) + Logs.(set_level @@ Some Debug); + set sw fs +(* get sw fs *) + +(* + "a" |-> "b" |-> "c" = "Hello" + | |-> "d" = "World" + |-> "e" = "!" +*) diff --git a/dune b/dune index 5d635dbe65..5c72588ef7 100644 --- a/dune +++ b/dune @@ -2,17 +2,10 @@ (env (dev - (flags :standard -w -unused-functor-parameter))) + (flags :standard -w -unused-functor-parameter -warn-error -A))) (mdx (files README.md) (deps %{bin:irmin}) - (libraries - irmin - irmin-cli - irmin-git - irmin-git.unix - eio - eio_main - eio.unix + (libraries irmin irmin-cli irmin-git irmin-git.unix eio eio_main eio.unix lwt_eio)) diff --git a/save_tree b/save_tree new file mode 100644 index 0000000000..e4e271ac01 --- /dev/null +++ b/save_tree @@ -0,0 +1,3282 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Tree_intf + +let src = Logs.Src.create "irmin.tree" ~doc:"Persistent lazy trees for Irmin" + +module Log = (val Logs.src_log src : Logs.LOG) + +type fuzzy_bool = False | True | Maybe +type ('a, 'r) cont = ('a -> 'r) -> 'r + +let ok x = Ok x + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = + match (l1, l2) with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1, v1) :: t1, (k2, v2) :: t2 -> ( + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + (aux [@tailcall]) t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + (aux [@tailcall]) t1 l2) + else ( + f k2 (`Right v2); + (aux [@tailcall]) l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Eio.Fiber.all (List.rev !l3) + +exception Backend_invariant_violation of string +exception Assertion_failure of string + +let backend_invariant_violation fmt = + Fmt.kstr (fun s -> raise (Backend_invariant_violation s)) fmt + +let assertion_failure fmt = Fmt.kstr (fun s -> raise (Assertion_failure s)) fmt + +module Make (P : Backend.S) = struct + type counters_atomic = { + contents_hash : int Atomic.t; + contents_find : int Atomic.t; + contents_add : int Atomic.t; + contents_mem : int Atomic.t; + node_hash : int Atomic.t; + node_mem : int Atomic.t; + node_index : int Atomic.t; + node_add : int Atomic.t; + node_find : int Atomic.t; + node_val_v : int Atomic.t; + node_val_find : int Atomic.t; + node_val_list : int Atomic.t; + } + + let fresh_counters _ = + { + contents_hash = Atomic.make 0; + contents_add = Atomic.make 0; + contents_find = Atomic.make 0; + contents_mem = Atomic.make 0; + node_hash = Atomic.make 0; + node_mem = Atomic.make 0; + node_index = Atomic.make 0; + node_add = Atomic.make 0; + node_find = Atomic.make 0; + node_val_v = Atomic.make 0; + node_val_find = Atomic.make 0; + node_val_list = Atomic.make 0; + } + + let cnt = fresh_counters () + + let reset_counters () = + Atomic.set cnt.contents_hash 0; + Atomic.set cnt.contents_add 0; + Atomic.set cnt.contents_find 0; + Atomic.set cnt.contents_mem 0; + Atomic.set cnt.node_hash 0; + Atomic.set cnt.node_mem 0; + Atomic.set cnt.node_index 0; + Atomic.set cnt.node_add 0; + Atomic.set cnt.node_find 0; + Atomic.set cnt.node_val_v 0; + Atomic.set cnt.node_val_find 0; + Atomic.set cnt.node_val_list 0 + + module Perf_counters = struct + type counters = { + contents_hash : int; + contents_find : int; + contents_add : int; + contents_mem : int; + node_hash : int; + node_mem : int; + node_index : int; + node_add : int; + node_find : int; + node_val_v : int; + node_val_find : int; + node_val_list : int; + } + [@@deriving irmin] + + let counters () = + { + contents_hash = Atomic.get cnt.contents_hash; + contents_add = Atomic.get cnt.contents_add; + contents_find = Atomic.get cnt.contents_find; + contents_mem = Atomic.get cnt.contents_mem; + node_hash = Atomic.get cnt.node_hash; + node_mem = Atomic.get cnt.node_mem; + node_index = Atomic.get cnt.node_index; + node_add = Atomic.get cnt.node_add; + node_find = Atomic.get cnt.node_find; + node_val_v = Atomic.get cnt.node_val_v; + node_val_find = Atomic.get cnt.node_val_find; + node_val_list = Atomic.get cnt.node_val_list; + } + + let dump_counters ppf _ = + Type.pp_json ~minify:false counters_t ppf (counters ()) + end + + include Perf_counters + + module Path = struct + include P.Node.Path + + let fold_right t ~f ~init = + let steps = map t Fun.id in + List.fold_right f steps init + end + + module Metadata = P.Node.Metadata + module Irmin_proof = Proof + module Tree_proof = Proof.Make (P.Contents.Val) (P.Hash) (Path) (Metadata) + module Env = Proof.Env (P) (Tree_proof) + + let merge_env x y = + match (Env.is_empty x, Env.is_empty y) with + | true, _ -> Ok y + | _, true -> Ok x + | false, false -> Error (`Conflict "merge env") + + module Hashes = Hash.Set.Make (P.Hash) + + module StepMap = struct + module X = struct + type t = Path.step [@@deriving irmin ~compare] + end + + include Map.Make (X) + + let stdlib_merge = merge + + include Merge.Map (X) + + let to_array m = + let length = cardinal m in + if length = 0 then [||] + else + let arr = Array.make length (choose m) in + let (_ : int) = + fold + (fun k v i -> + arr.(i) <- (k, v); + i + 1) + m 0 + in + arr + end + + type metadata = Metadata.t [@@deriving irmin ~equal] + type path = Path.t [@@deriving irmin ~pp] + type hash = P.Hash.t [@@deriving irmin ~pp ~equal ~compare] + type step = Path.step [@@deriving irmin ~pp ~compare] + type contents = P.Contents.Val.t [@@deriving irmin ~equal ~pp] + type repo = P.Repo.t + type marks = Hashes.t + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + + type 'a or_error = ('a, error) result + type 'a force = [ `True | `False of path -> 'a -> 'a ] + type uniq = [ `False | `True | `Marks of marks ] + type ('a, 'b) folder = path -> 'b -> 'a -> 'a + + type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + [@@deriving irmin] + + let dummy_marks = Hashes.create ~initial_slots:0 () + let empty_marks () = Hashes.create ~initial_slots:39 () + + exception Pruned_hash of { context : string; hash : hash } + exception Dangling_hash of { context : string; hash : hash } + exception Portable_value of { context : string } + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered dangling hash %a" context + pp_hash hash) + | Pruned_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered pruned hash %a" context pp_hash + hash) + | Portable_value { context } -> + Some + (Fmt.str "Irmin.Tree.%s: unsupported operation on portable tree." + context) + | _ -> None) + + let err_pruned_hash h = Error (`Pruned_hash h) + let err_dangling_hash h = Error (`Dangling_hash h) + let err_portable_value = Error `Portable_value + let pruned_hash_exn context hash = raise (Pruned_hash { context; hash }) + let portable_value_exn context = raise (Portable_value { context }) + + let get_ok : type a. string -> a or_error -> a = + fun context -> function + | Ok x -> x + | Error (`Pruned_hash hash) -> pruned_hash_exn context hash + | Error (`Dangling_hash hash) -> raise (Dangling_hash { context; hash }) + | Error `Portable_value -> portable_value_exn context + + type 'key ptr_option = Key of 'key | Hash of hash | Ptr_none + (* NOTE: given the choice, we prefer caching [Key] over [Hash] as it can + be used to avoid storing duplicate contents values on export. *) + + module Contents = struct + type key = P.Contents.Key.t [@@deriving irmin] + type v = Key of repo * key | Value of contents | Pruned of hash + type nonrec ptr_option = key ptr_option + + type info = { + ptr : ptr_option Atomic.t; + value : contents option Atomic.t; + env : Env.t; + } + + type t = { v : v Atomic.t; info : info } + + let info_is_empty i = + Atomic.get i.ptr = Ptr_none && Atomic.get i.value = None + + let v = + let open Type in + variant "Node.Contents.v" (fun key value pruned (v : v) -> + match v with + | Key (_, x) -> key x + | Value v -> value v + | Pruned h -> pruned h) + |~ case1 "key" P.Contents.Key.t (fun _ -> assert false) + |~ case1 "value" P.Contents.Val.t (fun v -> Value v) + |~ case1 "pruned" hash_t (fun h -> Pruned h) + |> sealv + + let clear_info i = + if not (info_is_empty i) then ( + Atomic.set i.value None; + Atomic.set i.ptr Ptr_none) + + let clear t = clear_info t.info + + let of_v ~env (v : v) = + let ptr, value = + match v with + | Key (_, k) -> ((Key k : ptr_option), None) + | Value v -> (Ptr_none, Some v) + | Pruned _ -> (Ptr_none, None) + in + let ptr = Atomic.make ptr in + let value = Atomic.make value in + let info = { ptr; value; env } in + { v = Atomic.make v; info } + + let export ?clear:(c = true) repo t k = + let ptr = Atomic.get t.info.ptr in + if c then clear t; + match (Atomic.get t.v, ptr) with + | Key (repo', _), (Ptr_none | Hash _) -> + if repo != repo' then Atomic.set t.v (Key (repo, k)) + | Key (repo', _), Key k -> + if repo != repo' then Atomic.set t.v (Key (repo, k)) + | Value _, (Ptr_none | Hash _) -> Atomic.set t.v (Key (repo, k)) + | Value _, Key k -> Atomic.set t.v (Key (repo, k)) + | Pruned _, _ -> + (* The main export function never exports a pruned position. *) + assert false + + let of_value c = of_v (Value c) + let of_key repo k = of_v (Key (repo, k)) + let pruned h = of_v (Pruned h) + + let cached_hash t = + match (Atomic.get t.v, Atomic.get t.info.ptr) with + | Key (_, k), _ -> Some (P.Contents.Key.to_hash k) + | Value _, Key k -> Some (P.Contents.Key.to_hash k) + | Pruned h, _ -> Some h + | Value _, Hash h -> Some h + | Value _, Ptr_none -> None + + let cached_key t = + match (Atomic.get t.v, Atomic.get t.info.ptr) with + | Key (_, k), _ -> Some k + | (Value _ | Pruned _), Key k -> Some k + | (Value _ | Pruned _), (Hash _ | Ptr_none) -> None + + let cached_value t = + match (Atomic.get t.v, Atomic.get t.info.value) with + | Value v, None -> Some v + | (Key _ | Value _ | Pruned _), (Some _ as v) -> v + | (Key _ | Pruned _), None -> ( + match cached_hash t with + | None -> None + | Some h -> ( + match Env.find_contents t.info.env h with + | None -> None + | Some c -> Some c)) + + let set_hash_cache ~cache t hash = + let (_ : bool) = + cache && Atomic.compare_and_set t.info.ptr Ptr_none (Hash hash) + in + () + + let hash ?(cache = true) c = + match cached_hash c with + | Some k -> k + | None -> ( + match cached_value c with + | None -> assert false + | Some v -> + Atomic.incr cnt.contents_hash; + let h = P.Contents.Hash.hash v in + set_hash_cache ~cache c h; + h) + + let key t = + match Atomic.get t.v with + | Key (_, k) -> Some k + | Value _ | Pruned _ -> None + + let value_of_key ~cache t repo k = + Atomic.incr cnt.contents_find; + let h = P.Contents.Key.to_hash k in + let v_opt = P.Contents.find (P.Repo.contents_t repo) k in + Option.iter (Env.add_contents_from_store t.info.env h) v_opt; + match v_opt with + | None -> err_dangling_hash h + | Some v -> + if cache then Atomic.set t.info.value v_opt; + Ok v + + let to_value ~cache t = + match cached_value t with + | Some v -> ok v + | None -> ( + match Atomic.get t.v with + | Value _ -> assert false (* [cached_value == None] *) + | Key (repo, k) -> value_of_key ~cache t repo k + | Pruned h -> err_pruned_hash h) + + let force = to_value ~cache:true + + let force_exn t = + let v = force t in + get_ok "force" v + + let equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_contents x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare v of_v (fun t -> Atomic.get t.v) + + let merge : t Merge.t = + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let c = to_value ~cache:true old |> Option.of_result in + Ok (Some c)) + in + match merge_env x.info.env y.info.env with + | Error _ as e -> e + | Ok env -> ( + let x = to_value ~cache:true x |> Option.of_result in + let y = to_value ~cache:true y |> Option.of_result in + match Merge.(f P.Contents.Val.merge) ~old x y with + | Ok (Some c) -> Ok (of_value ~env c) + | Ok None -> Error (`Conflict "empty contents") + | Error _ as e -> e) + in + Merge.v t f + + let fold ~force ~cache ~path f_value f_tree t acc = + match force with + | `True -> + let c = to_value ~cache t in + f_value path (get_ok "fold" c) acc |> f_tree path + | `False skip -> ( + match cached_value t with + | None -> skip path acc + | Some c -> f_value path c acc |> f_tree path) + end + + module Lazy_cache : sig + type 'a t + + val unknown : unit -> 'a t + val make : (unit -> 'a) -> 'a t + val force : 'a t -> 'a option + val force_exn : 'a t -> 'a + val set : 'a t -> 'a -> unit + val inspect : 'a t -> 'a t option + end = struct + type 'a s = Unknown | Known of 'a | Lazy of (unit -> 'a) + type 'a t = 'a s Atomic.t + + let unknown () = Atomic.make Unknown + let make fn = Atomic.make (Lazy fn) + + let force t = + match Atomic.get t with + | Known v -> Some v + | Unknown -> None + | Lazy fn as old -> ( + let v = fn () in + if Atomic.compare_and_set t old (Known v) then Some v + else match Atomic.get t with Known v -> Some v | _ -> assert false) + + let force_exn t = match force t with Some v -> v | None -> assert false + + let set t v = + let (_ : bool) = Atomic.compare_and_set t Unknown (Known v) in + () + + let inspect t = match Atomic.get t with Unknown -> None | _ -> Some t + end + + module Node = struct + type value = P.Node.Val.t [@@deriving irmin ~equal ~pp] + type key = P.Node.Key.t [@@deriving irmin] + type nonrec ptr_option = key ptr_option + + open struct + module Portable = P.Node_portable + end + + type portable = Portable.t [@@deriving irmin ~equal ~pp] + + (* [elt] is a tree *) + type elt = + [ `Node of t + | `Contents of Contents.t * Metadata.t + | `Contents_inlined_3 of Contents.t * Metadata.t ] + + and update = Add of elt | Remove + and updatemap = update StepMap.t + and map = elt StepMap.t * elt StepMap.t + + and info = { + value : value option Atomic.t; + map : map option Atomic.t; + ptr : ptr_option Atomic.t; + findv_cache : map option Atomic.t; + length : int Lazy_cache.t; + env : Env.t; + } + + and v = + | Map of map + | Key of repo * key + | Value of repo * value * updatemap option + | Portable_dirty of portable * updatemap + | Pruned of hash + + and t = { v : v Atomic.t; info : info } + (** For discussion of [t.v]'s states, see {!Tree_intf.S.inspect}. + + [t.info.map] is only populated during a call to [Node.to_map]. *) + + let elt_t (t : t Type.t) : elt Type.t = + let open Type in + variant "Node.value" (fun node contents contents_m -> function + | `Node x -> node x + | `Contents (c, m) | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + if equal_metadata m Metadata.default then contents c + else contents_m (c, m)) + |~ case1 "Node" t (fun x -> `Node x) + |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) + |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) + (* |~ case1 "Contents-inlined" (pair Contents.t Metadata.t) (fun x -> + `Contents_inlined_3 x) *) + |> sealv + + let stepmap_t : 'a. 'a Type.t -> 'a StepMap.t Type.t = + fun elt -> + let open Type in + let to_map x = + List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x + in + let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in + map (list (pair Path.step_t elt)) to_map of_map + + let update_t (elt : elt Type.t) : update Type.t = + let open Type in + variant "Node.update" (fun add remove -> function + | Add elt -> add elt + | Remove -> remove) + |~ case1 "add" elt (fun elt -> Add elt) + |~ case0 "remove" Remove + |> sealv + + let v_t (elt : elt Type.t) : v Type.t = + let m = stepmap_t elt in + let um = stepmap_t (update_t elt) in + let open Type in + variant "Node.node" (fun map key value pruned portable_dirty -> function + | Map (m, m1) -> map (m, m1) + | Key (_, y) -> key y + | Value (_, v, m) -> value (v, m) + | Pruned h -> pruned h + | Portable_dirty (v, m) -> portable_dirty (v, m)) + |~ case1 "map" (pair m m) (fun (m, mi) -> Map (m, mi)) + |~ case1 "key" P.Node.Key.t (fun _ -> assert false) + |~ case1 "value" (pair P.Node.Val.t (option um)) (fun _ -> assert false) + |~ case1 "pruned" hash_t (fun h -> Pruned h) + |~ case1 "portable_dirty" (pair portable_t um) (fun (v, m) -> + Portable_dirty (v, m)) + |> sealv + + let of_v ?length ?findv_cache ~env v = + let ptr, map, value = + match v with + | Map m -> (Ptr_none, Some m, None) + | Key (_, k) -> (Key k, None, None) + | Value (_, v, None) -> (Ptr_none, None, Some v) + | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) + in + let ptr = Atomic.make ptr in + let map = Atomic.make map in + let value = Atomic.make value in + let findv_cache = Atomic.make findv_cache in + let length = + match length with None -> Lazy_cache.unknown () | Some len -> len + in + let info = { ptr; map; value; findv_cache; env; length } in + let v = Atomic.make v in + { v; info } + + let of_map m = of_v (Map m) + let of_key repo k = of_v (Key (repo, k)) + + let of_value ?length ?findv_cache ?updates repo v = + of_v ?length ?findv_cache (Value (repo, v, updates)) + + let of_portable_dirty ?findv_cache ~env p updates = + of_v ?findv_cache ~env (Portable_dirty (p, updates)) + + let pruned h = of_v (Pruned h) + + let info_is_empty i = + Atomic.get i.map = None + && Atomic.get i.value = None + && Atomic.get i.findv_cache = None + && Atomic.get i.ptr = Ptr_none + + let rec add_to_findv_cache t step v = + let old_value = Atomic.get t.info.findv_cache in + let new_value = + match old_value with + | None -> Some (StepMap.singleton step v, StepMap.empty) + (*TODO inline check size here ?*) + | Some (m, mi) -> Some (StepMap.add step v m, mi) + in + if not (Atomic.compare_and_set t.info.findv_cache old_value new_value) + then add_to_findv_cache t step v + + let clear_info_fields i = + if not (info_is_empty i) then ( + Atomic.set i.value None; + Atomic.set i.map None; + Atomic.set i.ptr Ptr_none; + Atomic.set i.findv_cache None) + + let rec clear_elt ~max_depth depth v = + match v with + | `Contents (c, _) -> if depth + 1 > max_depth then Contents.clear c + | `Contents_inlined_3 (c, _) -> + if depth + 1 > max_depth then Contents.clear c + | `Node t -> clear ~max_depth (depth + 1) t + + and clear_info ~max_depth ~v depth i = + let clear _ v = clear_elt ~max_depth depth v in + let () = + match v with + | Value (_, _, Some um) -> + StepMap.iter + (fun k -> function Remove -> () | Add v -> clear k v) + um + | Value (_, _, None) | Map _ | Key _ | Portable_dirty _ | Pruned _ -> () + in + let () = + match (v, Atomic.get i.map) with + | Map m, _ | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> + let m, mi = m in + StepMap.iter clear m; + StepMap.iter clear mi + | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> () + in + let () = + match Atomic.get i.findv_cache with + | Some m -> + let m, mi = m in + StepMap.iter clear m; + StepMap.iter clear mi + | None -> () + in + if depth >= max_depth then clear_info_fields i + + and clear ~max_depth depth t = + clear_info ~v:(Atomic.get t.v) ~max_depth depth t.info + + (* export t to the given repo and clear the cache *) + let export ?clear:(c = true) repo t k = + let ptr = t.info.ptr in + if c then clear_info_fields t.info; + match Atomic.get t.v with + | Key (repo', k) -> if repo != repo' then Atomic.set t.v (Key (repo, k)) + | Value _ | Map _ -> ( + match Atomic.get ptr with + | Ptr_none | Hash _ -> Atomic.set t.v (Key (repo, k)) + | Key k -> Atomic.set t.v (Key (repo, k))) + | Portable_dirty _ | Pruned _ -> + (* The main export function never exports a pruned position. *) + assert false + + module Core_value + (N : + Node.Generic_key.Core + with type step := step + and type hash := hash + and type metadata := metadata) + (To_elt : sig + type repo + + val t : env:Env.t -> repo -> N.value -> elt + end) = + struct + let to_map ~cache ~env repo t = + Atomic.incr cnt.node_val_list; + let entries = N.seq ~cache t in + Seq.fold_left + (fun acc (k, v) -> StepMap.add k (To_elt.t ~env repo v) acc) + StepMap.empty entries + + (** Does [um] empties [v]? + + Gotcha: Some [Remove] entries in [um] might not be in [v]. *) + let is_empty_after_updates ~cache t um = + let any_add = + StepMap.to_seq um + |> Seq.exists (function _, Remove -> false | _, Add _ -> true) + in + if any_add then false + else + let val_is_empty = N.is_empty t in + if val_is_empty then true + else + let remove_count = StepMap.cardinal um in + if (not val_is_empty) && remove_count = 0 then false + else if N.length t > remove_count then false + else ( + (* Starting from this point the function is expensive, but there is + no alternative. *) + Atomic.incr cnt.node_val_list; + let entries = N.seq ~cache t in + Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) + + let findv ~cache ~env step node repo t = + match N.find ~cache t step with + | None -> None + | Some v -> + let tree = To_elt.t ~env repo v in + if cache then add_to_findv_cache node step tree; + Some tree + + let seq ~env ?offset ?length ~cache repo v = + Atomic.incr cnt.node_val_list; + let seq = N.seq ?offset ?length ~cache v in + Seq.map (fun (k, v) -> (k, To_elt.t ~env repo v)) seq + end + + module Regular_value = + Core_value + (P.Node.Val) + (struct + type nonrec repo = repo + + let t ~env repo = function + | `Node k -> `Node (of_key ~env repo k) + | `Node_with_inlined _ -> assert false + | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) + end) + + module Portable_value = + Core_value + (P.Node_portable) + (struct + type repo = unit + + let t ~env () = function + | `Node h -> `Node (pruned ~env h) + | `Node_with_inlined _ -> assert false + | `Contents (h, m) -> `Contents (Contents.pruned ~env h, m) + end) + + (** This [Scan] module contains function that scan the content of [t.v] and + [t.info], looking for specific patterns. *) + module Scan = struct + let iter_hash t hit miss miss_arg = + match (Atomic.get t.v, Atomic.get t.info.ptr) with + | Key (_, k), _ -> hit (P.Node.Key.to_hash k) + | (Map _ | Value _ | Portable_dirty _), Key k -> + hit (P.Node.Key.to_hash k) + | Pruned h, _ -> hit h + | (Map _ | Value _ | Portable_dirty _), Hash h -> hit h + | (Map _ | Value _ | Portable_dirty _), Ptr_none -> miss t miss_arg + + let iter_key t hit miss miss_arg = + match (Atomic.get t.v, Atomic.get t.info.ptr) with + | Key (_, k), _ -> hit k + | (Map _ | Value _ | Portable_dirty _ | Pruned _), Key k -> hit k + | (Map _ | Value _ | Portable_dirty _ | Pruned _), (Hash _ | Ptr_none) + -> + miss t miss_arg + + let iter_map t hit miss miss_arg = + match (Atomic.get t.v, Atomic.get t.info.map) with + | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> hit m + | Map m, _ -> hit m + | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> + miss t miss_arg + + let iter_value t hit miss miss_arg = + match (Atomic.get t.v, Atomic.get t.info.value) with + | Value (_, v, None), None -> hit v + | (Map _ | Key _ | Value _ | Portable_dirty _ | Pruned _), Some v -> + hit v + | ( (Map _ | Key _ | Value (_, _, Some _) | Portable_dirty _ | Pruned _), + None ) -> + iter_hash t + (fun h -> + (* The need for [t], [miss] and [miss_arg] allocates a closure *) + match Env.find_node t.info.env h with + | None -> miss t miss_arg + | Some v -> hit v) + miss miss_arg + + let iter_portable t hit miss miss_arg = + match Atomic.get t.v with + | Pruned h -> ( + match Env.find_pnode t.info.env h with + | None -> miss t miss_arg + | Some v -> hit v) + | Map _ | Key _ | Value _ | Portable_dirty _ -> + (* No need to peek in [env]in these cases because [env] + is in practice expected to only hit on [Pruned]. *) + miss t miss_arg + + let iter_repo_key t hit miss miss_arg = + match (Atomic.get t.v, Atomic.get t.info.ptr) with + | Key (repo, k), _ -> hit repo k + | Value (repo, _, _), Key k -> hit repo k + | (Map _ | Portable_dirty _ | Pruned _ | Value _), _ -> miss t miss_arg + + let iter_repo_value t hit miss miss_arg = + match (Atomic.get t.v, Atomic.get t.info.value) with + | Value (repo, v, None), _ -> hit repo v + | (Value (repo, _, _) | Key (repo, _)), Some v -> hit repo v + | (Value (repo, _, _) | Key (repo, _)), None -> + iter_hash t + (fun h -> + match Env.find_node t.info.env h with + | None -> miss t miss_arg + | Some v -> hit repo v) + miss miss_arg + | (Map _ | Portable_dirty _ | Pruned _), _ -> miss t miss_arg + + type node = t + + (** An instance of [t] is expected to be the result of a chain of [to_*] + function calls. + + The [to_*] functions scan a [node] and look for a specific pattern. + The first function in the chain to match a pattern will return the + instance of [t] and ignore the rest of the chain. + + The functions in the chain should be carefuly ordered so that the + computation that follows is as quick as possible (e.g. if the goal is + to convert a [node] to hash, [to_hash] should be checked before + [to_map]). + + [cascade] may be used in order to build chains. *) + + type _ t = + | Hash : hash -> [> `hash ] t + | Map : map -> [> `map ] t + | Value : value -> [> `value ] t + | Value_dirty : (repo * value * updatemap) -> [> `value_dirty ] t + | Portable : portable -> [> `portable ] t + | Portable_dirty : (portable * updatemap) -> [> `portable_dirty ] t + | Pruned : hash -> [> `pruned ] t + | Repo_key : (repo * key) -> [> `repo_key ] t + | Repo_value : (repo * value) -> [> `repo_value ] t + | Any : [> `any ] t + + module View_kind = struct + type _ t = + | Hash : [> `hash ] t + | Map : [> `map ] t + | Value : [> `value ] t + | Value_dirty : [> `value_dirty ] t + | Portable : [> `portable ] t + | Portable_dirty : [> `portable_dirty ] t + | Pruned : [> `pruned ] t + | Repo_key : [> `repo_key ] t + | Repo_value : [> `repo_value ] t + | Any : [> `any ] t + end + + let to_hash t miss = iter_hash t (fun h -> Hash h) miss + let to_map t miss = iter_map t (fun m -> Map m) miss + let to_value t miss = iter_value t (fun v -> Value v) miss + let to_portable t miss = iter_portable t (fun v -> Portable v) miss + + let to_value_dirty t miss miss_arg = + match Atomic.get t.v with + | Value (repo, v, Some um) -> Value_dirty (repo, v, um) + | Map _ | Key _ | Value (_, _, None) | Portable_dirty _ | Pruned _ -> + miss t miss_arg + + let to_portable_dirty t miss miss_arg = + match Atomic.get t.v with + | Portable_dirty (v, um) -> Portable_dirty (v, um) + | Map _ | Key _ | Value _ | Pruned _ -> miss t miss_arg + + let to_pruned t miss miss_arg = + match Atomic.get t.v with + | Pruned h -> Pruned h + | Map _ | Key _ | Value _ | Portable_dirty _ -> miss t miss_arg + + let to_repo_key t miss miss_arg = + iter_repo_key t (fun repo k -> Repo_key (repo, k)) miss miss_arg + + let to_repo_value t miss miss_arg = + iter_repo_value t (fun repo v -> Repo_value (repo, v)) miss miss_arg + + let rec cascade : type k. node -> k View_kind.t list -> k t = + fun t -> function + | [] -> + (* The declared cascade doesn't cover all cases *) + assert false + | x :: xs -> ( + match x with + | Hash -> to_hash t cascade xs + | Map -> to_map t cascade xs + | Value -> to_value t cascade xs + | Value_dirty -> to_value_dirty t cascade xs + | Portable -> to_portable t cascade xs + | Portable_dirty -> to_portable_dirty t cascade xs + | Pruned -> to_pruned t cascade xs + | Repo_key -> to_repo_key t cascade xs + | Repo_value -> to_repo_value t cascade xs + | Any -> Any) + end + + let get_none _ () = None + let cached_hash t = Scan.iter_hash t Option.some get_none () + let cached_key t = Scan.iter_key t Option.some get_none () + let cached_map t = Scan.iter_map t Option.some get_none () + let cached_value t = Scan.iter_value t Option.some get_none () + let cached_portable t = Scan.iter_portable t Option.some get_none () + + let key t = + match Atomic.get t.v with + | Key (_, k) -> Some k + | Map _ | Value _ | Portable_dirty _ | Pruned _ -> None + + (* When computing hashes of nodes, we try to use [P.Node.Val.t] as a + pre-image if possible so that this intermediate value can be cached + within [t.info.value] (in case it is about to be written to the backend). + + This is only possible if all of the child pointers have pre-existing + keys, otherwise we must convert to portable nodes as a fallback. *) + type hash_preimage = Node of P.Node.Val.t | Pnode of Portable.t + type node_value = P.Node.Val.value + type pnode_value = Portable.value + + type hash_preimage_value = + | Node_value of node_value + | Pnode_value of pnode_value + + let weaken_value : node_value -> pnode_value = function + | `Contents (key, m) -> `Contents (P.Contents.Key.to_hash key, m) + | `Node_with_inlined _ -> assert false + | `Node key -> `Node (P.Node.Key.to_hash key) + + let set_hash_cache ~cache t hash = + let (_ : bool) = + cache && Atomic.compare_and_set t.info.ptr Ptr_none (Hash hash) + in + () + + let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = + fun ~cache t k -> + let a_of_hashable hash v = + Atomic.incr cnt.node_hash; + let hash = hash v in + set_hash_cache ~cache t hash; + k hash + in + match + (Scan.cascade t [ Hash; Value; Value_dirty; Portable_dirty; Map ] + : [ `hash | `value | `value_dirty | `portable_dirty | `map ] Scan.t) + with + | Hash h -> k h + | Value v -> a_of_hashable P.Node.Val.hash_exn v + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + | Map m -> + hash_preimage_of_map ~cache t m (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + + and hash_preimage_of_map : type r. + cache:bool -> t -> map -> (hash_preimage, r) cont = + fun ~cache t map k -> + Atomic.incr cnt.node_val_v; + let map, map_inlined = map in + let bindings = + Seq.append (StepMap.to_seq map) (StepMap.to_seq map_inlined) + in + let must_build_portable_node = + bindings + |> Seq.exists (fun (_, v) -> + match v with + | `Node n -> Option.is_none (cached_key n) + | `Contents (c, _) -> Option.is_none (Contents.cached_key c) + | `Contents_inlined_3 (c, _) -> + Option.is_none (Contents.cached_key c)) + in + if must_build_portable_node then + let pnode = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + (step, `Contents (Contents.hash c, m)) + | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + (step, `Contents (Contents.hash c, m)) + | `Node n -> hash ~cache n (fun k -> (step, `Node k))) + |> Portable.of_seq + in + k (Pnode pnode) + else + let node = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Node n -> ( + match cached_key n with + | Some k -> (step, `Node k) + | None -> + (* We checked that all child keys are cached above *) + assert false)) + |> P.Node.Val.of_seq + in + if cache then Atomic.set t.info.value (Some node); + k (Node node) + + and hash_preimage_value_of_elt : type r. + cache:bool -> elt -> (hash_preimage_value, r) cont = + fun ~cache e k -> + match e with + | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match Contents.key c with + | Some key -> k (Node_value (`Contents (key, m))) + | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match Contents.key c with + | Some key -> k (Node_value (`Contents (key, m))) + | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) + | `Node n -> ( + match key n with + | Some key -> k (Node_value (`Node key)) + | None -> hash ~cache n (fun hash -> k (Pnode_value (`Node hash)))) + + and hash_preimage_of_updates : type r. + cache:bool -> t -> hash_preimage -> updatemap -> (hash_preimage, r) cont + = + fun ~cache t v updates k -> + let updates = StepMap.bindings updates in + let rec aux acc = function + | [] -> + (if cache then + match acc with + | Node n -> Atomic.set t.info.value (Some n) + | Pnode _ -> ()); + k acc + | (k, Add e) :: rest -> + hash_preimage_value_of_elt ~cache e (fun e -> + let acc = + match (acc, e) with + | Node n, Node_value v -> Node (P.Node.Val.add n k v) + | Node n, Pnode_value v -> + Pnode (Portable.add (Portable.of_node n) k v) + | Pnode n, Node_value v -> + Pnode (Portable.add n k (weaken_value v)) + | Pnode n, Pnode_value v -> Pnode (Portable.add n k v) + in + aux acc rest) + | (k, Remove) :: rest -> + let acc = + match acc with + | Node n -> Node (P.Node.Val.remove n k) + | Pnode n -> Pnode (Portable.remove n k) + in + aux acc rest + in + aux v updates + + let hash ~cache k = hash ~cache k (fun x -> x) + + let value_of_key ~cache t repo k = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match cached_value t with + | Some v -> ok v + | None -> ( + Atomic.incr cnt.node_find; + let v_opt = P.Node.find (P.Repo.node_t repo) k in + let h = P.Node.Key.to_hash k in + let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in + match v_opt with + | None -> err_dangling_hash h + | Some v -> + if cache then Atomic.set t.info.value v_opt; + Ok v) + + let to_value ~cache t = + match + (Scan.cascade t [ Value; Repo_key; Any ] + : [ `value | `repo_key | `any ] Scan.t) + with + | Value v -> ok v + | Repo_key (repo, k) -> value_of_key ~cache t repo k + | Any -> ( + match Atomic.get t.v with + | Key _ | Value (_, _, None) -> assert false + | Pruned h -> err_pruned_hash h + | Portable_dirty _ -> err_portable_value + | Map _ | Value (_, _, Some _) -> + invalid_arg + "Tree.Node.to_value: the supplied node has not been written to \ + disk. Either export it or convert it to a portable value \ + instead.") + + let to_portable_value_aux ~cache ~value_of_key t = + let ok x = Ok x in + match + (Scan.cascade t + [ + Portable; Value; Repo_key; Portable_dirty; Value_dirty; Map; Pruned; + ] + : [ `portable + | `value + | `repo_key + | `portable_dirty + | `value_dirty + | `map + | `pruned ] + Scan.t) + with + | Portable p -> ok p + | Value v -> ok (P.Node_portable.of_node v) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node _ -> assert false + | Pnode x -> ok x) + | Repo_key (repo, k) -> + let value_res = value_of_key ~cache t repo k in + Result.map P.Node_portable.of_node value_res + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> ok (Portable.of_node x) + | Pnode x -> ok x) + | Map m -> + hash_preimage_of_map ~cache t m (function + | Node x -> ok (Portable.of_node x) + | Pnode x -> ok x) + | Pruned h -> err_pruned_hash h + + let to_portable_value = to_portable_value_aux ~value_of_key + + let to_map ~cache t = + let of_maps m updates = + let m = + match updates with + | None -> m + | Some updates -> + StepMap.stdlib_merge + (fun _ left right -> + match (left, right) with + | None, None -> assert false + | (Some _ as v), None -> v + | _, Some (Add v) -> Some v + | _, Some Remove -> None) + m updates + in + if cache then Atomic.set t.info.map (Some (m, StepMap.empty)); + (m, StepMap.empty) + in + let of_value repo v um = + let env = t.info.env in + let m = Regular_value.to_map ~env ~cache repo v in + of_maps m um + in + let of_portable_value v um = + let env = t.info.env in + let m = Portable_value.to_map ~env ~cache () v in + of_maps m um + in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> ok m + | Repo_value (repo, v) -> ok (of_value repo v None) + | Repo_key (repo, k) -> ( + match value_of_key ~cache t repo k with + | Error _ as e -> e + | Ok v -> Ok (of_value repo v None)) + | Value_dirty (repo, v, um) -> ok (of_value repo v (Some um)) + | Portable p -> ok (of_portable_value p None) + | Portable_dirty (p, um) -> ok (of_portable_value p (Some um)) + | Pruned h -> err_pruned_hash h + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let rec elt_equal (x : elt) (y : elt) = + x == y + || + match (x, y) with + | `Contents x, `Contents y -> contents_equal x y + | `Contents_inlined_3 x, `Contents_inlined_3 y -> contents_equal x y + | `Node x, `Node y -> equal x y + | _ -> false + + and map_equal ((x, xi) : map) ((y, yi) : map) = + StepMap.equal elt_equal x y && StepMap.equal elt_equal xi yi + + and equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_value x y + | _ -> ( + match (cached_portable x, cached_portable y) with + | Some x, Some y -> equal_portable x y + | _ -> ( + match (cached_map x, cached_map y) with + | Some x, Some y -> map_equal x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)))) + + (* same as [equal] but do not compare in-memory maps + recursively. *) + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (cached_hash x, cached_hash y) with + | Some x, Some y -> if equal_hash x y then True else False + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> if equal_value x y then True else False + | _ -> ( + match (cached_portable x, cached_portable y) with + | Some x, Some y -> if equal_portable x y then True else False + | _ -> Maybe)) + + let empty () = of_map (StepMap.empty, StepMap.empty) ~env:(Env.empty ()) + let empty_hash = hash ~cache:false (empty ()) + let singleton k v = of_map (StepMap.singleton k v, StepMap.empty) + + let slow_length ~cache t = + match + (Scan.cascade t + [ + Map; Value; Portable; Repo_key; Value_dirty; Portable_dirty; Pruned; + ] + : [ `map + | `value + | `portable + | `repo_key + | `value_dirty + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map (m, mi) -> StepMap.cardinal m + StepMap.cardinal mi + | Value v -> P.Node.Val.length v + | Portable p -> P.Node_portable.length p + | Repo_key (repo, k) -> + value_of_key ~cache t repo k |> get_ok "length" |> P.Node.Val.length + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> P.Node.Val.length x + | Pnode x -> P.Node_portable.length x) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node _ -> assert false + | Pnode x -> P.Node_portable.length x) + | Pruned h -> pruned_hash_exn "length" h + + let length ~cache t = + match Lazy_cache.force t.info.length with + | Some len -> len + | None -> + let len = slow_length ~cache t in + Lazy_cache.set t.info.length len; + len + + let is_empty ~cache t = + match + (Scan.cascade t + [ Map; Value; Portable; Hash; Value_dirty; Portable_dirty ] + : [ `map + | `value + | `portable + | `hash + | `value_dirty + | `portable_dirty ] + Scan.t) + with + | Map (m, mi) -> StepMap.is_empty m && StepMap.is_empty mi + | Value v -> P.Node.Val.is_empty v + | Portable p -> P.Node_portable.is_empty p + | Hash h -> equal_hash h empty_hash + | Value_dirty (_repo, v, um) -> + Regular_value.is_empty_after_updates ~cache v um + | Portable_dirty (p, um) -> + Portable_value.is_empty_after_updates ~cache p um + + let findv_aux ~cache ~value_of_key ctx t step = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + let of_map (m, mi) = + try Some (StepMap.find step m) + with Not_found -> ( + try Some (StepMap.find step mi) with Not_found -> None) + in + let of_value = Regular_value.findv ~cache ~env:t.info.env step t in + let of_portable = Portable_value.findv ~cache ~env:t.info.env step t () in + let of_t () = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map (m, mi) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_map (m, mi) + | Repo_value (repo, v) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_value repo v + | Repo_key (repo, k) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + let v = value_of_key ~cache t repo k in + let v = get_ok ctx v in + of_value repo v + | Value_dirty (repo, v, um) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match StepMap.find_opt step um with + | Some (Add v) -> Some v + | Some Remove -> None + | None -> of_value repo v) + | Portable p -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_portable p + | Portable_dirty (p, um) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match StepMap.find_opt step um with + | Some (Add v) -> Some v + | Some Remove -> None + | None -> of_portable p) + | Pruned h -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + pruned_hash_exn ctx h + in + match Atomic.get t.info.findv_cache with + | None -> of_t () + | Some (m, mi) -> ( + match of_map (m, mi) with None -> of_t () | Some _ as r -> r) + + let findv = findv_aux ~value_of_key + + 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 + in + StepMap.to_seq m |> Seq.drop offset |> take + + let seq_of_map ?offset ?length (m, mi) = + Seq.append (seq_of_map ?offset ?length m) (seq_of_map ?offset ?length mi) + + let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error = + let env = t.info.env in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map (m, mi) -> ok (seq_of_map ?offset ?length (m, mi)) + | Repo_value (repo, v) -> + ok (Regular_value.seq ~env ?offset ?length ~cache repo v) + | Repo_key (repo, k) -> ( + match value_of_key ~cache t repo k with + | Error _ as e -> e + | Ok v -> ok (Regular_value.seq ~env ?offset ?length ~cache repo v)) + | Value_dirty _ | Portable_dirty _ -> ( + match to_map ~cache t with + | Error _ as e -> e + | Ok (m, mi) -> ok (seq_of_map ?offset ?length (m, mi))) + | Portable p -> ok (Portable_value.seq ~env ?offset ?length ~cache () p) + | Pruned h -> err_pruned_hash h + + let bindings ~cache t = + (* XXX: If [t] is value, no need to [to_map]. Let's remove and inline + this into Tree.entries. *) + match to_map ~cache t with + | Error _ as e -> e + | Ok (m, mi) -> Ok (StepMap.bindings m @ StepMap.bindings mi) + + let seq_of_updates updates value_bindings = + (* This operation can be costly for large updates. *) + if StepMap.is_empty updates then + (* Short-circuit return if we have no more updates to apply. *) + value_bindings + else + let value_bindings = + Seq.filter (fun (s, _) -> not (StepMap.mem s updates)) value_bindings + in + let updates = + StepMap.to_seq updates + |> Seq.filter_map (fun (s, elt) -> + match elt with Remove -> None | Add e -> Some (s, e)) + in + Seq.append value_bindings updates + + type ('v, 'acc, 'r) cps_folder = + path:Path.t -> 'acc -> int -> 'v -> ('acc, 'r) cont + (** A ('val, 'acc, 'r) cps_folder is a CPS, threaded fold function over + values of type ['v] producing an accumulator of type ['acc]. *) + + let fold : type acc. + order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + force:acc force -> + cache:bool -> + uniq:uniq -> + pre:(acc, step list) folder option -> + post:(acc, step list) folder option -> + path:Path.t -> + ?depth:depth -> + node:(acc, _) folder -> + contents:(acc, contents) folder -> + tree:(acc, _) folder -> + t -> + acc -> + acc = + fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents + ~tree t acc -> + let env = t.info.env in + let marks = + match uniq with + | `False -> dummy_marks + | `True -> empty_marks () + | `Marks n -> n + in + let pre path bindings acc = + match pre with + | None -> acc + | Some pre -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + pre path s acc + in + let post path bindings acc = + match post with + | None -> acc + | Some post -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + post path s acc + in + let rec aux : type r. (t, acc, r) cps_folder = + fun ~path acc d t k -> + let apply acc = node path t acc |> tree path (`Node t) in + let next acc = + match force with + | `True -> ( + match order with + | `Random state -> + let m, mi = to_map ~cache t |> get_ok "fold" in + let arr = + Array.append (StepMap.to_array m) (StepMap.to_array mi) + in + let () = shuffle state arr in + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k + | `Sorted -> + let m = to_map ~cache t |> get_ok "fold" in + (map [@tailcall]) ~path acc d (Some m) k + | `Undefined -> ( + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> (map [@tailcall]) ~path acc d (Some m) k + | Repo_value (repo, v) -> + (value [@tailcall]) ~path acc d (repo, v, None) k + | Repo_key (repo, _key) -> + let v = to_value ~cache t |> get_ok "fold" in + (value [@tailcall]) ~path acc d (repo, v, None) k + | Value_dirty (repo, v, um) -> + (value [@tailcall]) ~path acc d (repo, v, Some um) k + | Portable p -> (portable [@tailcall]) ~path acc d (p, None) k + | Portable_dirty (p, um) -> + (portable [@tailcall]) ~path acc d (p, Some um) k + | Pruned h -> pruned_hash_exn "fold" h)) + | `False skip -> ( + match cached_map t with + | Some (n, ni) -> ( + match order with + | `Sorted | `Undefined -> + (map [@tailcall]) ~path acc d (Some (n, ni)) k + | `Random state -> + let arr = + Array.append (StepMap.to_array n) (StepMap.to_array ni) + in + shuffle state arr; + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k) + | None -> + (* XXX: That node is skipped if is is of tag Value *) + skip path acc |> k) + in + match depth with + | None -> apply acc |> next + | Some (`Eq depth) -> if d < depth then next acc else apply acc |> k + | Some (`Le depth) -> + if d < depth then apply acc |> next else apply acc |> k + | Some (`Lt depth) -> + if d < depth - 1 then apply acc |> next else apply acc |> k + | Some (`Ge depth) -> if d < depth then next acc else apply acc |> next + | Some (`Gt depth) -> if d <= depth then next acc else apply acc |> next + and aux_uniq : type r. (t, acc, r) cps_folder = + fun ~path acc d t k -> + if uniq = `False then (aux [@tailcall]) ~path acc d t k + else + let h = hash ~cache t in + match Hashes.add marks h with + | `Duplicate -> k acc + | `Ok -> (aux [@tailcall]) ~path acc d t k + and step : type r. (step * elt, acc, r) cps_folder = + fun ~path acc d (s, v) k -> + let path = Path.rcons path s in + match v with + | `Node n -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k + | `Contents c -> ( + let apply () = + let tree path = tree path (`Contents c) in + Contents.fold ~force ~cache ~path contents tree (fst c) acc |> k + in + match depth with + | None -> apply () + | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc + | Some (`Le depth) -> if d < depth then apply () else k acc + | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc + | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc + | Some (`Gt depth) -> if d >= depth then apply () else k acc) + | `Contents_inlined_3 c -> ( + let apply () = + let tree path = tree path (`Contents c) in + Contents.fold ~force ~cache ~path contents tree (fst c) acc |> k + in + match depth with + | None -> apply () + | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc + | Some (`Le depth) -> if d < depth then apply () else k acc + | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc + | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc + | Some (`Gt depth) -> if d >= depth then apply () else k acc) + and steps : type r. ((step * elt) Seq.t, acc, r) cps_folder = + fun ~path acc d s k -> + match s () with + | Seq.Nil -> k acc + | Seq.Cons (h, t) -> + (step [@tailcall]) ~path acc d h (fun acc -> + (steps [@tailcall]) ~path acc d t k) + and map : type r. (map option, acc, r) cps_folder = + fun ~path acc d m k -> + match m with + | None -> k acc + | Some (m, mi) -> + let bindings = Seq.append (StepMap.to_seq m) (StepMap.to_seq mi) in + seq ~path acc d bindings k + and value : type r. (repo * value * updatemap option, acc, r) cps_folder = + fun ~path acc d (repo, v, updates) k -> + let bindings = Regular_value.seq ~env ~cache repo v in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and portable : type r. (portable * updatemap option, acc, r) cps_folder = + fun ~path acc d (v, updates) k -> + let bindings = Portable_value.seq ~env ~cache () v in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and seq : type r. ((step * elt) Seq.t, acc, r) cps_folder = + fun ~path acc d bindings k -> + let acc = pre path bindings acc in + (steps [@tailcall]) ~path acc d bindings (fun acc -> + post path bindings acc |> k) + in + aux_uniq ~path acc 0 t Fun.id + + let incremental_length t step up n updates = + match Lazy_cache.inspect t.info.length with + | None -> None + | Some len -> + Some + (Lazy_cache.make (fun () -> + let len = Lazy_cache.force_exn len in + let exists = + match StepMap.find_opt step updates with + | Some (Add _) -> true + | Some Remove -> false + | None -> ( + match P.Node.Val.find n step with + | None -> false + | Some _ -> true) + in + match up with + | Add _ when not exists -> len + 1 + | Remove when exists -> len - 1 + | _ -> len)) + + let clear_findv_cache t step = + match Atomic.get t.info.findv_cache with + | None -> None + | Some (m, mi) -> Some (StepMap.remove step m, StepMap.remove step mi) + + let update t step up = + Fmt.pr "update %a@." (Repr.pp step_t) step; + let env = t.info.env in + let of_map (m, mi) = + let m' = + match up with + | Remove -> StepMap.remove step m + | Add v -> StepMap.add step v m + in + if m == m' then t else of_map ~env (m', mi) + in + let of_value repo n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t + else + let length = incremental_length t step up n updates in + let findv_cache = clear_findv_cache t step in + of_value ?length ?findv_cache ~env repo n ~updates:updates' + in + let of_portable n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t + else + let findv_cache = clear_findv_cache t step in + of_portable_dirty ?findv_cache ~env n updates' + in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map (m, mi) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_map (m, mi) + | Repo_value (repo, v) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_value repo v StepMap.empty + | Repo_key (repo, k) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + let v = value_of_key ~cache:true t repo k |> get_ok "update" in + of_value repo v StepMap.empty + | Value_dirty (repo, v, um) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_value repo v um + | Portable p -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_portable p StepMap.empty + | Portable_dirty (p, um) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_portable p um + | Pruned h -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + pruned_hash_exn "update" h + + let remove t step = update t step Remove + let add t step v = update t step (Add v) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t node = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare node of_v (fun t -> Atomic.get t.v) + + let _, t = + Type.mu2 (fun _ y -> + let elt = elt_t y in + let v = v_t elt in + let t = t v in + (v, t)) + + let elt_t = elt_t t + let dump = Type.pp_dump t + + let rec merge : type a. (t Merge.t -> a) -> a = + fun k -> + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let m = to_map ~cache:true old |> Option.of_result in + Ok (Some m)) + in + match merge_env x.info.env y.info.env with + | Error _ as e -> e + | Ok env -> + let x = to_map ~cache:true x |> Option.of_result in + let y = to_map ~cache:true y |> Option.of_result in + assert false + (* let m = + StepMap.merge elt_t (fun _step -> + (merge_elt [@tailcall]) Merge.option) + in + Merge.(f @@ option m) ~old x y |> function + | Ok (Some map) -> Ok (of_map ~env map) + | Ok None -> Error (`Conflict "empty map") + | Error _ as e -> e) *) + in + k (Merge.v t f) + + and merge_elt : type r. (elt Merge.t, r) cont = + fun k -> + let open Merge.Infix in + let f : elt Merge.f = + fun ~old x y -> + match (x, y) with + | `Contents (x, cx), `Contents (y, cy) -> + let mold = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (_, m) -> ok (Some m) + | `Contents_inlined_3 (_, m) -> ok (Some m) + | `Node _ -> ok None) + in + Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (c, _) -> ok (Some c) + | `Contents_inlined_3 (c, _) -> ok (Some c) + | `Node _ -> ok None) + in + Merge.(f Contents.merge) ~old x y >>=* fun c -> + Merge.ok (`Contents (c, m)) + (* TODO inlined *) + | `Node x, `Node y -> + (merge [@tailcall]) (fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents _ -> ok None + | `Contents_inlined_3 _ -> ok None + | `Node n -> ok (Some n)) + in + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) + | _ -> Merge.conflict "add/add values" + in + k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) + + let merge_elt = merge_elt (fun x -> x) + end + + type node = Node.t [@@deriving irmin ~pp] + type node_key = Node.key [@@deriving irmin ~pp] + type contents_key = Contents.key [@@deriving irmin ~pp] + + type kinded_key = + [ `Contents of Contents.key * metadata + | `Node of Node.key + | `Node_with_inlined of Node.key * (Contents.key * metadata) list ] + [@@deriving irmin] + + type kinded_hash = + [ `Contents of hash * metadata + | `Node_with_inlined of hash * (hash * metadata) list + | `Node of hash ] + [@@deriving irmin ~equal] + + type t = + [ `Node of node + | `Contents of Contents.t * Metadata.t + | `Contents_inlined_3 of Contents.t * metadata ] + [@@deriving irmin] + + let to_backend_node n = + Node.to_value ~cache:true n |> get_ok "to_backend_node" + + let to_backend_portable_node n = + Node.to_portable_value ~cache:true n |> get_ok "to_backend_portable_node" + + let of_backend_node repo n = + let env = Env.empty () in + let length = Lazy_cache.make (fun () -> P.Node.Val.length n) in + Node.of_value ~length ~env repo n + + let dump ppf = function + | `Node n -> Fmt.pf ppf "node: %a" Node.dump n + | `Contents (c, _) -> Fmt.pf ppf "contents: %a" (Type.pp Contents.t) c + | `Contents_inlined_3 (c, _) -> + Fmt.pf ppf "inlined contents: %a" (Type.pp Contents.t) c + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 + || (c1 == c2 && m1 == m2) + || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let equal (x : t) (y : t) = + x == y + || + match (x, y) with + | `Node x, `Node y -> Node.equal x y + | `Contents x, `Contents y -> contents_equal x y + | `Contents_inlined_3 x, `Contents_inlined_3 y -> contents_equal x y + | `Node _, `Contents _ + | `Node _, `Contents_inlined_3 _ + | `Contents _, `Node _ + | `Contents _, `Contents_inlined_3 _ + | `Contents_inlined_3 _, `Node _ + | `Contents_inlined_3 _, `Contents _ -> + false + + let is_empty = function + | `Node n -> Node.is_empty ~cache:true n + | `Contents _ -> false + | `Contents_inlined_3 _ -> false + + type elt = + [ `Node of node + | `Contents of contents * metadata + | `Contents_inlined_4 of contents * metadata ] + + let of_node n = `Node n + + let of_contents ?(metadata = Metadata.default) c = + let env = Env.empty () in + let c = Contents.of_value ~env c in + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + Fmt.pr "%a@." (Repr.pp Contents.t) c; + let len = + match Repr.Size.of_value Contents.t with + | Dynamic f -> f c + | Static len -> len + | Unknown -> assert false + in + Fmt.pr "%d@." len; + if len < 16 then `Contents_inlined_3 (c, metadata) + else `Contents (c, metadata) + + let of_contents_inlined ?(metadata = Metadata.default) c = + let env = Env.empty () in + let c = Contents.of_value ~env c in + `Contents_inlined_3 (c, metadata) + + let v : elt -> t = function + | `Contents_inlined_4 (c, metadata) -> of_contents_inlined ~metadata c + | `Contents (c, metadata) -> of_contents ~metadata c + | `Node n -> `Node n + + let pruned_with_env ~env = function + | `Contents (h, meta) -> `Contents (Contents.pruned ~env h, meta) + | `Node_with_inlined _ -> assert false + | `Node h -> `Node (Node.pruned ~env h) + + let pruned h = + let env = Env.empty () in + pruned_with_env ~env h + + let destruct x = x + + let clear ?(depth = 0) = function + | `Node n -> Node.clear ~max_depth:depth 0 n + | `Contents _ -> () + | `Contents_inlined_3 _ -> () + + let sub ~cache ctx t path = + let rec aux node path = + match Path.decons path with + | None -> Some node + | Some (h, p) -> ( + Node.findv ~cache ctx node h |> function + | None | Some (`Contents _) | Some (`Contents_inlined_3 _) -> None + | Some (`Node n) -> (aux [@tailcall]) n p) + in + match t with + | `Node n -> (aux [@tailcall]) n path + | `Contents _ -> None + | `Contents_inlined_3 _ -> None + + let find_tree (t : t) path = + let cache = true in + [%log.debug "Tree.find_tree %a" pp_path path]; + match (t, Path.rdecons path) with + | v, None -> Some v + | _, Some (path, file) -> ( + sub ~cache "find_tree.sub" t path |> function + | None -> None + | Some n -> Node.findv ~cache "find_tree.findv" n file) + + let id _ _ acc = acc + + let fold ?(order = `Sorted) ?(force = `True) ?(cache = false) ?(uniq = `False) + ?pre ?post ?depth ?(contents = id) ?(node = id) ?(tree = id) (t : t) acc = + match t with + | `Contents (c, _) as c' -> + let tree path = tree path c' in + Contents.fold ~force ~cache ~path:Path.empty contents tree c acc + | `Contents_inlined_3 (c, _) as c' -> + let tree path = tree path c' in + Contents.fold ~force ~cache ~path:Path.empty contents tree c acc + | `Node n -> + Node.fold ~order ~force ~cache ~uniq ~pre ~post ~path:Path.empty ?depth + ~contents ~node ~tree n acc + + type stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int; + } + [@@deriving irmin] + + let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + let incr_nodes s = { s with nodes = s.nodes + 1 } + let incr_leafs s = { s with leafs = s.leafs + 1 } + let incr_skips s = { s with skips = s.skips + 1 } + + let set_depth p s = + let n_depth = List.length (Path.map p (fun _ -> ())) in + let depth = max n_depth s.depth in + { s with depth } + + let set_width childs s = + let width = max s.width (List.length childs) in + { s with width } + + let err_not_found n k = + Fmt.kstr invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k + + let get_tree (t : t) path = + find_tree t path |> function + | None -> err_not_found "get_tree" path + | Some v -> v + + let find_all t k = + find_tree t k |> function + | None | Some (`Node _) -> None + | Some (`Contents (c, m)) -> + let c = Contents.to_value ~cache:true c in + Some (get_ok "find_all" c, m) + | Some (`Contents_inlined_3 (c, m)) -> + let c = Contents.to_value ~cache:true c in + Some (get_ok "find_all" c, m) + + let find t k = find_all t k |> function None -> None | Some (c, _) -> Some c + + let get_all t k = + find_all t k |> function None -> err_not_found "get" k | Some v -> v + + let get t k = get_all t k |> fun (c, _) -> c + let mem t k = find t k |> function None -> false | _ -> true + let mem_tree t k = find_tree t k |> function None -> false | _ -> true + + let kind t path = + let cache = true in + [%log.debug "Tree.kind %a" pp_path path]; + match (t, Path.rdecons path) with + | `Contents _, None -> Some `Contents + | `Contents_inlined_3 _, None -> Some `Contents_inlined__1 + (* TODO inlined *) + | `Node _, None -> Some `Node + | _, Some (dir, file) -> ( + sub ~cache "kind.sub" t dir |> function + | None -> None + | Some m -> ( + Node.findv ~cache "kind.findv" m file |> function + | None -> None + | Some (`Contents _) -> Some `Contents + | Some (`Contents_inlined_3 _) -> Some `Contents_inlined__1 + | Some (`Node _) -> Some `Node)) + + let length t ?(cache = true) path = + [%log.debug "Tree.length %a" pp_path path]; + sub ~cache "length" t path |> function + | None -> 0 + | Some n -> Node.length ~cache:true n + + let seq t ?offset ?length ?(cache = true) path = + [%log.debug "Tree.seq %a" pp_path path]; + sub ~cache "seq.sub" t path |> function + | None -> Seq.empty + | Some n -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + Node.seq ?offset ?length ~cache n |> get_ok "seq" + + let list t ?offset ?length ?(cache = true) path = + seq t ?offset ?length ~cache path |> List.of_seq + + let empty () = `Node (Node.empty ()) + + let singleton k ?(metadata = Metadata.default) c = + [%log.debug "Tree.singleton %a" pp_path k]; + let env = Env.empty () in + let base_tree = `Contents (Contents.of_value ~env c, metadata) in + Path.fold_right k + ~f:(fun step child -> `Node (Node.singleton ~env step child)) + ~init:base_tree + + (** During recursive updates, we keep track of whether or not we've made a + modification in order to avoid unnecessary allocations of identical tree + objects. *) + type 'a updated = Changed of 'a | Unchanged + + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (x, y) with + | `Node x, `Node y -> Node.maybe_equal x y + | _ -> if equal x y then True else False + + let get_env = function + | `Node n -> n.Node.info.env + | `Contents (c, _) -> c.Contents.info.env + | `Contents_inlined_3 (c, _) -> c.Contents.info.env + + let update_tree ~cache ~f_might_return_empty_node ~(f : t option -> t option) + root_tree path = + (* User-introduced empty nodes will be removed immediately if necessary. *) + let prune_empty : node -> bool = + if not f_might_return_empty_node then Fun.const false + else Node.is_empty ~cache + in + match Path.rdecons path with + | None -> ( + let empty_tree = + match is_empty root_tree with + | true -> root_tree + | false -> `Node (Node.empty ()) + in + match f (Some root_tree) with + (* Here we consider "deleting" a root contents value or node to consist + of changing it to an empty node. Note that this introduces + sensitivity to ordering of subtree operations: updating in a subtree + and adding the subtree are not necessarily commutative. *) + | None -> empty_tree + | Some (`Node _ as new_root) -> ( + match maybe_equal root_tree new_root with + | True -> root_tree + | Maybe | False -> new_root) + | Some (`Contents c' as new_root) -> ( + match root_tree with + | `Contents c when contents_equal c c' -> root_tree + | _ -> new_root) + | Some (`Contents_inlined_3 c' as new_root) -> ( + match root_tree with + | `Contents_inlined_3 c when contents_equal c c' -> root_tree + | _ -> new_root)) + | Some (path, file) -> ( + Fmt.pr "HERE %a %a@." (Repr.pp path_t) path (Repr.pp step_t) file; + let rec aux : type r. path -> node -> (node updated, r) cont = + fun path parent_node k -> + let changed n = k (Changed n) in + match Path.decons path with + | None -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + let with_new_child t = Node.add parent_node file t |> changed in + let old_binding = + Node.findv ~cache "update_tree.findv" parent_node file + in + let new_binding = f old_binding in + match (old_binding, new_binding) with + | None, None -> k Unchanged + | None, Some (`Contents _ as t) -> with_new_child t + | None, Some (`Contents_inlined_3 _ as t) -> with_new_child t + | None, Some (`Node n as t) -> ( + match prune_empty n with + | true -> k Unchanged + | false -> with_new_child t) + | Some _, None -> Node.remove parent_node file |> changed + | Some old_value, Some (`Node n as t) -> ( + match prune_empty n with + | true -> Node.remove parent_node file |> changed + | false -> ( + match maybe_equal old_value t with + | True -> k Unchanged + | Maybe | False -> with_new_child t)) + | Some (`Contents c), Some (`Contents c' as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Contents_inlined_3 c), Some (`Contents c' as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Contents c'), Some (`Contents_inlined_3 c as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Contents_inlined_3 c'), Some (`Contents_inlined_3 c as t) + -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Node _), Some (`Contents _ as t) -> with_new_child t + | Some (`Node _), Some (`Contents_inlined_3 _ as t) -> + with_new_child t + (* | Some (`Contents_inlined_3 c), Some (`Contents_inlined_3 c') -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t + | ) *) + (* | Some (`Contents_inlined_3 _), _ -> assert false + | _, Some (`Contents_inlined_3 _) -> assert false) *) + ) + | Some (step, key_suffix) -> + let old_binding = + Node.findv ~cache "update_tree.findv" parent_node step + in + let to_recurse = + match old_binding with + | Some (`Node child) -> child + | None | Some (`Contents _) | Some (`Contents_inlined_3 _) -> + Node.empty () + in + (aux [@tailcall]) key_suffix to_recurse (function + | Unchanged -> + (* This includes [remove]s in an empty node, in which case we + want to avoid adding a binding anyway. *) + k Unchanged + | Changed child -> ( + match Node.is_empty ~cache child with + | true -> + (* A [remove] has emptied previously non-empty child with + binding [h], so we remove the binding. *) + Node.remove parent_node step |> changed + | false -> + Fmt.pr + "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + Node.add parent_node step (`Node child) |> changed)) + in + let top_node = + match root_tree with + | `Node n -> n + | `Contents _ -> Node.empty () + | `Contents_inlined_3 _ -> Node.empty () + in + aux path top_node @@ function + | Unchanged -> root_tree + | Changed node -> + Env.copy ~into:node.info.env (get_env root_tree); + `Node node) + + let update t k ?(metadata = Metadata.default) f = + let cache = true in + [%log.debug "Tree.update %a" pp_path k]; + update_tree ~cache t k ~f_might_return_empty_node:false ~f:(fun t -> + let old_contents = + match t with + | Some (`Node _) | None -> None + | Some (`Contents (c, _)) -> + let c = Contents.to_value ~cache c in + Some (get_ok "update" c) + | Some (`Contents_inlined_3 (c, _)) -> + let c = Contents.to_value ~cache c in + Some (get_ok "update" c) + in + match f old_contents with + | None -> None + | Some c -> of_contents ~metadata c |> Option.some) + + let rec inline_tree (t : t) = + match t with + | `Node ({ v; _ } : Node.t) -> ( + match Atomic.get v with + | Map (map, _mapi) -> + Fmt.pr "@[Map@,"; + StepMap.iter (fun _ t -> inline_tree t) map; + let p1, p2 = + StepMap.partition + (fun _ -> function `Contents_inlined_3 _ -> true | _ -> false) + map + in + let print = + StepMap.iter (fun step -> function + | `Node _ -> Fmt.pr "Node / step: %a@," (Repr.pp step_t) step + | `Contents _ -> + Fmt.pr "Contents / step: %a@," (Repr.pp step_t) step + | `Contents_inlined_3 _ -> + Fmt.pr "Contents_inlined / step: %a@," (Repr.pp step_t) step) + in + Fmt.pr "TO INLINE:@,"; + print p1; + Fmt.pr "NOT TO INLINE:@,"; + print p2; + Fmt.pr "@]@," + | Key _ -> Fmt.pr "Key@," + | Value _ -> Fmt.pr "Value@," + | Portable_dirty _ -> Fmt.pr "Portable_dirty@," + | Pruned _ -> Fmt.pr "Pruned@,") + | `Contents _ -> () + | `Contents_inlined_3 _ -> () + (* [ `Node of node + | `Contents of Contents.t * Metadata.t + | `Contents_inlined_3 of Contents.t * metadata ] *) + + let add t k ?(metadata = Metadata.default) c = + [%log.debug "Tree.add %a" pp_path k]; + ignore @@ inline_tree t; + (* update_tree ~cache:true (inline_tree t) k *) + update_tree ~cache:true t k + ~f:(fun _ -> Some (of_contents ~metadata c)) + ~f_might_return_empty_node:false + + let add_tree t k v = + [%log.debug "Tree.add_tree %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Some v) + ~f_might_return_empty_node:true + + let remove t k = + [%log.debug "Tree.remove %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> None) + ~f_might_return_empty_node:false + + let update_tree t k f = + [%log.debug "Tree.update_tree %a" pp_path k]; + update_tree ~cache:true t k ~f ~f_might_return_empty_node:true + + let import repo = function + | `Contents (k, m) -> ( + Atomic.incr cnt.contents_mem; + P.Contents.mem (P.Repo.contents_t repo) k |> function + | true -> + let env = Env.empty () in + Some (`Contents (Contents.of_key ~env repo k, m)) + | false -> None) + | `Node_with_inlined _ -> assert false + | `Node k -> ( + Atomic.incr cnt.node_mem; + P.Node.mem (P.Repo.node_t repo) k |> function + | true -> + let env = Env.empty () in + Some (`Node (Node.of_key ~env repo k)) + | false -> None) + + let import_with_env ~env repo = function + | `Node k -> `Node (Node.of_key ~env repo k) + | `Node_with_inlined _ -> assert false + | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) + + let import_no_check repo f = + let env = Env.empty () in + import_with_env ~env repo f + + let same_repo r1 r2 = + r1 == r2 || Conf.equal (P.Repo.config r1) (P.Repo.config r2) + + (* Given an arbitrary tree value, persist its contents to the given contents + and node stores via a depth-first {i post-order} traversal. We must export + a node's children before the node itself in order to get the {i keys} of + any un-persisted child values. *) + let export ?clear repo contents_t node_t n = + [%log.debug "Tree.export clear=%a" Fmt.(option bool) clear]; + let cache = + match clear with + | Some true | None -> + (* This choice of [cache] flag has no impact, since we either + immediately clear the corresponding cache or are certain that + the it is already filled. *) + false + | Some false -> true + in + + let add_node n v k = + Atomic.incr cnt.node_add; + let key = P.Node.add node_t v in + let () = + (* Sanity check: Did we just store the same hash as the one represented + by the Tree.Node [n]? *) + match Node.cached_hash n with + | None -> + (* No hash is in [n]. Computing it would result in getting it from + [v] or rebuilding a private node. *) + () + | Some h' -> + let h = P.Node.Key.to_hash key in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent node binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" + pp_node_key key Node.pp_value v pp_hash h' + in + k key + in + + let add_node_map n (x : Node.map) k = + let node = + (* Since we traverse in post-order, all children of [x] have already + been added. Thus, their keys are cached and we can retrieve them. *) + Atomic.incr cnt.node_val_v; + StepMap.to_seq (x + |> Seq.map (fun (step, v) -> + match v with + | `Node n -> ( + match Node.cached_key n with + | Some k -> (step, `Node k) + | None -> + assertion_failure + "Encountered child node value with uncached key \ + during export:@,\ + @ @[%a@]" + dump v) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" + dump v) + | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" + dump v)) + |> P.Node.Val.of_seq + in + add_node n node k + in + + let add_updated_node n (v : Node.value) (updates : Node.updatemap) k = + let node = + StepMap.fold + (fun k v acc -> + match v with + | Node.Remove -> P.Node.Val.remove acc k + | Node.Add (`Node n as v) -> ( + match Node.cached_key n with + | Some ptr -> P.Node.Val.add acc k (`Node ptr) + | None -> + assertion_failure + "Encountered child node value with uncached key during \ + export:@,\ + @ @[%a@]" + dump v) + | Add (`Contents (c, m) as v) -> ( + match Contents.cached_key c with + | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" + dump v) + | Add (`Contents_inlined_3 (c, m) as v) -> ( + match Contents.cached_key c with + | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" + dump v)) + updates v + in + add_node n node k + in + + let rec on_node : type r. [ `Node of node ] -> (node_key, r) cont = + fun (`Node n) k -> + let k key = + (* All the nodes in the exported tree should be cleaned using + [Node.export]. This ensures that [key] is stored in [n]. *) + Node.export ?clear repo n key; + k key + in + let has_repo = + match Atomic.get n.Node.v with + | Node.Key (repo', _) -> + if same_repo repo repo' then true + else + (* Case 1. [n] is a key from another repo. Let's crash. + + We could also only crash if the hash in the key is unknown to + [repo], or completely ignore the issue. *) + failwith "Can't export the node key from another repo" + | Value (repo', _, _) -> + if same_repo repo repo' then true + else + (* Case 2. [n] is a value from another repo. Let's crash. + + We could also ignore the issue. *) + failwith "Can't export a node value from another repo" + | Pruned _ | Portable_dirty _ | Map _ -> false + in + match Atomic.get n.Node.v with + | Pruned h -> + (* Case 3. [n] is a pruned hash. [P.Node.index node_t h] could be + different than [None], but let's always crash. *) + pruned_hash_exn "export" h + | Portable_dirty _ -> + (* Case 4. [n] is a portable value with diffs. The hash of the + reconstructed portable value could be known by [repo], but let's + always crash. *) + portable_value_exn "export" + | Map _ | Value _ | Key _ -> ( + match Node.cached_key n with + | Some key -> + if has_repo then + (* Case 5. [n] is a key that is accompanied by the [repo]. Let's + assume that [P.Node.mem node_t key] is [true] for performance + reason (not benched). *) + k key + else ( + Atomic.incr cnt.node_mem; + let mem = P.Node.mem node_t key in + if not mem then + (* Case 6. [n] contains a key that is not known by [repo]. + Let's abort. *) + failwith "Can't export a key unkown from the repo" + else + (* Case 7. [n] contains a key that is known by the [repo]. *) + k key) + | None -> ( + let skip_when_some = + match Node.cached_hash n with + | None -> + (* No pre-computed hash. *) + None + | Some h -> ( + Atomic.incr cnt.node_index; + P.Node.index node_t h |> function + | None -> + (* Pre-computed hash is unknown by repo. + + NOTE: it's possible that this value already has a key + in the store, but it's not indexed. If so, we're + adding a duplicate here – this isn't an issue for + correctness, but does waste space. *) + None + | Some key -> + Atomic.incr cnt.node_mem; + let mem = P.Node.mem node_t key in + if mem then + (* Case 8. The pre-computed hash is converted into + a key *) + Some key + else + (* The backend could produce a key from [h] but + doesn't know [h]. *) + None) + in + match skip_when_some with + | Some key -> k key + | None -> ( + (* Only [Map _ | Value _] possible now. + + Case 9. Let's export it to the backend. *) + let new_children_seq = + let seq = + match Atomic.get n.Node.v with + | Value (_, _, Some m) -> + StepMap.to_seq m + |> Seq.filter_map (function + | step, Node.Add v -> Some (step, v) + | _, Remove -> None) + | Map m -> StepMap.to_seq m + | Value (_, _, None) -> Seq.empty + | Key _ | Portable_dirty _ | Pruned _ -> + (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is + excluded above. *) + assert false + in + Seq.map (fun (_, x) -> x) seq + in + on_node_seq new_children_seq @@ fun `Node_children_exported -> + match (Atomic.get n.Node.v, Node.cached_value n) with + | Map x, _ -> add_node_map n x k + | Value (_, v, None), None | _, Some v -> add_node n v k + | Value (_, v, Some um), _ -> add_updated_node n v um k + | (Key _ | Portable_dirty _ | Pruned _), _ -> + (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is + excluded above. *) + assert false))) + and on_contents : type r. + [ `Contents of Contents.t * metadata ] -> + ([ `Content_exported ], r) cont = + fun (`Contents (c, _)) k -> + match Atomic.get c.Contents.v with + | Contents.Key (_, key) -> + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Value _ -> + let v = Contents.to_value ~cache c in + let v = get_ok "export" v in + Atomic.incr cnt.contents_add; + let key = P.Contents.add contents_t v in + let () = + let h = P.Contents.Key.to_hash key in + let h' = Contents.hash ~cache c in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent contents binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" + pp_contents_key key pp_contents v pp_hash h' + in + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Pruned h -> pruned_hash_exn "export" h + and on_contents_inlined : type r. + [ `Contents_inlined_3 of Contents.t * metadata ] -> + ([ `Content_exported ], r) cont = + fun (`Contents_inlined_3 (c, _)) k -> + match Atomic.get c.Contents.v with + | Contents.Key (_, key) -> + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Value _ -> + let v = Contents.to_value ~cache c in + let v = get_ok "export" v in + Atomic.incr cnt.contents_add; + let key = P.Contents.add contents_t v in + let () = + let h = P.Contents.Key.to_hash key in + let h' = Contents.hash ~cache c in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent contents binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" + pp_contents_key key pp_contents v pp_hash h' + in + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Pruned h -> pruned_hash_exn "export" h + and on_node_seq : type r. + Node.elt Seq.t -> ([ `Node_children_exported ], r) cont = + fun seq k -> + match seq () with + | Seq.Nil -> + (* Have iterated on all children, let's export parent now *) + k `Node_children_exported + | Seq.Cons ((`Node _ as n), rest) -> + on_node n (fun _node_key -> on_node_seq rest k) + | Seq.Cons ((`Contents _ as c), rest) -> + on_contents c (fun `Content_exported -> on_node_seq rest k) + | Seq.Cons ((`Contents_inlined_3 _ as c), rest) -> + on_contents_inlined c (fun `Content_exported -> on_node_seq rest k) + in + on_node (`Node n) (fun key -> key) + + let merge : t Merge.t = + let f ~old (x : t) y = + Merge.(f Node.merge_elt) ~old x y |> function + | Ok t -> Merge.ok t + | Error e -> Error e + in + Merge.v t f + + let entries path tree = + let rec aux acc = function + | [] -> acc + | (path, h) :: todo -> + let childs = Node.bindings ~cache:true h |> get_ok "entries" in + let acc, todo = + List.fold_left + (fun (acc, todo) (k, v) -> + let path = Path.rcons path k in + match v with + | `Node v -> (acc, (path, v) :: todo) + | `Contents c -> ((path, c) :: acc, todo) + | `Contents_inlined_3 c -> ((path, c) :: acc, todo)) + (acc, todo) childs + in + (aux [@tailcall]) acc todo + in + (aux [@tailcall]) [] [ (path, tree) ] + + (** Given two forced lazy values, return an empty diff if they both use the + same dangling hash. *) + let diff_force_result (type a b) ~(empty : b) ~(diff_ok : a * a -> b) + (x : a or_error) (y : a or_error) : b = + match (x, y) with + | ( Error (`Dangling_hash h1 | `Pruned_hash h1), + Error (`Dangling_hash h2 | `Pruned_hash h2) ) -> ( + match equal_hash h1 h2 with true -> empty | false -> assert false) + | Error _, Ok _ -> assert false + | Ok _, Error _ -> assert false + | Ok x, Ok y -> diff_ok (x, y) + | Error _, Error _ -> assert false + + let diff_contents x y = + if Node.contents_equal x y then [] + else + let cx = Contents.to_value ~cache:true (fst x) in + let cy = Contents.to_value ~cache:true (fst y) in + diff_force_result cx cy ~empty:[] ~diff_ok:(fun (cx, cy) -> + [ `Updated ((cx, snd x), (cy, snd y)) ]) + + let diff_node (x : node) (y : node) = + let bindings n = + Node.to_map ~cache:true n |> function + | Ok m -> Ok (StepMap.bindings m) + | Error _ as e -> e + in + let removed acc (k, (c, m)) = + let c = Contents.to_value ~cache:true c |> get_ok "diff_node" in + (k, `Removed (c, m)) :: acc + in + let added acc (k, (c, m)) = + let c = Contents.to_value ~cache:true c |> get_ok "diff_node" in + (k, `Added (c, m)) :: acc + in + let rec diff_bindings acc todo path x y = + let acc = ref acc in + let todo = ref todo in + let () = + alist_iter2 compare_step + (fun key v () -> + let path = Path.rcons path key in + match v with + (* Left *) + | `Left (`Contents x) -> + let x = removed !acc (path, x) in + acc := x + | `Left (`Contents_inlined_3 x) -> + let x = removed !acc (path, x) in + acc := x + | `Left (`Node x) -> + let xs = entries path x in + let xs = List.fold_left removed !acc xs in + acc := xs + (* Right *) + | `Right (`Contents y) -> + let y = added !acc (path, y) in + acc := y + | `Right (`Contents_inlined_3 y) -> + let y = added !acc (path, y) in + acc := y + | `Right (`Node y) -> + let ys = entries path y in + let ys = List.fold_left added !acc ys in + acc := ys + (* Both *) + | `Both (`Node x, `Node y) -> todo := (path, x, y) :: !todo + | `Both (`Contents x, `Node y) + | `Both (`Contents_inlined_3 x, `Node y) -> + let ys = entries path y in + let x = removed !acc (path, x) in + let ys = List.fold_left added x ys in + acc := ys + | `Both (`Node x, `Contents y) + | `Both (`Node x, `Contents_inlined_3 y) -> + let xs = entries path x in + let y = added !acc (path, y) in + let ys = List.fold_left removed y xs in + acc := ys + | `Both (`Contents x, `Contents y) -> + let content_diffs = + diff_contents x y |> List.map (fun d -> (path, d)) + in + acc := content_diffs @ !acc + | `Both (`Contents x, `Contents_inlined_3 y) + | `Both (`Contents_inlined_3 x, `Contents y) + | `Both (`Contents_inlined_3 x, `Contents_inlined_3 y) -> + let content_diffs = + diff_contents x y |> List.map (fun d -> (path, d)) + in + acc := content_diffs @ !acc) + x y + in + (diff_node [@tailcall]) !acc !todo + and diff_node acc = function + | [] -> acc + | (path, x, y) :: todo -> + if Node.equal x y then (diff_node [@tailcall]) acc todo + else + let x = bindings x in + let y = bindings y in + diff_force_result ~empty:[] + ~diff_ok:(fun (x, y) -> diff_bindings acc todo path x y) + x y + in + (diff_node [@tailcall]) [] [ (Path.empty, x, y) ] + + let diff (x : t) (y : t) = + match (x, y) with + | `Contents ((c1, m1) as x), `Contents ((c2, m2) as y) -> + if contents_equal x y then [] + else + let c1 = Contents.to_value ~cache:true c1 |> get_ok "diff" in + let c2 = Contents.to_value ~cache:true c2 |> get_ok "diff" in + [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] + | `Node x, `Node y -> diff_node x y + | `Contents (x, m), `Node y -> + let diff = diff_node (Node.empty ()) y in + let x = Contents.to_value ~cache:true x |> get_ok "diff" in + (Path.empty, `Removed (x, m)) :: diff + | `Node x, `Contents (y, m) -> + let diff = diff_node x (Node.empty ()) in + let y = Contents.to_value ~cache:true y |> get_ok "diff" in + (Path.empty, `Added (y, m)) :: diff + (* TODO inlined *) + | _ -> assert false + + type concrete = + [ `Tree of (Path.step * concrete) list + | `Contents of P.Contents.Val.t * Metadata.t ] + [@@deriving irmin] + + type 'a or_empty = Empty | Non_empty of 'a + + let of_concrete c = + let rec concrete : type r. concrete -> (t or_empty, r) cont = + fun t k -> + match t with + | `Contents (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + k (Non_empty (of_contents ~metadata:m c)) + | `Tree childs -> + tree StepMap.empty childs (function + | Empty -> k Empty + | Non_empty n -> k (Non_empty (`Node n))) + and tree : type r. + Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont + = + fun map t k -> + match t with + | [] -> + k + (if StepMap.is_empty map then Empty + else Non_empty (Node.of_map ~env:(Env.empty ()) map)) + | (s, n) :: t -> + (concrete [@tailcall]) n (fun v -> + (tree [@tailcall]) + (StepMap.update s + (function + | None -> ( + match v with + | Empty -> None (* Discard empty sub-directories *) + | Non_empty v -> Some v) + | Some _ -> + Fmt.invalid_arg + "of_concrete: duplicate bindings for step `%a`" + pp_step s) + map) + t k) + in + (concrete [@tailcall]) c (function Empty -> empty () | Non_empty x -> x) + + let to_concrete t = + let rec tree : type r. t -> (concrete, r) cont = + fun t k -> + match t with + | `Contents c -> contents c k + | `Contents_inlined_3 c -> contents c k + | `Node n -> + let m = Node.to_map ~cache:true n in + let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in + (node [@tailcall]) [] bindings (fun n -> + let n = List.sort (fun (s, _) (s', _) -> compare_step s s') n in + k (`Tree n)) + and contents : type r. Contents.t * metadata -> (concrete, r) cont = + fun (c, m) k -> + let c = Contents.to_value ~cache:true c |> get_ok "to_concrete" in + k (`Contents (c, m)) + and node : type r. + (step * concrete) list -> + (step * Node.elt) list -> + ((step * concrete) list, r) cont = + fun childs x k -> + match x with + | [] -> k childs + | (s, n) :: t -> ( + match n with + | `Node _ as n -> + (tree [@tailcall]) n (fun tree -> node ((s, tree) :: childs) t k) + | `Contents c -> + (contents [@tailcall]) c (fun c -> + (node [@tailcall]) ((s, c) :: childs) t k) + | `Contents_inlined_3 c -> + (contents [@tailcall]) c (fun c -> + (node [@tailcall]) ((s, c) :: childs) t k)) + in + tree t (fun x -> x) + + let key (t : t) = + [%log.debug "Tree.key"]; + match t with + | `Node n -> ( + match Node.key n with Some key -> Some (`Node key) | None -> None) + | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match Contents.key c with + | Some key -> Some (`Contents (key, m)) + | None -> None) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match Contents.key c with + | Some key -> Some (`Contents (key, m)) + | None -> None) + + let hash ?(cache = true) (t : t) = + [%log.debug "Tree.hash"]; + match t with + | `Node n -> `Node (Node.hash ~cache n) + | `Contents (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + `Contents (Contents.hash ~cache c, m) + | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + `Contents (Contents.hash ~cache c, m) + + let stats ?(force = false) (t : t) = + let cache = true in + let force = + if force then `True else `False (fun k s -> set_depth k s |> incr_skips) + in + let contents k _ s = set_depth k s |> incr_leafs in + let pre k childs s = + if childs = [] then s else set_depth k s |> set_width childs |> incr_nodes + in + let post _ _ acc = acc in + fold ~force ~cache ~pre ~post ~contents t empty_stats + + let inspect = function + | `Contents _ -> `Contents + | `Contents_inlined_3 _ -> `Contents_inlined__2 + | `Node n -> + `Node + (match Atomic.get n.Node.v with + | Map _ -> `Map + | Value _ -> `Value + | Key _ -> `Key + | Portable_dirty _ -> `Portable_dirty + | Pruned _ -> `Pruned) + + module Proof = struct + type irmin_tree = t + + include Tree_proof + + type proof_tree = tree + type proof_inode = inode_tree + type node_proof = P.Node_portable.proof + + let proof_of_iproof : proof_inode -> proof_tree = function + | Blinded_inode h -> Blinded_node h + | Inode_values l -> Node l + | Inode_tree i -> Inode i + | Inode_extender ext -> Extender ext + + let rec proof_of_tree : type a. irmin_tree -> (proof_tree -> a) -> a = + fun tree k -> + match tree with + | `Contents_inlined_3 (c, h) -> proof_of_contents c h k + | `Contents (c, h) -> proof_of_contents c h k + | `Node node -> proof_of_node node k + + and proof_of_contents : type a. + Contents.t -> metadata -> (proof_tree -> a) -> a = + fun c m k -> + match Contents.cached_value c with + | Some v -> k (Contents (v, m)) + | None -> k (Blinded_contents (Contents.hash c, m)) + + and proof_of_node : type a. node -> (proof_tree -> a) -> a = + fun node k -> + (* Let's convert [node] to [node_proof]. + + As [node] might not be exported, we can only turn it into a portable + node. *) + let to_portable_value = + let value_of_key ~cache:_ _node _repo k = + let h = P.Node.Key.to_hash k in + err_dangling_hash h + in + Node.to_portable_value_aux ~cache:false ~value_of_key + in + match to_portable_value node with + | Error (`Dangling_hash h) -> k (Blinded_node h) + | Error (`Pruned_hash h) -> k (Blinded_node h) + | Ok v -> + (* [to_proof] may trigger reads. This is fine. *) + let node_proof = P.Node_portable.to_proof v in + proof_of_node_proof node node_proof k + + (** [of_node_proof n np] is [p] (of type [Tree.Proof.t]) which is very + similar to [np] (of type [P.Node.Val.proof]) except that the values + loaded in [n] have been expanded. *) + and proof_of_node_proof : type a. + node -> node_proof -> (proof_tree -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_node h) + | `Inode (length, proofs) -> + iproof_of_inode node length proofs (fun p -> proof_of_iproof p |> k) + | `Values vs -> iproof_of_values node vs (fun p -> proof_of_iproof p |> k) + + and iproof_of_node_proof : type a. + node -> node_proof -> (proof_inode -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_inode h) + | `Inode (length, proofs) -> iproof_of_inode node length proofs k + | `Values vs -> iproof_of_values node vs k + + and iproof_of_inode : type a. + node -> int -> (_ * node_proof) list -> (proof_inode -> a) -> a = + fun node length proofs k -> + let rec aux acc = function + | [] -> k (Inode_tree { length; proofs = List.rev acc }) + | (index, proof) :: rest -> + iproof_of_node_proof node proof (fun proof -> + aux ((index, proof) :: acc) rest) + in + (* We are dealing with an inode A. + Its children are Bs. + The children of Bs are Cs. + *) + match proofs with + | [ (index, proof) ] -> + (* A has 1 child. *) + iproof_of_node_proof node proof (function + | Inode_tree { length = length'; proofs = [ (i, p) ] } -> + (* B is an inode with 1 child, C isn't. *) + assert (length = length'); + k + (Inode_extender { length; segments = [ index; i ]; proof = p }) + | Inode_extender { length = length'; segments; proof } -> + (* B is an inode with 1 child, so is C. *) + assert (length = length'); + k + (Inode_extender + { length; segments = index :: segments; proof }) + | (Blinded_inode _ | Inode_values _ | Inode_tree _) as p -> + (* B is not an inode with 1 child. *) + k (Inode_tree { length; proofs = [ (index, p) ] })) + | _ -> aux [] proofs + + and iproof_of_values : type a. + node -> (step * Node.pnode_value) list -> (proof_inode -> a) -> a = + let findv = + let value_of_key ~cache:_ _node _repo k = + let h = P.Node.Key.to_hash k in + err_dangling_hash h + in + Node.findv_aux ~value_of_key + in + fun node steps k -> + let rec aux acc = function + | [] -> k (Inode_values (List.rev acc)) + | (step, _) :: rest -> ( + match findv ~cache:false "Proof.iproof_of_values" node step with + | None -> assert false + | Some t -> + let k p = aux ((step, p) :: acc) rest in + proof_of_tree t k) + in + aux [] steps + + let of_tree t = proof_of_tree t Fun.id + + let rec load_proof : type a. env:_ -> proof_tree -> (kinded_hash -> a) -> a + = + fun ~env p k -> + match p with + | Blinded_node h -> k (`Node h) + | Node n -> load_node_proof ~env n k + | Inode { length; proofs } -> load_inode_proof ~env length proofs k + | Blinded_contents (h, m) -> k (`Contents (h, m)) + | Contents (v, m) -> + let h = P.Contents.Hash.hash v in + Env.add_contents_from_proof env h v; + k (`Contents (h, m)) + | Extender { length; segments; proof } -> + load_extender_proof ~env length segments proof k + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_extender_proof : type a. + env:_ -> int -> int list -> proof_inode -> (kinded_hash -> a) -> a = + fun ~env len segments p k -> + node_proof_of_proof ~env p (fun p -> + let np = proof_of_extender len segments p in + let v = P.Node_portable.of_proof ~depth:0 np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node_portable.hash_exn v in + Env.add_pnode_from_proof env h v; + k (`Node h)) + + and proof_of_extender len segments p : node_proof = + List.fold_left + (fun acc index -> `Inode (len, [ (index, acc) ])) + p (List.rev segments) + + (* Recontruct private node from [P.Node.Val.empty] *) + and load_node_proof : type a. + env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = + fun ~env n k -> + let rec aux acc = function + | [] -> + let h = P.Node_portable.hash_exn acc in + Env.add_pnode_from_proof env h acc; + k (`Node h) + | (s, p) :: rest -> + let k h = aux (P.Node_portable.add acc s h) rest in + load_proof ~env p k + in + aux (P.Node_portable.empty ()) n + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_inode_proof : type a. + env:_ -> int -> (_ * proof_inode) list -> (kinded_hash -> a) -> a = + fun ~env len proofs k -> + let rec aux : _ list -> _ list -> a = + fun acc proofs -> + match proofs with + | [] -> + let np = `Inode (len, List.rev acc) in + let v = P.Node_portable.of_proof ~depth:0 np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node_portable.hash_exn v in + Env.add_pnode_from_proof env h v; + k (`Node h) + | (i, p) :: rest -> + let k p = aux ((i, p) :: acc) rest in + node_proof_of_proof ~env p k + in + aux [] proofs + + and node_proof_of_proof : type a. + env:_ -> proof_inode -> (node_proof -> a) -> a = + fun ~env t k -> + match t with + | Blinded_inode x -> k (`Blinded x) + | Inode_tree { length; proofs } -> + node_proof_of_inode ~env length proofs k + | Inode_values n -> node_proof_of_node ~env n k + | Inode_extender { length; segments; proof } -> + node_proof_of_proof ~env proof (fun p -> + k (proof_of_extender length segments p)) + + and node_proof_of_inode : type a. + env:_ -> int -> (_ * proof_inode) list -> (node_proof -> a) -> a = + fun ~env length proofs k -> + let rec aux acc = function + | [] -> k (`Inode (length, List.rev acc)) + | (i, p) :: rest -> + node_proof_of_proof ~env p (fun p -> aux ((i, p) :: acc) rest) + in + aux [] proofs + + and node_proof_of_node : type a. + env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = + fun ~env node k -> + let rec aux acc = function + | [] -> k (`Values (List.rev acc)) + | (s, p) :: rest -> + load_proof ~env p (fun n -> aux ((s, n) :: acc) rest) + in + aux [] node + + let to_tree p = + let env = Env.empty () in + Env.set_mode env Env.Deserialise; + let h = load_proof ~env (state p) Fun.id in + let tree = pruned_with_env ~env h in + Env.set_mode env Env.Consume; + tree + end + + let produce_proof repo kinded_key f = + Env.with_produce @@ fun env ~start_serialise -> + let tree = import_with_env ~env repo kinded_key in + let tree_after, result = f tree in + let after = hash tree_after in + (* Here, we build a proof from [tree] (not from [tree_after]!), on purpose: + we look at the effect on [f] on [tree]'s caches and we rely on the fact + that the caches are env across copy-on-write copies of [tree]. *) + clear tree; + start_serialise (); + let proof = Proof.of_tree tree in + (* [env] will be purged when leaving the scope, that should avoid any memory + leaks *) + let kinded_hash = Node.weaken_value kinded_key in + (Proof.v ~before:kinded_hash ~after proof, result) + + let verify_proof_exn p f = + Env.with_consume @@ fun env ~stop_deserialise -> + let before = Proof.before p in + let after = Proof.after p in + (* First convert to proof to [Env] *) + let h = Proof.(load_proof ~env (state p) Fun.id) in + (* Then check that the consistency of the proof *) + if not (equal_kinded_hash before h) then + Irmin_proof.bad_proof_exn "verify_proof: invalid before hash"; + let tree = pruned_with_env ~env h in + try + stop_deserialise (); + (* Then apply [f] on a cleaned tree, an exception will be raised if [f] + reads out of the proof. *) + let tree_after, result = f tree in + (* then check that [after] corresponds to [tree_after]'s hash. *) + if not (equal_kinded_hash after (hash tree_after)) then + Irmin_proof.bad_proof_exn "verify_proof: invalid after hash"; + (tree_after, result) + with + | Pruned_hash h -> + (* finaly check that [f] only access valid parts of the proof. *) + Fmt.kstr Irmin_proof.bad_proof_exn + "verify_proof: %s is trying to read through a blinded node or object \ + (%a)" + h.context pp_hash h.hash + | e -> raise e + + type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] + + let verify_proof p f = + try + let r = verify_proof_exn p f in + Ok r + with + | Irmin_proof.Bad_proof e -> Error (`Proof_mismatch e.context) + | e -> raise e + + let hash_of_proof_state state = + let env = Env.empty () in + Proof.load_proof ~env state Fun.id + + module Private = struct + let get_env = get_env + + module Env = Env + end +end diff --git a/src/irmin-pack-tools/tezos_explorer/parse.ml b/src/irmin-pack-tools/tezos_explorer/parse.ml index 79eedefa01..5494249de1 100644 --- a/src/irmin-pack-tools/tezos_explorer/parse.ml +++ b/src/irmin-pack-tools/tezos_explorer/parse.ml @@ -1,6 +1,17 @@ open Import open Files -module Files = Make (Irmin_tezos.Conf) (Irmin_tezos.Schema) + +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = None + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end + +module Content = Irmin.Contents.String +module Schema = Irmin.Schema.KV (Content) +module Files = Make (Conf) (Schema) type ctx = { off : Int63.t; info : info } and info = { commits : int list; contents : int list; inodes : int list } diff --git a/src/irmin-pack-tools/tezos_explorer/show.ml b/src/irmin-pack-tools/tezos_explorer/show.ml index 01afad5fc2..7ea3f88544 100644 --- a/src/irmin-pack-tools/tezos_explorer/show.ml +++ b/src/irmin-pack-tools/tezos_explorer/show.ml @@ -2,7 +2,35 @@ open Notty open Notty_unix open Import open Files -module Files = Make (Irmin_tezos.Conf) (Irmin_tezos.Schema) + +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = None + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end + +module Content = Irmin.Contents.String +module Schema = Irmin.Schema.KV (Content) +module Files = Make (Conf) (Schema) + +(* + module Node = Node.Make (Hash) (Path) (Metadata) + module Commit = Commit.Make (Hash) + module Info = Info.Default *) + +(* module Schema = struct + open Irmin + module Hash = Hash.SHA1 + module Info = Info.Default + module Branch = Branch.String + module Path = Path.String_list + module Metadata = Metadata.None + module Contents = Content + module Node = Node.Make (Hash) (Path) (Metadata) + module Commit = Commit.Generic_key.Make (Hash) +end *) type entry_content = { hash : string; @@ -160,16 +188,16 @@ module Menu = struct let back_str = [| - ("◂──", "Go back by 1000 "); - ("◂─", "Go back by 10 "); + ("◂◂◂", "Go back by 1000 "); + ("◂◂", "Go back by 10 "); ("◂", "Go back by 1 "); |] let forth_str = [| ("▸", "Go forth by 1 "); - ("─▸", "Go forth by 10 "); - ("──▸", "Go forth by 1000 "); + ("▸▸", "Go forth by 10 "); + ("▸▸▸", "Go forth by 1000 "); |] let gen_entry_buttons r c str = diff --git a/src/irmin-pack-tools/tezos_explorer_gui/context.ml b/src/irmin-pack-tools/tezos_explorer_gui/context.ml index fdd12d2fc7..68f7dd0d63 100644 --- a/src/irmin-pack-tools/tezos_explorer_gui/context.ml +++ b/src/irmin-pack-tools/tezos_explorer_gui/context.ml @@ -4,12 +4,14 @@ open Optint open Sdl_util type ctx = { + sw : Eio.Switch.t; + fs : Eio.Fs.dir_ty Eio.Path.t; r : Sdl.renderer; w : Sdl.window; wr : Sdl.rect; f : Ttf.font; indexes : (string * Int63.t) list; - store_path : string; + store_path : Eio.Fs.dir_ty Eio.Path.t; mutable drag : (int * int) option; mutable current : int; mutable last_refresh : float; @@ -24,7 +26,7 @@ let get_window_rect () = let uh = h usable_bounds in create ~x:(w bounds - uw) ~y:(Sdl.Rect.h bounds - uh) ~w:uw ~h:uh -let init_context store_path font_path i = +let init_context ~sw ~fs store_path font_path i = let wr = get_window_rect () in let w = let open Sdl.Rect in @@ -37,9 +39,11 @@ let init_context store_path font_path i = in let f = get @@ Ttf.open_font font_path 12 in let last_refresh = Unix.gettimeofday () in - let indexes = Load_tree.load_index store_path in + let indexes = Load_tree.load_index (Eio.Path.native_exn store_path) in let current = i in { + sw; + fs; r; w; wr; diff --git a/src/irmin-pack-tools/tezos_explorer_gui/dune b/src/irmin-pack-tools/tezos_explorer_gui/dune index 75e31ff95e..4e6328ece6 100644 --- a/src/irmin-pack-tools/tezos_explorer_gui/dune +++ b/src/irmin-pack-tools/tezos_explorer_gui/dune @@ -1,8 +1,9 @@ -; (executable -; (public_name irmin-tezos-explorer-gui) -; (package irmin-pack-tools) -; (name main) -; (modules main context load_tree tree sdl_util layout loading) -; (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner) -; (preprocess -; (pps ppx_repr))) +(executable + (public_name irmin-tezos-explorer-gui) + (package irmin-pack-tools) + (name main) + (modules main context load_tree tree sdl_util layout loading) + (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner eio + eio_main) + (preprocess + (pps ppx_repr))) diff --git a/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml b/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml index 7fb3285a6d..54a082af7b 100644 --- a/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml +++ b/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml @@ -1,15 +1,24 @@ open Optint module Kind = Irmin_pack.Pack_value.Kind -module Conf = Irmin_tezos.Conf -module Schema = Irmin_tezos.Schema + +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end + +module Content = Irmin.Contents.String +module Schema = Irmin.Schema.KV (Content) module Maker = Irmin_pack_unix.Maker (Conf) module Store = Maker.Make (Schema) module Hash = Store.Hash module Key = Irmin_pack_unix.Pack_key.Make (Hash) module Io = Irmin_pack_unix.Io.Unix module Errs = Irmin_pack_unix.Io_errors.Make (Io) -module Index = Irmin_pack_unix.Index.Make (Hash) -module File_manager = Irmin_pack_unix.File_manager.Make (Io) (Index) (Errs) +module Pack_index = Irmin_pack_unix.Index.Make (Hash) +module File_manager = Irmin_pack_unix.File_manager.Make (Io) (Pack_index) (Errs) module Dispatcher = Irmin_pack_unix.Dispatcher.Make (File_manager) module Inode = struct @@ -33,6 +42,8 @@ end module Varint = struct type t = int [@@deriving repr ~decode_bin ~encode_bin] + (** LEB128 stores 7 bits per byte. An OCaml [int] has at most 63 bits. + [63 / 7] equals [9]. *) let max_encoded_size = 9 end @@ -159,9 +170,9 @@ let get_tree_from_commit (loading : Loading.t) dispatcher dict max_depth in get_commit_tree 0 -let load_tree loading store_path ~max_depth (hash, off) last_commit_off = +let load_tree sw fs loading store_path ~max_depth (hash, off) last_commit_off = Loading.set_state loading Load_tree; - let conf = Irmin_pack.Conf.init store_path in + let conf = Irmin_pack.Conf.init ~sw ~fs store_path in let fm = Errs.raise_if_error @@ File_manager.open_ro conf in let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in let dict = File_manager.dict fm in @@ -171,10 +182,12 @@ let load_tree loading store_path ~max_depth (hash, off) last_commit_off = commit let load_index store_path = - let index = Index.v_exn ~readonly:true ~log_size:500_000 store_path in + let index = Pack_index.v_exn ~readonly:true ~log_size:500_000 store_path in let l = ref [] in - Index.iter - (fun h (off, _, _) -> l := (string_of_int @@ Hash.short_hash h, off) :: !l) + Pack_index.iter + (fun h (off, _, k) -> + if k = Commit_v1 || k = Commit_v2 then + l := (string_of_int @@ Hash.short_hash h, off) :: !l) index; let cmp (_, off1) (_, off2) = Int63.(to_int @@ sub off1 off2) in List.sort cmp !l diff --git a/src/irmin-pack-tools/tezos_explorer_gui/main.ml b/src/irmin-pack-tools/tezos_explorer_gui/main.ml index 265cfc4530..4198b50f61 100644 --- a/src/irmin-pack-tools/tezos_explorer_gui/main.ml +++ b/src/irmin-pack-tools/tezos_explorer_gui/main.ml @@ -25,8 +25,8 @@ let generate_tree ctx d = else snd @@ List.nth ctx.indexes (ctx.current - 1) in let tree = - Load_tree.load_tree loading ctx.store_path ~max_depth:d commit_info - last_commit_addr + Load_tree.load_tree ctx.sw ctx.fs loading ctx.store_path ~max_depth:d + commit_info last_commit_addr in (* layout *) let layout = layout ctx loading tree in @@ -99,10 +99,11 @@ let set_texture t texture = Sdl.destroy_texture t.texture; t.texture <- texture -let main store_path font_path i d = +let main ~sw ~fs store_path font_path i d = let () = get @@ Sdl.init Sdl.Init.(video + events) in let () = get @@ Ttf.init () in - let ctx = init_context store_path font_path i in + let store_path = Eio.Path.(fs / store_path) in + let ctx = init_context ~sw ~fs store_path font_path i in (* wait for the window to be showned *) wait_shown (); try @@ -220,9 +221,14 @@ let depth = Arg.( value & opt int (-1) & info [ "d"; "depth" ] ~docv:"depth" ~doc:"max depth") -let main_cmd = +let main_cmd ~sw ~fs = let doc = "a gui for tezos store exploration" in let info = Cmd.info "graphics" ~doc in - Cmd.v info Term.(const main $ store_path $ font_path $ commit $ depth) - -let () = exit (Cmd.eval ~catch:false main_cmd) + Cmd.v info + Term.(const (main ~sw ~fs) $ store_path $ font_path $ commit $ depth) + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.fs env in + exit (Cmd.eval ~catch:false (main_cmd ~sw ~fs)) diff --git a/src/irmin-pack/inode.ml b/src/irmin-pack/inode.ml index f544ee4597..ce5ea78445 100644 --- a/src/irmin-pack/inode.ml +++ b/src/irmin-pack/inode.ml @@ -73,11 +73,12 @@ struct let unsafe_keyvalue_of_hashvalue = function | `Contents (h, m) -> `Contents (Key.unfindable_of_hash h, m) - | `Node h -> `Node (Key.unfindable_of_hash h) + | `Node (h, il) -> + `Node (Key.unfindable_of_hash h, List.map Key.unfindable_of_hash il) let hashvalue_of_keyvalue = function | `Contents (k, m) -> `Contents (Key.to_hash k, m) - | `Node k -> `Node (Key.to_hash k) + | `Node (k, il) -> `Node (Key.to_hash k, List.map Key.to_hash il) end module Step = @@ -794,6 +795,8 @@ struct | Values l -> StepMap.fold (fun s v acc -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let v = match v with | `Node _ as k -> (Some s, k) @@ -959,7 +962,7 @@ struct type kinded_key = | Contents of contents_key | Contents_x of metadata * contents_key - | Node of node_key + | Node of node_key * contents_key list [@@deriving irmin] type entry = { name : step; key : kinded_key } [@@deriving irmin] @@ -979,14 +982,15 @@ struct if T.equal_metadata m Metadata.default then { name; key = Contents contents_key } else { name; key = Contents_x (m, contents_key) } - | `Node node_key -> { name; key = Node node_key } + | `Node (node_key, inlined_keys) -> + { name; key = Node (node_key, inlined_keys) } let of_entry e = ( e.name, match e.key with | Contents key -> `Contents (key, Metadata.default) | Contents_x (m, key) -> `Contents (key, m) - | Node key -> `Node key ) + | Node (key, inlined_keys) -> `Node (key, inlined_keys) ) type error = [ `Invalid_hash of hash * hash * t @@ -1172,7 +1176,7 @@ struct [of_proof]. *) if should_be_stable ~length ~root:(depth = 0) then (* [seq_v] may call [find], even if some branches are blinded *) - let node = Node.of_seq (seq_v la v) in + let node = Node.of_seq (seq_v la v) [] in Node.hash node else hash v in @@ -1212,7 +1216,7 @@ struct Val_ref.of_hash (lazy (let vs = seq layout ~cache:false t in - Node.hash (Node.of_seq vs))) + Node.hash (Node.of_seq vs []))) in { v_ref; v = t.v; root = true } @@ -1243,7 +1247,7 @@ struct let recompute_hash layout t = if is_stable t then let vs = seq layout ~cache:false t in - Node.hash (Node.of_seq vs) + Node.hash (Node.of_seq vs []) else let v = to_bin_v layout Bin.Ptr_any t.v in let hash = Bin.V.hash v in @@ -1399,7 +1403,7 @@ struct | None -> t | Some _ -> remove layout t s k Fun.id |> stabilize_root layout - let of_seq la l = + let of_seq la l _to_inline = let t = let rec aux_big seq inode = match seq () with @@ -1564,7 +1568,7 @@ struct let is_tree t = match t.v with Tree _ -> true | Values _ -> false module Proof = struct - type value = [ `Contents of hash * metadata | `Node of hash ] + type value = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin] type t = @@ -1677,7 +1681,9 @@ struct in a [Values], it needs to be converted back to a [Tree] shallowed. *) let t = - of_seq Total (List.map strengthen_step_value vs |> List.to_seq) + of_seq Total + (List.map strengthen_step_value vs |> List.to_seq) + [] in let hash = (* Compute the hash right away (not lazily) so that @@ -1720,7 +1726,9 @@ struct module Snapshot = struct include T - type kinded_hash = Contents of hash * metadata | Node of hash + type kinded_hash = + | Contents of hash * metadata + | Node of hash * hash list [@@deriving irmin] type entry = { step : string; hash : kinded_hash } [@@deriving irmin] @@ -1749,9 +1757,10 @@ struct | Snapshot.Contents (hash, m) -> let key = index hash in `Contents (key, m) - | Node hash -> + | Node (hash, inlined_hashes) -> let key = index hash in - `Node key ) + let inlined_keys = List.map index inlined_hashes in + `Node (key, inlined_keys) ) let of_inode_tree ~index layout tr = let entries = Array.make Conf.entries None in @@ -1856,7 +1865,7 @@ struct let s = step s in let v = address_of_key c in Compress.Contents (s, v, m) - | s, `Node n -> + | s, `Node (n, _il) -> let s = step s in let v = address_of_key n in Compress.Node (s, v) @@ -1908,7 +1917,8 @@ struct | Node (n, h) -> let name = step n in let hash = key h in - (name, `Node hash) + (* TODO inline *) + (name, `Node (hash, [])) in let t : Compress.tagged_v -> T.key Bin.v = fun tv -> @@ -1964,9 +1974,10 @@ struct | `Contents (contents_key, m) -> let h = Key.to_hash contents_key in { Snapshot.step; hash = Contents (h, m) } - | `Node node_key -> + | `Node (node_key, inlined_keys) -> let h = Key.to_hash node_key in - { step; hash = Node h } + let inlined_h = List.map Key.to_hash inlined_keys in + { step; hash = Node (h, inlined_h) } (* The implementation of [of_snapshot] is in the module [Val]. This is because we cannot compute the hash of a root from [Bin]. *) @@ -2037,11 +2048,13 @@ struct let pred t = apply t { f = (fun layout v -> I.pred layout v) } - let of_seq l = + let of_seq l to_inline = + Fmt.pr "HFHFHFHFHFHFHFHFHF@."; + Fmt.pr "LEN to_inline: %d@." (List.length to_inline); Stats.incr_inode_of_seq (); - Total (I.of_seq Total l) + Total (I.of_seq Total l to_inline) - let of_list l = of_seq (List.to_seq l) + let of_list l to_inline = of_seq (List.to_seq l) to_inline let seq ?offset ?length ?cache t = apply t { f = (fun layout v -> I.seq layout ?offset ?length ?cache v) } @@ -2049,7 +2062,7 @@ struct let list ?offset ?length ?cache t = apply t { f = (fun layout v -> I.list layout ?offset ?length ?cache v) } - let empty () = of_list [] + let empty () = of_list [] [] let is_empty t = apply t { f = (fun _ v -> I.is_empty v) } let find ?cache t s = @@ -2086,7 +2099,7 @@ struct (* If [x] is shallow, this [seq] call will perform IOs. *) seq x in - pre_hash_node (Node.of_seq vs) + pre_hash_node (Node.of_seq vs []) in let module Ptr_any = struct let t = @@ -2112,10 +2125,10 @@ struct let hash_exn ?force t = apply t { f = (fun _ v -> I.hash_exn ?force v) } let save ?(allow_non_root = false) ~add ~index ~mem t = - if Conf.forbid_empty_dir_persistence && is_empty t then + (* if Conf.forbid_empty_dir_persistence && is_empty t then failwith "Persisting an empty node is forbidden by the configuration of the \ - irmin-pack store"; + irmin-pack store"; *) let f layout v = if not allow_non_root then I.check_write_op_supported v; I.save layout ~add ~index ~mem v @@ -2160,8 +2173,8 @@ struct let merge ~contents ~node : t Irmin.Merge.t = let merge = Node.merge ~contents ~node in - let to_node t = of_seq (Node.seq t) in - let of_node n = Node.of_seq (seq n) in + let to_node t = of_seq (Node.seq t) [] in + let of_node n = Node.of_seq (seq n) [] in Irmin.Merge.like t merge of_node to_node let with_handler f_env t = @@ -2223,7 +2236,7 @@ struct type node_key = hash [@@deriving irmin] type contents_key = hash [@@deriving irmin] - type value = [ `Contents of hash * metadata | `Node of hash ] + type value = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin] let of_node t = t @@ -2251,15 +2264,19 @@ struct let find ?cache t s = find ?cache t s |> Option.map hashvalue_of_keyvalue - let merge = - let promote_merge : - hash option Irmin.Merge.t -> key option Irmin.Merge.t = - fun t -> - Irmin.Merge.like [%typ: key option] t (Option.map Key.to_hash) + let merge ~contents ~node = + let promote_merge_contents = + Irmin.Merge.like [%typ: key option] contents (Option.map Key.to_hash) (Option.map Key.unfindable_of_hash) in - fun ~contents ~node -> - merge ~contents:(promote_merge contents) ~node:(promote_merge node) + let promote_merge_node = + Irmin.Merge.like [%typ: (key * key list) option] node + (Option.map (fun (k, il) -> + (Key.to_hash k, List.map Key.to_hash il))) + (Option.map (fun (h, il) -> + (Key.unfindable_of_hash h, List.map Key.unfindable_of_hash il))) + in + merge ~contents:promote_merge_contents ~node:promote_merge_node module Proof = I.Proof @@ -2381,6 +2398,8 @@ struct let find t k = unsafe_find ~check_integrity:true t k let save ?allow_non_root t v = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let add k v = Pack.unsafe_append ~ensure_unique:true ~overcommit:false t k v in @@ -2388,7 +2407,12 @@ struct ~mem:(Pack.unsafe_mem t) v let hash_exn = Val.hash_exn - let add t v = save t v + + let add t v = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + save t v + let equal_hash = Irmin.Type.(unstage (equal H.t)) let check_hash expected got = diff --git a/src/irmin-pack/inode_intf.ml b/src/irmin-pack/inode_intf.ml index 7d625fb356..8475239c7f 100644 --- a/src/irmin-pack/inode_intf.ml +++ b/src/irmin-pack/inode_intf.ml @@ -28,7 +28,7 @@ module type Snapshot = sig type hash type metadata - type kinded_hash = Contents of hash * metadata | Node of hash + type kinded_hash = Contents of hash * metadata | Node of hash * hash list [@@deriving irmin] type entry = { step : string; hash : kinded_hash } [@@deriving irmin] @@ -53,7 +53,9 @@ module type Value = sig val pred : t -> (step option - * [ `Node of node_key | `Inode of node_key | `Contents of contents_key ]) + * [ `Node of node_key * contents_key list + | `Inode of node_key + | `Contents of contents_key ]) list module Portable : @@ -168,7 +170,7 @@ module type Internal = sig type kinded_key = | Contents of contents_key | Contents_x of metadata * contents_key - | Node of node_key + | Node of node_key * contents_key list [@@deriving irmin] type entry = { name : step; key : kinded_key } [@@deriving irmin] diff --git a/src/irmin-pack/io/checks.ml b/src/irmin-pack/io/checks.ml index 5cd1452510..f3e277ce21 100644 --- a/src/irmin-pack/io/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -422,7 +422,7 @@ struct match kind with | Contents -> progress_contents (); - check ~kind:`Contents ~offset ~length k + check ~kind:`Contents ~offset ~length k (* TODO inlined ?*) | Inode_v1_stable | Inode_v1_unstable | Inode_v2_root | Inode_v2_nonroot -> progress_nodes (); @@ -495,7 +495,7 @@ struct progress_contents (); check_contents key in - let pred_node repo key = + let pred_node repo (key, _il) = match X.Node.find (X.Repo.node_t repo) key with | None -> Fmt.failwith "node with hash %a not found" pp_hash (XKey.to_hash key) @@ -505,7 +505,7 @@ struct (function | s, `Inode x -> assert (s = None); - `Node x + `Node (x, []) | _, `Node x -> `Node x | _, `Contents x -> `Contents x) preds @@ -513,7 +513,7 @@ struct add_error `Wrong_hash (XKey.to_hash key); [] in - let check_nodes key = + let check_nodes (key, _il) = match X.Node.find (X.Repo.node_t t) key with | None -> Fmt.failwith "node with hash %a not found" pp_hash (XKey.to_hash key) @@ -534,7 +534,8 @@ struct | None -> [] | Some c -> let node = X.Commit.Val.node c in - [ `Node node ] + (* TODO inline *) + [ `Node (node, []) ] with _exn -> add_error `Wrong_hash (XKey.to_hash k); [] @@ -557,13 +558,13 @@ struct Object_counter.start ppf in let errors = ref [] in - let pred_node repo key = - try pred repo key + let pred_node repo (key, il) = + try pred repo (key, il) with _ -> errors := "Error in repo iter" :: !errors; [] in - let node k = + let node (k, _il) = progress_nodes (); match check k with Ok () -> () | Error msg -> errors := msg :: !errors in @@ -747,6 +748,7 @@ struct | Inode, `Inode x -> visit Inode x | Node s, `Node x -> visit (Node s) x | Node s, `Contents x -> visit (Node s) x + | Node s, `Contents_inlined_7 x -> visit (Node s) x | _ -> assert false) preds in diff --git a/src/irmin-pack/io/checks_intf.ml b/src/irmin-pack/io/checks_intf.ml index f082878696..e577e059ad 100644 --- a/src/irmin-pack/io/checks_intf.ml +++ b/src/irmin-pack/io/checks_intf.ml @@ -169,7 +169,7 @@ module type Sigs = sig ?ppf:Format.formatter -> auto_repair:bool -> check: - (kind:[> `Commit | `Contents | `Node ] -> + (kind:[> `Commit | `Contents | `Contents_inlined__3 | `Node ] -> offset:int63 -> length:int -> Index.key -> @@ -184,16 +184,22 @@ module type Sigs = sig pred: (X.Node.value -> (X.Node.Path.step option - * [< `Contents of XKey.t | `Inode of XKey.t | `Node of XKey.t ]) + * [< `Contents of XKey.t + | `Inode of XKey.t + | `Node of XKey.t * XKey.t list ]) list) -> iter: (contents:(XKey.hash Pack_key.t -> unit) -> - node:(XKey.t -> unit) -> + node:(XKey.t * XKey.t list -> unit) -> pred_node: (X.Repo.t -> - XKey.t -> - [> `Contents of XKey.t | `Node of XKey.t ] list) -> - pred_commit:(X.Repo.t -> XKey.t -> [> `Node of XKey.t ] list) -> + XKey.t * XKey.t list -> + [> `Contents of XKey.t + | `Contents_inlined_2 of XKey.t + | `Node of XKey.t * XKey.t list ] + list) -> + pred_commit: + (X.Repo.t -> XKey.t -> [> `Node of XKey.t * XKey.t list ] list) -> X.Repo.t -> unit) -> check: @@ -210,13 +216,13 @@ module type Sigs = sig iter: (pred_node: (X.Repo.t -> - XKey.t -> - ([> `Contents of XKey.t | `Node of XKey.t ] as 'a) list) -> - node:(XKey.t -> unit) -> + XKey.t * XKey.t list -> + ([> `Contents of XKey.t | `Node of XKey.t * XKey.t list ] as 'a) list) -> + node:(XKey.t * XKey.t list -> unit) -> commit:(XKey.t -> unit) -> X.Repo.t -> unit) -> - pred:(X.Repo.t -> XKey.t -> 'a list) -> + pred:(X.Repo.t -> XKey.t * XKey.t list -> 'a list) -> check:(XKey.t -> (unit, string) result) -> X.Repo.t -> ([> `No_error ], [> `Cannot_fix of string ]) result @@ -239,7 +245,10 @@ module type Sigs = sig t -> S.Hash.t -> (S.step option - * [ `Contents of S.Hash.t | `Inode of S.Hash.t | `Node of S.Hash.t ]) + * [ `Contents of S.Hash.t + | `Contents_inlined_7 of S.Hash.t + | `Inode of S.Hash.t + | `Node of S.Hash.t ]) list -> nb_children:int -> width:int -> diff --git a/src/irmin-pack/io/gc_args.ml b/src/irmin-pack/io/gc_args.ml index fe815d9f05..ef2292ae67 100644 --- a/src/irmin-pack/io/gc_args.ml +++ b/src/irmin-pack/io/gc_args.ml @@ -41,7 +41,9 @@ module type S = sig val pred : t -> - (step option * [ `Contents of key | `Inode of key | `Node of key ]) list + (step option + * [ `Contents of key | `Inode of key | `Node of key * key list ]) + list end module Node_store : sig diff --git a/src/irmin-pack/io/gc_worker.ml b/src/irmin-pack/io/gc_worker.ml index d7d42fb6f9..7b977a413c 100644 --- a/src/irmin-pack/io/gc_worker.ml +++ b/src/irmin-pack/io/gc_worker.ml @@ -106,12 +106,13 @@ module Make (Args : Gc_args.S) = struct raise (Pack_error (`Dangling_key (string_of_key commit_key))) | Some commit -> List.iter schedule_commit (Commit_value.parents commit); - schedule_kinded (`Node (Commit_value.node commit))) + (* TODO inline *) + schedule_kinded (`Node (Commit_value.node commit, []))) and schedule_kinded kinded_key = let key, kind = match kinded_key with - | `Contents key -> (key, Contents) - | `Inode key | `Node key -> (key, Node) + | `Contents key -> (key, Contents) (* TODO inline *) + | `Inode key | `Node (key, _) -> (key, Node) in match Node_store.get_offset node_store key with | offset -> schedule ~offset kind diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index 8bf6ce44b9..b83c5432cf 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -514,6 +514,8 @@ struct let check ~kind ~offset ~length k = match kind with | `Contents -> X.Contents.CA.integrity_check ~offset ~length k contents + | `Contents_inlined__3 -> + X.Contents.CA.integrity_check ~offset ~length k contents | `Node -> X.Node.CA.integrity_check ~offset ~length k nodes | `Commit -> X.Commit.CA.integrity_check ~offset ~length k commits in @@ -556,7 +558,7 @@ struct module Hash = Hash end) in let t = Stats.v () in - let pred_node repo k = + let pred_node repo (k, _il) = match X.Node.find (X.Repo.node_t repo) k with | None -> Fmt.failwith "key %a not found" pp_key k | Some v -> @@ -568,14 +570,14 @@ struct |> List.map (function | s, `Contents h -> (s, `Contents (XKey.to_hash h)) | s, `Inode h -> (s, `Inode (XKey.to_hash h)) - | s, `Node h -> (s, `Node (XKey.to_hash h))) + | s, `Node (h, _il) -> (s, `Node (XKey.to_hash h))) |> Stats.visit_node t (XKey.to_hash k) ~width ~nb_children in List.rev_map (function | s, `Inode x -> assert (s = None); - `Node x + `Node (x, []) | _, `Node x -> `Node x | _, `Contents x -> `Contents x) preds @@ -587,7 +589,7 @@ struct | Some c -> let node = X.Commit.Val.node c in Stats.visit_commit t (XKey.to_hash node); - [ `Node node ] + [ `Node (node, []) ] in let pred_contents _repo k = Stats.visit_contents t (XKey.to_hash k); @@ -731,7 +733,7 @@ struct let f_nodes x = f (Inode x) in match root_key with | `Contents _ -> Fmt.failwith "[root_key] cannot be of type contents" - | `Node key -> + | `Node (key, _il) -> let total = Export.run ?on_disk export f_contents f_nodes (key, Pack_value.Kind.Inode_v2_root) diff --git a/src/irmin-pack/io/store_intf.ml b/src/irmin-pack/io/store_intf.ml index c2e668a583..306604ef9b 100644 --- a/src/irmin-pack/io/store_intf.ml +++ b/src/irmin-pack/io/store_intf.ml @@ -229,7 +229,7 @@ module type S = sig (** {1 Snapshots} *) module Snapshot : sig - type kinded_hash = Contents of hash * metadata | Node of hash + type kinded_hash = Contents of hash * metadata | Node of hash * hash list [@@deriving irmin] type entry = { step : string; hash : kinded_hash } [@@deriving irmin] diff --git a/src/irmin-test/common.ml b/src/irmin-test/common.ml index 7a1fe21736..395512964e 100644 --- a/src/irmin-test/common.ml +++ b/src/irmin-test/common.ml @@ -165,7 +165,7 @@ module Make_helpers (S : Generic_key) = struct let v1 = long_random_string let v2 = "" let with_contents repo f = B.Repo.batch repo (fun t _ _ -> f t) - let with_node repo f = B.Repo.batch repo (fun _ t _ -> f t) + let with_node repo f = B.Repo.batch repo (fun _ t _ -> f t) () let with_commit repo f = B.Repo.batch repo (fun _ _ t -> f t) let with_info repo n f = with_commit repo (fun h -> f h ~info:(info n)) let kv1 ~repo = with_contents repo (fun t -> B.Contents.add t v1) @@ -176,28 +176,29 @@ module Make_helpers (S : Generic_key) = struct let n1 ~repo = let kv1 = kv1 ~repo in - with_node repo (fun t -> Graph.v t [ ("x", normal kv1) ]) + with_node repo (fun t () -> Graph.v t [ ("x", normal kv1) ] []) let n2 ~repo = let kn1 = n1 ~repo in - with_node repo (fun t -> Graph.v t [ ("b", `Node kn1) ]) + with_node repo (fun t () -> Graph.v t [ ("b", `Node (kn1, [])) ] []) let n3 ~repo = let kn2 = n2 ~repo in - with_node repo (fun t -> Graph.v t [ ("a", `Node kn2) ]) + with_node repo (fun t () -> Graph.v t [ ("a", `Node (kn2, [])) ] []) let n4 ~repo = let kn1 = n1 ~repo in let kv2 = kv2 ~repo in - let kn4 = with_node repo (fun t -> Graph.v t [ ("x", normal kv2) ]) in + let kn4 = with_node repo (fun t () -> Graph.v t [ ("x", normal kv2) ] []) in let kn5 = - with_node repo (fun t -> Graph.v t [ ("b", `Node kn1); ("c", `Node kn4) ]) + with_node repo (fun t () -> + Graph.v t [ ("b", `Node (kn1, [])); ("c", `Node (kn4, [])) ] []) in - with_node repo (fun t -> Graph.v t [ ("a", `Node kn5) ]) + with_node repo (fun t () -> Graph.v t [ ("a", `Node (kn5, [])) ]) let r1 ~repo = let kn2 = n2 ~repo in - match S.Tree.of_key repo (`Node kn2) with + match S.Tree.of_key repo (`Node (kn2, [])) with | None -> Alcotest.fail "r1" | Some tree -> S.Commit.v repo ~info:S.Info.empty ~parents:[] (tree :> S.tree) @@ -205,7 +206,7 @@ module Make_helpers (S : Generic_key) = struct let r2 ~repo = let kn3 = n3 ~repo in let kr1 = r1 ~repo in - match S.Tree.of_key repo (`Node kn3) with + match S.Tree.of_key repo (`Node (kn3, [])) with | None -> Alcotest.fail "r2" | Some t3 -> S.Commit.v repo ~info:S.Info.empty diff --git a/src/irmin-test/node.ml b/src/irmin-test/node.ml index 545f01f089..5b2ac82ad4 100644 --- a/src/irmin-test/node.ml +++ b/src/irmin-test/node.ml @@ -115,7 +115,7 @@ end = struct type key = Key.t [@@deriving irmin] module Extras = struct - type data = [ `Node of Key.t | `Contents of Key.t * unit ] + type data = [ `Node of Key.t * Key.t list | `Contents of Key.t * unit ] [@@deriving irmin] let random_data = @@ -128,7 +128,7 @@ end = struct | Error _ -> assert false | Ok x -> ( match Random.int 2 with - | 0 -> `Node x + | 0 -> `Node (x, []) | 1 -> `Contents (x, ()) | _ -> assert false) end diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index 6f13dcb184..0766d8c19a 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -121,7 +121,7 @@ module Make (S : Generic_key) = struct let check_list = checks [%typ: S.step * B.Node.Val.value] in let check_node msg v = let h' = B.Node.Hash.hash v in - let key = with_node repo (fun n -> B.Node.add n v) in + let key = with_node repo (fun n () -> B.Node.add n v) in check_hash (msg ^ ": hash(v) = add(v)") (B.Node.Key.to_hash key) h' in let v = B.Node.Val.empty () in @@ -165,13 +165,17 @@ module Make (S : Generic_key) = struct let u = B.Node.Val.add u "b" k in check_node "node: x+y+z+a+b" u; let h = B.Node.Hash.hash u in - let k = with_node repo (fun n -> B.Node.add n u) in + let k = with_node repo (fun n () -> B.Node.add n u) in check_hash "hash(v) = add(v)" h (B.Node.Key.to_hash k); let w = B.Node.find n k in check_values (get w); let kv1 = kv1 ~repo in - let k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in - let k1' = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let k1 = + with_node repo (fun g () -> Graph.v g [ ("x", normal kv1) ] []) + in + let k1' = + with_node repo (fun g () -> Graph.v g [ ("x", normal kv1) ] []) + in check_key "k1.1" k1 k1'; let t1 = B.Node.find n k1 in let k' = B.Node.Val.find (get t1) "x" in @@ -180,28 +184,36 @@ module Make (S : Generic_key) = struct "find x" (Some (normal kv1)) k'; - let k1'' = with_node repo (fun n -> B.Node.add n (get t1)) in + let k1'' = with_node repo (fun n () -> B.Node.add n (get t1)) in check_key "k1.2" k1 k1''; - let k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in - let k2' = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + let k2 = + with_node repo (fun g () -> Graph.v g [ ("b", `Node (k1, [])) ] []) + in + let k2' = + with_node repo (fun g () -> Graph.v g [ ("b", `Node (k1, [])) ] []) + in check_key "k2.1" k2 k2'; let t2 = B.Node.find n k2 in - let k2'' = with_node repo (fun n -> B.Node.add n (get t2)) in + let k2'' = with_node repo (fun n () -> B.Node.add n (get t2)) in check_key "k2.2" k2 k2''; let k1''' = Graph.find g k2 [ "b" ] in - check_val "k1.3" (Some (`Node k1)) k1'''; - let k3 = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in - let k3' = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + check_val "k1.3" (Some (`Node (k1, []))) k1'''; + let k3 = + with_node repo (fun g () -> Graph.v g [ ("a", `Node (k2, [])) ] []) + in + let k3' = + with_node repo (fun g () -> Graph.v g [ ("a", `Node (k2, [])) ] []) + in check_key "k3.1" k3 k3'; let t3 = B.Node.find n k3 in - let k3'' = with_node repo (fun n -> B.Node.add n (get t3)) in + let k3'' = with_node repo (fun n () -> B.Node.add n (get t3)) in check_key "k3.2" k3 k3''; let k2'' = Graph.find g k3 [ "a" ] in - check_val "k2.3" (Some (`Node k2)) k2''; + check_val "k2.3" (Some (`Node (k2, []))) k2''; let k1'''' = Graph.find g k2' [ "b" ] in - check_val "t1.2" (Some (`Node k1)) k1''''; + check_val "t1.2" (Some (`Node (k1, []))) k1''''; let k1''''' = Graph.find g k3 [ "a"; "b" ] in - check_val "t1.3" (Some (`Node k1)) k1'''''; + check_val "t1.3" (Some (`Node (k1, []))) k1'''''; let kv11 = Graph.find g k1 [ "x" ] in check_val "v1.1" (Some (normal kv1)) kv11; let kv12 = Graph.find g k2 [ "b"; "x" ] in @@ -209,13 +221,19 @@ module Make (S : Generic_key) = struct let kv13 = Graph.find g k3 [ "a"; "b"; "x" ] in check_val "v1" (Some (normal kv1)) kv13; let kv2 = kv2 ~repo in - let k4 = with_node repo (fun g -> Graph.v g [ ("x", normal kv2) ]) in + let k4 = + with_node repo (fun g () -> Graph.v g [ ("x", normal kv2) ] []) + in let k5 = - with_node repo (fun g -> Graph.v g [ ("b", `Node k1); ("c", `Node k4) ]) + with_node repo (fun g () -> + Graph.v g [ ("b", `Node (k1, [])); ("c", `Node (k4, [])) ] []) + in + let k6 = + with_node repo (fun g () -> Graph.v g [ ("a", `Node (k5, [])) ] []) in - let k6 = with_node repo (fun g -> Graph.v g [ ("a", `Node k5) ]) in let k6' = - with_node repo (fun g -> Graph.add g k3 [ "a"; "c"; "x" ] (normal kv2)) + with_node repo (fun g () -> + Graph.add g k3 [ "a"; "c"; "x" ] (normal kv2)) in check_key "node k6" k6 k6'; let n6' = B.Node.find n k6' in @@ -231,27 +249,53 @@ module Make (S : Generic_key) = struct else names := s :: !names) all in - let n0 = with_node repo (fun g -> Graph.v g []) in - let n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) in - let n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (`Node n0)) in - let n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + let n0 = with_node repo (fun g () -> Graph.v g [] []) in + let n1 = + with_node repo (fun g () -> Graph.add g n0 [ "b" ] (`Node (n0, []))) + in + let n2 = + with_node repo (fun g () -> Graph.add g n1 [ "a" ] (`Node (n0, []))) + in + let n3 = + with_node repo (fun g () -> Graph.add g n2 [ "a" ] (`Node (n0, []))) + in assert_no_duplicates "1" n3; - let n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (`Node n0)) in - let n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (`Node n0)) in - let n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + let n1 = + with_node repo (fun g () -> Graph.add g n0 [ "a" ] (`Node (n0, []))) + in + let n2 = + with_node repo (fun g () -> Graph.add g n1 [ "b" ] (`Node (n0, []))) + in + let n3 = + with_node repo (fun g () -> Graph.add g n2 [ "a" ] (`Node (n0, []))) + in assert_no_duplicates "2" n3; - let n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (normal kv1)) in - let n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (normal kv1)) in - let n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (normal kv1)) in + let n1 = + with_node repo (fun g () -> Graph.add g n0 [ "b" ] (normal kv1)) + in + let n2 = + with_node repo (fun g () -> Graph.add g n1 [ "a" ] (normal kv1)) + in + let n3 = + with_node repo (fun g () -> Graph.add g n2 [ "a" ] (normal kv1)) + in assert_no_duplicates "3" n3; - let n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (normal kv1)) in - let n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (normal kv1)) in - let n3 = with_node repo (fun g -> Graph.add g n2 [ "b" ] (normal kv1)) in + let n1 = + with_node repo (fun g () -> Graph.add g n0 [ "a" ] (normal kv1)) + in + let n2 = + with_node repo (fun g () -> Graph.add g n1 [ "b" ] (normal kv1)) + in + let n3 = + with_node repo (fun g () -> Graph.add g n2 [ "b" ] (normal kv1)) + in assert_no_duplicates "4" n3; S.Repo.close repo; try - let n0 = with_node repo (fun g -> Graph.v g []) in - let _ = with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) in + let n0 = with_node repo (fun g () -> Graph.v g [] []) in + let _ = + with_node repo (fun g () -> Graph.add g n0 [ "b" ] (`Node (n0, []))) + in Alcotest.fail "Add after close should not be allowed" with | Irmin.Closed -> () @@ -271,9 +315,15 @@ module Make (S : Generic_key) = struct let check_key = check B.Commit.Key.t in let check_keys = checks B.Commit.Key.t in (* t3 -a-> t2 -b-> t1 -x-> (v1) *) - let kt1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in - let kt2 = with_node repo (fun g -> Graph.v g [ ("a", `Node kt1) ]) in - let kt3 = with_node repo (fun g -> Graph.v g [ ("b", `Node kt2) ]) in + let kt1 = + with_node repo (fun g () -> Graph.v g [ ("x", normal kv1) ] []) + in + let kt2 = + with_node repo (fun g () -> Graph.v g [ ("a", `Node (kt1, [])) ] []) + in + let kt3 = + with_node repo (fun g () -> Graph.v g [ ("b", `Node (kt2, [])) ] []) + in (* r1 : t2 *) let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in let kr1, _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in @@ -324,7 +374,8 @@ module Make (S : Generic_key) = struct let kv = with_contents repo (fun t -> B.Contents.add t (string_of_int i)) in - with_node repo (fun g -> Graph.v g [ (string_of_int i, normal kv) ])) + with_node repo (fun g () -> + Graph.v g [ (string_of_int i, normal kv) ] [])) [ 0; 1; 2; 3; 4; 5; 6; 7; 8 ] in let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in @@ -466,7 +517,7 @@ module Make (S : Generic_key) = struct let test_tree_hashes x () = let test repo = let node bindings = - with_node repo (fun g -> + with_node repo (fun g () -> let empty = Graph.empty g in List.fold_left (fun t (k, v) -> @@ -544,27 +595,35 @@ module Make (S : Generic_key) = struct (* merge nodes *) let g = g repo in (* The empty node *) - let k0 = with_node repo (fun g -> Graph.v g []) in + let k0 = with_node repo (fun g () -> Graph.v g [] []) in (* Create the node t1 -x-> (v1) *) - let k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let k1 = + with_node repo (fun g () -> Graph.v g [ ("x", normal kv1) ] []) + in (* Create the node t2 -b-> t1 -x-> (v1) *) - let k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + let k2 = + with_node repo (fun g () -> Graph.v g [ ("b", `Node (k1, [])) ] []) + in (* Create the node t3 -c-> t1 -x-> (v1) *) - let k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + let k3 = + with_node repo (fun g () -> Graph.v g [ ("c", `Node (k1, [])) ] []) + in (* Should create the node: t4 -b-> t1 -x-> (v1) \c/ *) let k4 = - with_node repo (fun g -> + with_node repo (fun g () -> Irmin.Merge.(f @@ B.Node.merge g) - ~old:(old (Some k0)) (Some k2) (Some k3)) + ~old:(old (Some (k0, []))) + (Some (k2, [])) + (Some (k3, []))) in let k4 = merge_exn "k4" k4 in let k4 = match k4 with Some k -> k | None -> failwith "k4" in let _ = k4 in let succ_t = [%typ: string * Graph.value] in - let succ = Graph.list g k4 in - checks succ_t "k4" [ ("b", `Node k1); ("c", `Node k1) ] succ; + let succ = Graph.list g (fst k4) in + checks succ_t "k4" [ ("b", `Node (k1, [])); ("c", `Node (k1, [])) ] succ; let info date = let i = Int64.of_int date in S.Info.v ~author:"test" ~message:"Test commit" i @@ -600,7 +659,9 @@ module Make (S : Generic_key) = struct in let kr3_key = merge_exn "kr3_key" kr3_key in check_key "kr3 key with old parent" kr3 kr3_key; - let kr3', _ = with_info 3 @@ History.v ~node:k4 ~parents:[ kr1; kr2 ] in + let kr3', _ = + with_info 3 @@ History.v ~node:(fst k4) ~parents:[ kr1; kr2 ] + in let r3 = B.Commit.find c kr3 in let r3' = B.Commit.find c kr3' in check T.(option B.Commit.Val.t) "r3" r3 r3'; @@ -1032,6 +1093,7 @@ module Make (S : Generic_key) = struct Alcotest.testable (fun ppf -> function | `Contents -> Fmt.string ppf "contents" + | `Contents_inlined__2 -> Fmt.string ppf "contents_inlined" | `Node `Key -> Fmt.string ppf "key" | `Node `Map -> Fmt.string ppf "map" | `Node `Value -> Fmt.string ppf "value" @@ -1596,8 +1658,9 @@ module Make (S : Generic_key) = struct let trigger_node_to_backend_portable t = match S.Tree.destruct t with | `Contents _ -> assert false + | `Contents_inlined_3 _ -> assert false | `Node n -> - let _ = S.to_backend_portable_node n in + let _ = S.to_backend_portable_node (fst n) in () in let () = trigger_node_to_backend_portable portable_dirty in @@ -1704,7 +1767,7 @@ module Make (S : Generic_key) = struct S.Tree.Proof.v ~before ~after state in let wrong_hash = B.Contents.Hash.hash "not the right hash!" in - let wrong_kinded_hash = `Node wrong_hash in + let wrong_kinded_hash = `Node (wrong_hash, []) in let () = check_bad_proof (proof ~before:wrong_kinded_hash ()) in let () = check_bad_proof (proof ~after:wrong_kinded_hash ()) in let _ = S.Tree.verify_proof (proof ()) f0 in @@ -1761,8 +1824,10 @@ module Make (S : Generic_key) = struct in (match S.Tree.destruct c1 with | `Contents _ -> Alcotest.fail "got `Contents, expected `Node" + | `Contents_inlined_3 _ -> + Alcotest.fail "got `Contents_inlined_3, expected `Node" | `Node node -> ( - let v = S.to_backend_node node in + let v = S.to_backend_node (fst node) in let () = let ls = B.Node.Val.list v in Alcotest.(check int) "list wide node" size (List.length ls) @@ -1772,7 +1837,7 @@ module Make (S : Generic_key) = struct let v1 = B.Node.Val.add v "x" k in let () = let h' = B.Node.Hash.hash v1 in - let h = with_node repo (fun n -> B.Node.add n v1) in + let h = with_node repo (fun n () -> B.Node.add n v1) in check B.Node.Hash.t "wide node + x: hash(v) = add(v)" (B.Node.Key.to_hash h) h' in @@ -1787,7 +1852,7 @@ module Make (S : Generic_key) = struct let () = let v3 = B.Node.Val.remove v "1" in let h' = B.Node.Hash.hash v3 in - with_node repo (fun n -> B.Node.add n v3) |> fun h -> + with_node repo (fun n () -> B.Node.add n v3) |> fun h -> check B.Node.Hash.t "wide node - 1 : hash(v) = add(v)" (B.Node.Key.to_hash h) h' in @@ -2261,7 +2326,7 @@ module Make (S : Generic_key) = struct with_node repo (fun n -> let contents = contents s in let node = B.Node.Val.(add (empty ())) s (normal contents) in - B.Node.add n node) + fun () -> B.Node.add n node) in let commit (s : string) : S.commit_key = with_commit repo (fun c -> @@ -2271,15 +2336,16 @@ module Make (S : Generic_key) = struct in let foo_k = node "foo" in let bar_k = node "bar" in - let tree_1 = S.Tree.shallow repo (`Node foo_k) in - let tree_2 = S.Tree.shallow repo (`Node bar_k) in + let tree_1 = S.Tree.shallow repo (`Node (foo_k, [])) in + let tree_2 = S.Tree.shallow repo (`Node (bar_k, [])) in let node_3 = let contents_foo = contents "foo" in S.Backend.Node.Val.of_list [ ("foo", `Contents (contents_foo, S.Metadata.default)); - ("bar", `Node bar_k); + ("bar", `Node (bar_k, [])); ] + [] in let tree_3 = S.Tree.of_node (S.of_backend_node repo node_3) in let _ = @@ -2293,7 +2359,7 @@ module Make (S : Generic_key) = struct let h = S.Head.get t in let commit_v = let commit_foo = commit "foo" in - S.Backend.Commit.Val.v ~info:(info ()) ~node:key_3 + S.Backend.Commit.Val.v ~info:(info ()) ~node:(fst key_3) ~parents:[ S.Commit.key h; commit_foo ] in let commit_key = with_commit repo (fun c -> B.Commit.add c commit_v) in @@ -2327,7 +2393,10 @@ module Make (S : Generic_key) = struct let node_b = S.Tree.destruct tree - |> ( function `Contents _ -> assert false | `Node n -> n ) + |> ( function + | `Contents _ -> assert false + | `Contents_inlined_3 _ -> assert false + | `Node (n, _il) -> n ) |> S.to_backend_node in let node_ph = pre_hash_of S.Backend.Node.Val.t node_b in diff --git a/src/irmin-test/store_graph.ml b/src/irmin-test/store_graph.ml index f30fa37dd8..6cfe6de7d1 100644 --- a/src/irmin-test/store_graph.ml +++ b/src/irmin-test/store_graph.ml @@ -37,7 +37,9 @@ module Make (S : Generic_key) = struct in let node k = if mem (`Node k) !visited then - Alcotest.failf "node %a visited twice" (Irmin.Type.pp B.Node.Key.t) k; + Alcotest.failf "node %a visited twice" + (Irmin.Type.pp B.Node.Key.t) + (fst k); visited := `Node k :: !visited in let contents ?order k = @@ -110,89 +112,138 @@ module Make (S : Generic_key) = struct let test1 () = let foo = with_contents repo (fun c -> B.Contents.add c "foo") in let foo_k = (foo, S.Metadata.default) in - let k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in - let k2 = with_node repo (fun g -> Graph.v g [ ("a", `Node k1) ]) in - let k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in - let nodes = [ `Contents foo_k; `Node k1; `Node k2; `Node k3 ] in + let k1 = + with_node repo (fun g () -> Graph.v g [ ("b", normal foo) ]) [] + in + let k2 = + with_node repo (fun g () -> Graph.v g [ ("a", `Node (k1, [])) ]) [] + in + let k3 = + with_node repo (fun g () -> Graph.v g [ ("c", `Node (k1, [])) ]) [] + in + let nodes = + [ `Contents foo_k; `Node (k1, []); `Node (k2, []); `Node (k3, []) ] + in visited := []; - test_rev_order ~nodes ~max:[ k2; k3 ]; + test_rev_order ~nodes ~max:[ (k2, []); (k3, []) ]; visited := []; - test_in_order ~nodes ~max:[ k2; k3 ]; + test_in_order ~nodes ~max:[ (k2, []); (k3, []) ]; visited := []; skipped := []; - test_skip ~max:[ k2; k3 ] ~to_skip:[ `Node k1 ] ~not_visited:[]; + test_skip + ~max:[ (k2, []); (k3, []) ] + ~to_skip:[ `Node (k1, []) ] + ~not_visited:[]; visited := []; let () = - test_min_max ~nodes ~min:[ k1 ] ~max:[ k2 ] - ~not_visited:[ `Contents foo_k; `Node k3 ] + test_min_max ~nodes + ~min:[ (k1, []) ] + ~max:[ (k2, []) ] + ~not_visited:[ `Contents foo_k; `Node (k3, []) ] in visited := []; - test_min_max ~nodes ~min:[ k2; k3 ] ~max:[ k2; k3 ] - ~not_visited:[ `Contents foo_k; `Node k1 ] + test_min_max ~nodes + ~min:[ (k2, []); (k3, []) ] + ~max:[ (k2, []); (k3, []) ] + ~not_visited:[ `Contents foo_k; `Node (k1, []) ] in let test2 () = (* Graph.iter requires a node as max, we cannot test a graph with only contents. *) let foo = with_contents repo (fun c -> B.Contents.add c "foo") in let foo_k = (foo, S.Metadata.default) in - let k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + let k1 = + with_node repo (fun g () -> Graph.v g [ ("b", normal foo) ]) [] + in visited := []; - test_rev_order ~nodes:[ `Contents foo_k; `Node k1 ] ~max:[ k1 ]; + test_rev_order + ~nodes:[ `Contents foo_k; `Node (k1, []) ] + ~max:[ (k1, []) ]; visited := []; skipped := []; - test_skip ~max:[ k1 ] - ~to_skip:[ `Node k1 ] + test_skip + ~max:[ (k1, []) ] + ~to_skip:[ `Node (k1, []) ] ~not_visited:[ `Contents foo_k ] in let test3 () = let foo = with_contents repo (fun c -> B.Contents.add c "foo") in let foo_k = (foo, S.Metadata.default) in - let kb1 = with_node repo (fun g -> Graph.v g [ ("b1", normal foo) ]) in - let ka1 = with_node repo (fun g -> Graph.v g [ ("a1", `Node kb1) ]) in - let ka2 = with_node repo (fun g -> Graph.v g [ ("a2", `Node kb1) ]) in - let kb2 = with_node repo (fun g -> Graph.v g [ ("b2", normal foo) ]) in + let kb1 = + with_node repo (fun g () -> Graph.v g [ ("b1", normal foo) ]) [] + in + let ka1 = + with_node repo (fun g () -> Graph.v g [ ("a1", `Node (kb1, [])) ]) [] + in + let ka2 = + with_node repo (fun g () -> Graph.v g [ ("a2", `Node (kb1, [])) ]) [] + in + let kb2 = + with_node repo (fun g () -> Graph.v g [ ("b2", normal foo) ]) [] + in let kc = - with_node repo (fun g -> + with_node repo + (fun g () -> Graph.v g - [ ("c1", `Node ka1); ("c2", `Node ka2); ("c3", `Node kb2) ]) + [ + ("c1", `Node (ka1, [])); + ("c2", `Node (ka2, [])); + ("c3", `Node (kb2, [])); + ]) + [] in let nodes = [ `Contents foo_k; - `Node kb1; - `Node ka1; - `Node ka2; - `Node kb2; - `Node kc; + `Node (kb1, []); + `Node (ka1, []); + `Node (ka2, []); + `Node (kb2, []); + `Node (kc, []); ] in visited := []; - test_rev_order ~nodes ~max:[ kc ]; + test_rev_order ~nodes ~max:[ (kc, []) ]; visited := []; - test_in_order ~nodes ~max:[ kc ]; + test_in_order ~nodes ~max:[ (kc, []) ]; visited := []; skipped := []; let () = - test_skip ~max:[ kc ] - ~to_skip:[ `Node ka1; `Node ka2 ] - ~not_visited:[ `Node kb1 ] + test_skip + ~max:[ (kc, []) ] + ~to_skip:[ `Node (ka1, []); `Node (ka2, []) ] + ~not_visited:[ `Node (kb1, []) ] in visited := []; skipped := []; let () = - test_skip ~max:[ kc ] - ~to_skip:[ `Node ka1; `Node ka2; `Node kb2 ] - ~not_visited:[ `Node kb1; `Contents foo_k ] + test_skip + ~max:[ (kc, []) ] + ~to_skip:[ `Node (ka1, []); `Node (ka2, []); `Node (kb2, []) ] + ~not_visited:[ `Node (kb1, []); `Contents foo_k ] in visited := []; let () = - test_min_max ~nodes ~min:[ kb1 ] ~max:[ ka1 ] - ~not_visited:[ `Contents foo_k; `Node ka2; `Node kb2; `Node kc ] + test_min_max ~nodes + ~min:[ (kb1, []) ] + ~max:[ (ka1, []) ] + ~not_visited: + [ + `Contents foo_k; `Node (ka2, []); `Node (kb2, []); `Node (kc, []); + ] in visited := []; - test_min_max ~nodes ~min:[ kc ] ~max:[ kc ] + test_min_max ~nodes + ~min:[ (kc, []) ] + ~max:[ (kc, []) ] ~not_visited: - [ `Contents foo_k; `Node kb1; `Node ka1; `Node ka2; `Node kb2 ] + [ + `Contents foo_k; + `Node (kb1, []); + `Node (ka1, []); + `Node (ka2, []); + `Node (kb2, []); + ] in test1 (); test2 (); diff --git a/src/irmin-tezos/schema.ml b/src/irmin-tezos/schema.ml index 0ecb2b4249..66d141c522 100644 --- a/src/irmin-tezos/schema.ml +++ b/src/irmin-tezos/schema.ml @@ -95,7 +95,7 @@ struct let hash_of_entry (_, t) = match t with - | `Node h -> Node_key.to_hash h + | `Node (h, _) -> Node_key.to_hash h | `Contents (h, _) -> Contents_key.to_hash h (* Irmin 1.4 uses int64 to store list lengths *) diff --git a/src/irmin/commit.ml b/src/irmin/commit.ml index f0c0d4e0c4..460e2860db 100644 --- a/src/irmin/commit.ml +++ b/src/irmin/commit.ml @@ -171,7 +171,7 @@ struct let empty_if_none (n, _) = function | None -> N.add n (N.Val.empty ()) - | Some node -> node + | Some (node, _) -> node let equal_key = Type.(unstage (equal Key.t)) let equal_opt_keys = Type.(unstage (equal (option Key.t))) @@ -202,9 +202,9 @@ struct | None -> Merge.ok None | Some old -> let vold = get t old in - Merge.ok (Some (Some (Val.node vold))) + Merge.ok (Some (Some (Val.node vold, []))) in - merge_node t ~old (Some (Val.node v1)) (Some (Val.node v2)) + merge_node t ~old (Some (Val.node v1, [])) (Some (Val.node v2, [])) >>=* fun node -> let node = empty_if_none t node in let parents = [ k1; k2 ] in @@ -287,7 +287,8 @@ module History (S : Store) = struct let edges t = [%log.debug "edges"]; - [ `Node (S.Val.node t) ] @ List.map (fun k -> `Commit k) (S.Val.parents t) + [ `Node (S.Val.node t, []) ] + @ List.map (fun k -> `Commit k) (S.Val.parents t) let closure t ~min ~max = [%log.debug "closure"]; diff --git a/src/irmin/dot.ml b/src/irmin/dot.ml index 5fcfaf9698..cdba3fa3b8 100644 --- a/src/irmin/dot.ml +++ b/src/irmin/dot.ml @@ -162,7 +162,9 @@ module Make (S : Store.Generic_key.S) = struct !contents; List.iter (fun (k, t) -> - add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ]) + add_vertex + (`Node (k, [])) + [ `Shape `Box; `Style `Dotted; label_of_node k t ]) !nodes; List.iter (fun (k, r) -> @@ -176,12 +178,16 @@ module Make (S : Store.Generic_key.S) = struct match v with | `Contents (v, _meta) -> let v = Contents.Key.to_hash v in - add_edge (`Node k) + add_edge + (`Node (k, [])) [ `Style `Dotted; label_of_step l ] (`Contents v) - | `Node n -> + | `Node (n, _) -> let n = Node.Key.to_hash n in - add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n)) + add_edge + (`Node (k, [])) + [ `Style `Solid; label_of_step l ] + (`Node (n, []))) (Node.Val.list t)) !nodes; List.iter @@ -192,7 +198,7 @@ module Make (S : Store.Generic_key.S) = struct add_edge (`Commit k) [ `Style `Bold ] (`Commit c)) (Commit.Val.parents r); let node_hash = Commit.Val.node r |> Node.Key.to_hash in - add_edge (`Commit k) [ `Style `Dashed ] (`Node node_hash)) + add_edge (`Commit k) [ `Style `Dashed ] (`Node (node_hash, []))) !commits; let branch_t = S.Backend.Repo.branch_t (S.repo t) in let bs = Branch.list branch_t in diff --git a/src/irmin/node.ml b/src/irmin/node.ml index 799d852006..502d309d84 100644 --- a/src/irmin/node.ml +++ b/src/irmin/node.ml @@ -58,7 +58,10 @@ module Of_core (S : Core) = struct merge_metadata merge_key) let merge_node merge_key = - Merge.alist S.step_t S.node_key_t (fun _step -> merge_key) + Merge.alist S.step_t + (Type.pair S.node_key_t (Type.list S.contents_key_t)) + (fun _step -> merge_key) + (* TODO: inline *) (* FIXME: this is very broken; do the same thing as [Tree.merge] instead. *) @@ -67,7 +70,7 @@ module Of_core (S : Core) = struct let implode (contents, succ) = let xs = List.rev_map (fun (s, c) -> (s, `Contents c)) contents in let ys = List.rev_map (fun (s, n) -> (s, `Node n)) succ in - S.of_list (xs @ ys) + S.of_list (xs @ ys) [] in let merge = Merge.pair (merge_contents contents) (merge_node node) in Merge.like S.t merge explode implode @@ -108,33 +111,41 @@ struct type t = Path.step [@@deriving irmin ~compare] end) - type 'h node_entry = { name : Path.step; node : 'h } [@@deriving irmin] + type ('h, 'hi) node_entry = { name : Path.step; node : 'h; inlined : 'hi } + [@@deriving irmin] type entry = - | Node of node_key node_entry + | Node of (node_key, contents_key list) node_entry | Contents of contents_key contents_entry | Contents_m of contents_key contents_m_entry + | Contents_inlined of contents_key contents_entry (* Invariant: the [_hash] cases are only externally reachable via [Portable.of_node]. *) - | Node_hash of Hash.t node_entry + | Node_hash of (Hash.t, Hash.t list) node_entry | Contents_hash of Hash.t contents_entry | Contents_m_hash of Hash.t contents_m_entry + | Contents_inlined_hash of Hash.t contents_entry [@@deriving irmin] type t = entry StepMap.t - type value = [ `Contents of contents_key * metadata | `Node of node_key ] - type weak_value = [ `Contents of hash * metadata | `Node of hash ] + type value = + [ `Contents of contents_key * metadata + | `Node of node_key * contents_key list ] + + type weak_value = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin] (* FIXME: special-case the default metadata in the default signature? *) let value_t = let open Type in variant "value" (fun n c x -> function - | `Node h -> n h + | `Node (h, l) -> n (h, l) | `Contents (h, m) -> if equal_metadata m Metadata.default then c h else x (h, m)) - |~ case1 "node" node_key_t (fun k -> `Node k) + |~ case1 "node" + (pair node_key_t (list contents_key_t)) + (fun (k, ic) -> `Node (k, ic)) |~ case1 "contents" contents_key_t (fun h -> `Contents (h, Metadata.default)) |~ case1 "contents-x" (pair contents_key_t Metadata.t) (fun (h, m) -> @@ -142,20 +153,25 @@ struct |> sealv let to_entry (k, (v : value)) = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + Fmt.pr "v: %a@." (Repr.pp value_t) v; match v with - | `Node h -> Node { name = k; node = h } + | `Node (h, ic) -> Node { name = k; node = h; inlined = ic } | `Contents (h, m) -> if equal_metadata m Metadata.default then Contents { name = k; contents = h } else Contents_m { metadata = m; name = k; contents = h } let inspect_nonportable_entry_exn : entry -> step * value = function - | Node n -> (n.name, `Node n.node) + | Node n -> (n.name, `Node (n.node, n.inlined)) | Contents c -> (c.name, `Contents (c.contents, Metadata.default)) | Contents_m c -> (c.name, `Contents (c.contents, c.metadata)) - | Node_hash _ | Contents_hash _ | Contents_m_hash _ -> + | Node_hash _ | Contents_hash _ | Contents_m_hash _ + | Contents_inlined_hash _ -> (* Not reachable after [Portable.of_node]. See invariant on {!entry}. *) assert false + | Contents_inlined _ -> assert false let step_of_entry : entry -> step = function | Node { name; _ } @@ -165,23 +181,32 @@ struct | Contents_hash { name; _ } | Contents_m_hash { name; _ } -> name + | Contents_inlined { name; _ } -> name + | Contents_inlined_hash { name; _ } -> name let weak_of_entry : entry -> step * weak_value = function - | Node n -> (n.name, `Node (Node_key.to_hash n.node)) - | Node_hash n -> (n.name, `Node n.node) + | Node n -> + ( n.name, + `Node + (Node_key.to_hash n.node, List.map Contents_key.to_hash n.inlined) + ) + | Node_hash n -> (n.name, `Node (n.node, n.inlined)) | Contents c -> (c.name, `Contents (Contents_key.to_hash c.contents, Metadata.default)) | Contents_m c -> (c.name, `Contents (Contents_key.to_hash c.contents, c.metadata)) | Contents_hash c -> (c.name, `Contents (c.contents, Metadata.default)) | Contents_m_hash c -> (c.name, `Contents (c.contents, c.metadata)) + | Contents_inlined _c -> assert false + | Contents_inlined_hash _c -> assert false - let of_seq l = + let of_seq l _to_inline = + Fmt.pr "LIST TO_INLINE: %d@." (List.length _to_inline); Seq.fold_left (fun acc x -> StepMap.add (fst x) (to_entry x) acc) StepMap.empty l - let of_list l = of_seq (List.to_seq l) + let of_list l to_inline = of_seq (List.to_seq l) to_inline let seq_entries ~offset ?length (t : t) = let take seq = match length with None -> seq | Some n -> Seq.take n seq in @@ -223,9 +248,10 @@ struct module Hash_preimage = struct type entry = - | Node_hash of Hash.t node_entry + | Node_hash of (Hash.t, Hash.t list) node_entry | Contents_hash of Hash.t contents_entry | Contents_m_hash of Hash.t contents_m_entry + | Contents_inlined_hash of Hash.t contents_entry [@@deriving irmin] type t = entry list [@@deriving irmin ~pre_hash] @@ -251,19 +277,30 @@ struct |> Seq.map (fun (_, v) -> match v with (* Weaken keys to hashes *) - | Node { name; node } -> - Hash_preimage.Node_hash { name; node = Node_key.to_hash node } + | Node { name; node; inlined } -> + Hash_preimage.Node_hash + { + name; + node = Node_key.to_hash node; + inlined = List.map Contents_key.to_hash inlined; + } | Contents { name; contents } -> Contents_hash { name; contents = Contents_key.to_hash contents } | Contents_m { metadata; name; contents } -> Contents_m_hash { metadata; name; contents = Contents_key.to_hash contents } - | Node_hash { name; node } -> Node_hash { name; node } + | Node_hash { name; node; inlined } -> + Node_hash { name; node; inlined } | Contents_hash { name; contents } -> Contents_hash { name; contents } | Contents_m_hash { metadata; name; contents } -> - Contents_m_hash { metadata; name; contents }) + Contents_m_hash { metadata; name; contents } + | Contents_inlined { name; contents } -> + Contents_inlined_hash + { name; contents = Contents_key.to_hash contents } + | Contents_inlined_hash { name; contents } -> + Contents_inlined_hash { name; contents }) |> Seq.fold_left (fun xs x -> x :: xs) [] in pre_hash entries f @@ -324,7 +361,7 @@ module Portable = struct assert (depth = 0); match t with | `Blinded _ | `Inode _ -> None - | `Values e -> Some (of_list e) + | `Values e -> Some (of_list e []) end module Of_node (X : S) = struct @@ -356,19 +393,25 @@ struct type node_key = hash [@@deriving irmin] type value = weak_value [@@deriving irmin] - let to_entry name = function - | `Node node -> Node_hash { name; node } + let to_entry name v = + match v with + | `Node (node, to_inline) -> + Node_hash { name; node; inlined = to_inline } | `Contents (contents, metadata) -> if equal_metadata metadata Metadata.default then Contents_hash { name; contents } else Contents_m_hash { name; contents; metadata } - let of_seq s = + let of_seq s to_inline = + Fmt.pr "LIST TO_INLINE: %d@." (List.length to_inline); Seq.fold_left - (fun acc (name, v) -> StepMap.add name (to_entry name v) acc) + (fun acc (name, v) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + StepMap.add name (to_entry name v) acc) StepMap.empty s - let of_list s = of_seq (List.to_seq s) + let of_list s to_inline = of_seq (List.to_seq s) to_inline let add t name v = let entry = to_entry name v in @@ -477,16 +520,21 @@ struct let rec merge t = let merge_key = - Merge.v [%typ: Key.t option] (fun ~old x y -> - Merge.(f (merge t)) ~old x y) + Merge.v + (Repr.option (Repr.pair Key.t (Repr.list C.Key.t))) + (fun ~old x y -> Merge.(f (merge t)) ~old x y) in let merge = Val.merge ~contents:C.(merge (fst t)) ~node:merge_key in let read = function | None -> Val.empty () - | Some k -> ( match find t k with None -> Val.empty () | Some v -> v) + | Some (k, _il) -> ( + match find t k with None -> Val.empty () | Some v -> v) in - let add v = if Val.is_empty v then None else Some (add t v) in - Merge.like_blocking [%typ: Key.t option] merge read add + (* TODO inline *) + let add v = if Val.is_empty v then None else Some (add t v, []) in + Merge.like_blocking + (Repr.option (Repr.pair Key.t (Repr.list C.Key.t))) + merge read add end module Generic_key = struct @@ -522,7 +570,10 @@ module Graph (S : Store) = struct type node_key = S.Key.t [@@deriving irmin] type path = Path.t [@@deriving irmin] type 'a t = 'a S.t - type value = [ `Contents of contents_key * metadata | `Node of node_key ] + + type value = + [ `Contents of contents_key * metadata + | `Node of node_key * contents_key list ] let empty t = S.add t (S.Val.empty ()) @@ -538,22 +589,27 @@ module Graph (S : Store) = struct let edges t = List.rev_map - (function _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (function + | _, `Node (n, il) -> `Node (n, il) | _, `Contents (c, _) -> `Contents c) (S.Val.list t) let pp_key = Type.pp S.Key.t - let pp_keys = Fmt.(Dump.list pp_key) + + let pp_keys = + Fmt.(Dump.list (Dump.pair pp_key (Dump.list (Type.pp S.Contents.Key.t)))) + let pp_path = Type.pp S.Path.t let equal_val = Type.(unstage (equal S.Val.t)) let pred t = function - | `Node k -> ( match S.find t k with None -> [] | Some v -> edges v) + | `Node (k, _il) -> ( + match S.find t k with None -> [] | Some v -> edges v) | _ -> [] let closure t ~min ~max = [%log.debug "closure min=%a max=%a" pp_keys min pp_keys max]; - let min = List.rev_map (fun x -> `Node x) min in - let max = List.rev_map (fun x -> `Node x) max in + let min = List.rev_map (fun (x, il) -> `Node (x, il)) min in + let max = List.rev_map (fun (x, il) -> `Node (x, il)) max in let g = Graph.closure ~pred:(pred t) ~min ~max () in List.fold_left (fun acc -> function `Node x -> x :: acc | _ -> acc) @@ -567,6 +623,7 @@ module Graph (S : Store) = struct let node = function | `Node x -> node x | `Contents c -> contents c + | `Contents_inlined_2 c -> contents c | `Branch _ | `Commit _ -> () in let edge = @@ -582,7 +639,7 @@ module Graph (S : Store) = struct in Graph.iter ~pred:(pred t) ~min ~max ~node ?edge ~skip ~rev () - let v t xs = S.add t (S.Val.of_list xs) + let v t xs to_inline = S.add t (S.Val.of_list xs to_inline) let find_step t node step = [%log.debug "contents %a" pp_key node]; @@ -592,11 +649,11 @@ module Graph (S : Store) = struct [%log.debug "read_node_exn %a %a" pp_key node pp_path path]; let rec aux node path = match Path.decons path with - | None -> Some (`Node node) + | None -> Some (`Node (node, [])) | Some (h, tl) -> ( match find_step t node h with | (None | Some (`Contents _)) as x -> x - | Some (`Node node) -> aux node tl) + | Some (`Node (node, _)) -> aux node tl) in aux node path @@ -608,7 +665,7 @@ module Graph (S : Store) = struct let old_node = match old_key with | None | Some (`Contents _) -> S.Val.empty () - | Some (`Node k) -> ( + | Some (`Node (k, _)) -> ( match S.find t k with None -> S.Val.empty () | Some v -> v) in let new_node = f old_node in @@ -618,7 +675,7 @@ module Graph (S : Store) = struct if S.Val.is_empty node then S.Val.empty () else node else let k = S.add t new_node in - S.Val.add node label (`Node k) + S.Val.add node label (`Node (k, [])) let map t node path f = [%log.debug "map %a %a" pp_key node pp_path path]; @@ -637,7 +694,9 @@ module Graph (S : Store) = struct match Path.rdecons path with | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) | None -> ( - match n with `Node n -> n | `Contents _ -> failwith "TODO: Node.add") + match n with + | `Node (n, _) -> n + | `Contents _ -> failwith "TODO: Node.add") let rdecons_exn path = match Path.rdecons path with @@ -704,13 +763,13 @@ module V1 (N : Generic_key.S with type step = string) = struct let hash_exn ?force t = N.hash_exn ?force t.n let head t = N.head t.n - let of_seq entries = - let n = N.of_seq entries in + let of_seq entries to_inline = + let n = N.of_seq entries to_inline in let entries = List.of_seq entries in { n; entries } - let of_list entries = - let n = N.of_list entries in + let of_list entries to_inline = + let n = N.of_list entries to_inline in { n; entries } let seq ?(offset = 0) ?length ?cache:_ t = @@ -753,7 +812,7 @@ module V1 (N : Generic_key.S with type step = string) = struct match (contents, metadata, node) with | Some c, None, None -> `Contents (c, Metadata.default) | Some c, Some m, None -> `Contents (c, m) - | None, None, Some n -> `Node n + | None, None, Some n -> `Node (n, []) | _ -> failwith "invalid node") |+ field "contents" (option Contents_key.t) (function | `Contents (x, _) -> Some x @@ -762,12 +821,15 @@ module V1 (N : Generic_key.S with type step = string) = struct | `Contents (_, x) when not (is_default x) -> Some x | _ -> None) |+ field "node" (option Node_key.t) (function - | `Node n -> Some n + | `Node (n, _) -> Some n | _ -> None) |> sealr let t : t Type.t = - Type.map Type.(list ~len:`Int64 (pair step_t value_t)) of_list list + Type.map + Type.(list ~len:`Int64 (pair step_t value_t)) + (fun l -> of_list l []) + list let merge ~contents ~node = let merge = N.merge ~contents ~node in diff --git a/src/irmin/node_intf.ml b/src/irmin/node_intf.ml index 6f45f19eb5..918743c961 100644 --- a/src/irmin/node_intf.ml +++ b/src/irmin/node_intf.ml @@ -35,7 +35,9 @@ module type Core = sig type step [@@deriving irmin] (** The type for steps between nodes. *) - type value = [ `Node of node_key | `Contents of contents_key * metadata ] + type value = + [ `Node of node_key * contents_key list + | `Contents of contents_key * metadata ] [@@deriving irmin] (** The type for either (node) keys or (contents) keys combined with their metadata. *) @@ -43,7 +45,7 @@ module type Core = sig type hash [@@deriving irmin] (** The type of hashes of values. *) - val of_list : (step * value) list -> t + val of_list : (step * value) list -> contents_key list -> t (** [of_list l] is the node [n] such that [list n = l]. *) val list : @@ -51,7 +53,7 @@ module type Core = sig (** [list t] is the contents of [t]. [offset] and [length] are used to paginate results. *) - val of_seq : (step * value) Seq.t -> t + val of_seq : (step * value) Seq.t -> contents_key list -> t (** [of_seq s] is the node [n] such that [seq n = s]. *) val seq : @@ -151,7 +153,7 @@ module type S_generic_key = sig val merge : contents:contents_key option Merge.t -> - node:node_key option Merge.t -> + node:(node_key * contents_key list) option Merge.t -> t Merge.t (** [merge] is the merge function for nodes. *) @@ -187,7 +189,7 @@ module type Portable = sig val merge : contents:contents_key option Merge.t -> - node:node_key option Merge.t -> + node:(node_key * contents_key list) option Merge.t -> t Merge.t (** [merge] is the merge function for nodes. *) @@ -244,9 +246,6 @@ module type Store = sig module Path : Path.S (** [Path] provides base functions on node paths. *) - val merge : [> read_write ] t -> key option Merge.t - (** [merge] is the 3-way merge function for nodes keys. *) - module Metadata : Metadata.S (** [Metadata] provides base functions for node metadata. *) @@ -263,6 +262,9 @@ module type Store = sig module Contents : Contents.Store with type key = Val.contents_key (** [Contents] is the underlying contents store. *) + + val merge : [> read_write ] t -> (key * Contents.key list) option Merge.t + (** [merge] is the 3-way merge function for nodes keys. *) end module type Graph = sig @@ -286,14 +288,16 @@ module type Graph = sig type path [@@deriving irmin] (** The type of store paths. A path is composed of {{!step} steps}. *) - type value = [ `Node of node_key | `Contents of contents_key * metadata ] + type value = + [ `Node of node_key * contents_key list + | `Contents of contents_key * metadata ] [@@deriving irmin] (** The type for store values. *) val empty : [> write ] t -> node_key (** The empty node. *) - val v : [> write ] t -> (step * value) list -> node_key + val v : [> write ] t -> (step * value) list -> contents_key list -> node_key (** [v t n] is a new node containing [n]. *) val list : [> read ] t -> node_key -> (step * value) list @@ -311,7 +315,10 @@ module type Graph = sig behhaves then same as [n] for other operations. *) val closure : - [> read ] t -> min:node_key list -> max:node_key list -> node_key list + [> read ] t -> + min:(node_key * contents_key list) list -> + max:(node_key * contents_key list) list -> + (node_key * contents_key list) list (** [closure t min max] is the unordered list of nodes [n] reachable from a node of [max] along a path which: (i) either contains no [min] or (ii) it ends with a [min]. @@ -320,12 +327,12 @@ module type Graph = sig val iter : [> read ] t -> - min:node_key list -> - max:node_key list -> - ?node:(node_key -> unit) -> + min:(node_key * contents_key list) list -> + max:(node_key * contents_key list) list -> + ?node:(node_key * contents_key list -> unit) -> ?contents:(contents_key -> unit) -> - ?edge:(node_key -> node_key -> unit) -> - ?skip_node:(node_key -> bool) -> + ?edge:(node_key * contents_key list -> node_key * contents_key list -> unit) -> + ?skip_node:(node_key * contents_key list -> bool) -> ?skip_contents:(contents_key -> bool) -> ?rev:bool -> unit -> diff --git a/src/irmin/object_graph.ml b/src/irmin/object_graph.ml index 0023a36005..4dbeb3f4d8 100644 --- a/src/irmin/object_graph.ml +++ b/src/irmin/object_graph.ml @@ -40,7 +40,8 @@ struct module X = struct type t = [ `Contents of Contents_key.t - | `Node of Node_key.t + | `Contents_inlined_2 of Contents_key.t + | `Node of Node_key.t * Contents_key.t list | `Commit of Commit_key.t | `Branch of Branch.t ] [@@deriving irmin] @@ -57,7 +58,9 @@ struct let hash (t : t) : int = match t with | `Contents c -> hash_contents c - | `Node n -> hash_node n + | `Contents_inlined_2 c -> hash_contents c + | `Node (n, _) -> hash_node n + (* TODO inline *) | `Commit c -> hash_commit c | `Branch b -> hash_branch b end @@ -241,9 +244,10 @@ struct let vertex_name k = let str t v = "\"" ^ Type.to_string t v ^ "\"" in match k with - | `Node n -> str Node_key.t n + | `Node (n, _) -> str Node_key.t n | `Commit c -> str Commit_key.t c | `Contents c -> str Contents_key.t c + | `Contents_inlined_2 c -> str Contents_key.t c | `Branch b -> str Branch.t b let vertex_attributes k = !vertex_attributes k diff --git a/src/irmin/object_graph_intf.ml b/src/irmin/object_graph_intf.ml index c07e15fec1..7a721c51fc 100644 --- a/src/irmin/object_graph_intf.ml +++ b/src/irmin/object_graph_intf.ml @@ -133,7 +133,8 @@ module type Sigs = sig S with type V.t = [ `Contents of Contents_key.t - | `Node of Node_key.t + | `Contents_inlined_2 of Contents_key.t + | `Node of Node_key.t * Contents_key.t list | `Commit of Commit_key.t | `Branch of Branch.t ] end diff --git a/src/irmin/proof.ml b/src/irmin/proof.ml index 3ad338a963..1d7e00942b 100644 --- a/src/irmin/proof.ml +++ b/src/irmin/proof.ml @@ -30,7 +30,7 @@ struct type step = S.step [@@deriving irmin] type metadata = M.t [@@deriving irmin] - type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + type kinded_hash = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin] type 'a inode = { length : int; proofs : (int * 'a) list } [@@deriving irmin] diff --git a/src/irmin/proof_intf.ml b/src/irmin/proof_intf.ml index cd6b4e6e4a..4ceb11599c 100644 --- a/src/irmin/proof_intf.ml +++ b/src/irmin/proof_intf.ml @@ -38,7 +38,7 @@ module type S = sig type step type metadata - type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + type kinded_hash = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin] type 'a inode = { length : int; proofs : (int * 'a) list } [@@deriving irmin] diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 9a64479753..f0cdf2d7fc 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -72,10 +72,12 @@ module Make (B : Backend.S) = struct | Some k -> Some k | None -> ( match hash t with - | `Node h -> ( + | `Node (h, _il) -> ( match B.Node.index (B.Repo.node_t r) h with | None -> None - | Some k -> Some (`Node k)) + | Some k -> + (* TODO inline *) + Some (`Node (k, []))) | `Contents (h, m) -> ( match B.Contents.index (B.Repo.contents_t r) h with | None -> None @@ -84,10 +86,12 @@ module Make (B : Backend.S) = struct let of_key r k = import r k let of_hash r = function - | `Node h -> ( + | `Node (h, _il) -> ( match B.Node.index (B.Repo.node_t r) h with | None -> None - | Some k -> of_key r (`Node k)) + | Some k -> + (* TODO inline *) + of_key r (`Node (k, []))) | `Contents (h, m) -> ( match B.Contents.index (B.Repo.contents_t r) h with | None -> None @@ -98,7 +102,7 @@ module Make (B : Backend.S) = struct let hash : ?cache:bool -> t -> hash = fun ?cache tr -> - match hash ?cache tr with `Node h -> h | `Contents (h, _) -> h + match hash ?cache tr with `Node (h, _) -> h | `Contents (h, _) -> h let pp = Type.pp t end @@ -111,7 +115,7 @@ module Make (B : Backend.S) = struct type commit = { r : repo; key : commit_key; v : B.Commit.value } type hash = Hash.t [@@deriving irmin ~equal ~pp ~compare] type node = Tree.node [@@deriving irmin] - type contents = Contents.t [@@deriving irmin ~equal] + type contents = Tree.contents [@@deriving irmin ~equal] type metadata = Metadata.t [@@deriving irmin] type tree = Tree.t [@@deriving irmin ~pp] type path = Path.t [@@deriving irmin ~pp] @@ -157,7 +161,13 @@ module Make (B : Backend.S) = struct let c = Tree.Contents.force_exn c in let k = save_contents x c in `Contents k - | `Node n -> + | `Contents_inlined_3 (c, _) -> + let c = Tree.Contents.force_exn c in + let k = save_contents x c in + `Contents_inlined_5 k + | `Node (n, _il) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let k = Tree.export ~clear r x y n in `Node k @@ -180,16 +190,27 @@ module Make (B : Backend.S) = struct B.Repo.batch ~lock:true r @@ fun contents_t node_t commit_t -> match Tree.destruct tree with | `Contents _ -> Error "cannot add contents at the root" - | `Node t -> + | `Contents_inlined_3 _ -> Error "cannot add contents at the root" + | `Node (t, _il) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + (* assert false; *) let node = Tree.export ~clear r contents_t node_t t in + (* assert false; *) + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let v = B.Commit.Val.v ~info ~node ~parents in + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let key = B.Commit.add commit_t v in + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; Ok { r; key; v } in match result with Ok t -> t | Error e -> invalid_arg e let node t = B.Commit.Val.node t.v - let tree t = Tree.import_no_check t.r (`Node (node t)) + let tree t = Tree.import_no_check t.r (`Node (node t, [])) let equal x y = equal_commit_key x.key y.key let key t = t.key let hash t = B.Commit.Key.to_hash t.key @@ -294,7 +315,7 @@ module Make (B : Backend.S) = struct match B.Commit.find (commit_t t) k with | None -> () | Some c -> - root_nodes := B.Commit.Val.node c :: !root_nodes; + root_nodes := (B.Commit.Val.node c, []) :: !root_nodes; B.Slice.add slice (`Commit (Commit_key.to_hash k, c))) keys; if not full then slice @@ -303,7 +324,8 @@ module Make (B : Backend.S) = struct let nodes = Graph.closure (node_t t) ~min:[] ~max:!root_nodes in let contents = ref Contents_keys.empty in List.iter - (fun k -> + (fun (k, _il) -> + (* TODO inline *) match B.Node.find (node_t t) k with | None -> () | Some v -> @@ -340,6 +362,8 @@ module Make (B : Backend.S) = struct let contents = ref [] in let nodes = ref [] in let commits = ref [] in + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; B.Slice.iter s (function | `Contents c -> contents := c :: !contents | `Node n -> nodes := n :: !nodes @@ -360,15 +384,17 @@ module Make (B : Backend.S) = struct type elt = [ `Commit of commit_key - | `Node of node_key + | `Node of node_key * contents_key list | `Contents of contents_key + | `Contents_inlined_2 of contents_key | `Branch of B.Branch.Key.t ] [@@deriving irmin] let return_false _ = false let default_pred_contents _ _ = [] + let default_pred_contents_inlined _ _ = [] - let default_pred_node t k = + let default_pred_node t (k, _il) = match B.Node.find (node_t t) k with | None -> [] | Some v -> @@ -385,7 +411,7 @@ module Make (B : Backend.S) = struct | Some c -> let node = B.Commit.Val.node c in let parents = B.Commit.Val.parents c in - [ `Node node ] @ List.map (fun k -> `Commit k) parents + [ `Node (node, []) ] @ List.map (fun k -> `Commit k) parents let default_pred_branch t b = match B.Branch.find (branch_t t) b with @@ -404,18 +430,21 @@ module Make (B : Backend.S) = struct | `Commit x -> commit x | `Node x -> node x | `Contents x -> contents x + | `Contents_inlined_2 x -> contents x | `Branch x -> branch x in let skip = function | `Commit x -> skip_commit x | `Node x -> skip_node x | `Contents x -> skip_contents x + | `Contents_inlined_2 x -> skip_contents x | `Branch x -> skip_branch x in let pred = function | `Commit x -> pred_commit t x | `Node x -> pred_node t x | `Contents x -> pred_contents t x + | `Contents_inlined_2 x -> pred_contents t x | `Branch x -> pred_branch t x in KGraph.iter ?cache_size ~pred ~min ~max ~node ?edge ~skip ~rev () @@ -429,12 +458,14 @@ module Make (B : Backend.S) = struct | `Commit x -> commit x | `Node x -> node x | `Contents x -> contents x + | `Contents_inlined_2 x -> contents x | `Branch x -> branch x in let pred = function | `Commit x -> pred_commit t x | `Node x -> pred_node t x | `Contents x -> pred_contents t x + | `Contents_inlined_2 x -> pred_contents t x | `Branch x -> pred_branch t x in KGraph.breadth_first_traversal ?cache_size ~pred ~max ~node () @@ -564,7 +595,8 @@ module Make (B : Backend.S) = struct if Atomic.compare_and_set t.tree old None then (* the tree cache needs to be invalidated *) let tree = - Tree.import_no_check (repo t) (`Node (Commit.node h)) + (* TODO inline *) + Tree.import_no_check (repo t) (`Node (Commit.node h, [])) in if Atomic.compare_and_set t.tree None (Some (h, tree)) then Some (h, tree) @@ -699,8 +731,9 @@ module Make (B : Backend.S) = struct aux 0 let root_tree = function - | `Node _ as n -> Tree.v n + | `Node (n, _il) -> Tree.v (`Node (n, [])) | `Contents _ -> assert false + | `Contents_inlined_3 _ -> assert false let add_commit t old_head ((c, _) as tree) = match t.head_ref with @@ -910,7 +943,12 @@ module Make (B : Backend.S) = struct let mem_tree t k = tree t |> fun tree -> Tree.mem_tree tree k let find_all t k = tree t |> fun tree -> Tree.find_all tree k let find t k = tree t |> fun tree -> Tree.find tree k - let get t k = tree t |> fun tree -> Tree.get tree k + + let get t k = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + tree t |> fun tree -> Tree.get tree k + let find_tree t k = tree t |> fun tree -> Tree.find_tree tree k let get_tree t k = tree t |> fun tree -> Tree.get_tree tree k @@ -920,7 +958,7 @@ module Make (B : Backend.S) = struct | Some tree -> ( match Tree.key tree with | Some (`Contents (key, _)) -> Some (`Contents key) - | Some (`Node key) -> Some (`Node key) + | Some (`Node (key, _)) -> Some (`Node key) | None -> None) let hash t k = diff --git a/src/irmin/store_intf.ml b/src/irmin/store_intf.ml index 4a12ed3d64..2a4c35be44 100644 --- a/src/irmin/store_intf.ml +++ b/src/irmin/store_intf.ml @@ -149,15 +149,17 @@ module type S_generic_key = sig type elt = [ `Commit of commit_key - | `Node of node_key + | `Node of node_key * contents_key list | `Contents of contents_key + | `Contents_inlined_2 of contents_key | `Branch of branch ] [@@deriving irmin] (** The type for elements iterated over by {!iter}. *) val default_pred_commit : t -> commit_key -> elt list - val default_pred_node : t -> node_key -> elt list + val default_pred_node : t -> node_key * contents_key list -> elt list val default_pred_contents : t -> contents_key -> elt list + val default_pred_contents_inlined : t -> contents_key -> elt list val iter : ?cache_size:int -> @@ -166,15 +168,15 @@ module type S_generic_key = sig ?edge:(elt -> elt -> unit) -> ?branch:(branch -> unit) -> ?commit:(commit_key -> unit) -> - ?node:(node_key -> unit) -> + ?node:(node_key * contents_key list -> unit) -> ?contents:(contents_key -> unit) -> ?skip_branch:(branch -> bool) -> ?skip_commit:(commit_key -> bool) -> - ?skip_node:(node_key -> bool) -> + ?skip_node:(node_key * contents_key list -> bool) -> ?skip_contents:(contents_key -> bool) -> ?pred_branch:(t -> branch -> elt list) -> ?pred_commit:(t -> commit_key -> elt list) -> - ?pred_node:(t -> node_key -> elt list) -> + ?pred_node:(t -> node_key * contents_key list -> elt list) -> ?pred_contents:(t -> contents_key -> elt list) -> ?rev:bool -> t -> @@ -221,11 +223,11 @@ module type S_generic_key = sig max:elt list -> ?branch:(branch -> unit) -> ?commit:(commit_key -> unit) -> - ?node:(node_key -> unit) -> + ?node:(node_key * contents_key list -> unit) -> ?contents:(contents_key -> unit) -> ?pred_branch:(t -> branch -> elt list) -> ?pred_commit:(t -> commit_key -> elt list) -> - ?pred_node:(t -> node_key -> elt list) -> + ?pred_node:(t -> node_key * contents_key list -> elt list) -> ?pred_contents:(t -> contents_key -> elt list) -> t -> unit @@ -438,7 +440,8 @@ module type S_generic_key = sig (** {1 Import/Export} *) type kinded_key = - [ `Contents of contents_key * metadata | `Node of node_key ] + [ `Contents of contents_key * metadata + | `Node of node_key * contents_key list ] [@@deriving irmin] (** Keys in the Irmin store are tagged with the type of the value they reference (either {!contents} or {!node}). In the [contents] case, the @@ -465,7 +468,8 @@ module type S_generic_key = sig val hash : ?cache:bool -> tree -> hash (** [hash t] is the hash of tree [t]. *) - type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + type kinded_hash = + [ `Contents of hash * metadata | `Node of hash * hash list ] (** Like {!kinded_key}, but with hashes as value references rather than keys. *) @@ -541,7 +545,7 @@ module type S_generic_key = sig (** {1 Reads} *) - val kind : t -> path -> [ `Contents | `Node ] option + val kind : t -> path -> [ `Contents | `Contents_inlined__1 | `Node ] option (** [kind] is {!Tree.kind} applied to [t]'s root tree. *) val list : t -> path -> (step * tree) list @@ -571,7 +575,10 @@ module type S_generic_key = sig val get_tree : t -> path -> tree (** [get_tree t k] is {!Tree.get_tree} applied to [t]'s root tree. *) - type kinded_key := [ `Contents of contents_key | `Node of node_key ] + type kinded_key := + [ `Contents of contents_key + | `Contents_inlined_5 of contents_key + | `Node of node_key ] val key : t -> path -> kinded_key option (** [id t k] *) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index bd21ebb18b..b47474a6d5 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -489,7 +489,11 @@ module Make (P : Backend.S) = struct type portable = Portable.t [@@deriving irmin ~equal ~pp] (* [elt] is a tree *) - type elt = [ `Node of t | `Contents of Contents.t * Metadata.t ] + type elt = + [ `Node of t * Contents.t list + | `Contents of Contents.t * Metadata.t + | `Contents_inlined_3 of Contents.t * Metadata.t ] + and update = Add of elt | Remove and updatemap = update StepMap.t and map = elt StepMap.t @@ -517,12 +521,23 @@ module Make (P : Backend.S) = struct let elt_t (t : t Type.t) : elt Type.t = let open Type in + let _f node contents contents_m = function + | `Node (x, il) -> node (x, il) + | `Contents (c, m) | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + if equal_metadata m Metadata.default then contents c + else contents_m (c, m) + in + let _g = case1 "Node" (pair t Contents.t) (fun x -> `Node x) in variant "Node.value" (fun node contents contents_m -> function - | `Node x -> node x - | `Contents (c, m) -> + | `Node (x, il) -> node (x, il) + | `Contents (c, m) | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; if equal_metadata m Metadata.default then contents c else contents_m (c, m)) - |~ case1 "Node" t (fun x -> `Node x) + |~ case1 "Node" (pair t (list Contents.t)) (fun x -> `Node x) |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) |> sealv @@ -619,7 +634,11 @@ module Make (P : Backend.S) = struct let rec clear_elt ~max_depth depth v = match v with | `Contents (c, _) -> if depth + 1 > max_depth then Contents.clear c - | `Node t -> clear ~max_depth (depth + 1) t + | `Contents_inlined_3 (c, _) -> + if depth + 1 > max_depth then Contents.clear c + | `Node (t, il) -> + clear ~max_depth (depth + 1) t; + List.iter Contents.clear il and clear_info ~max_depth ~v depth i = let clear _ v = clear_elt ~max_depth depth v in @@ -644,7 +663,7 @@ module Make (P : Backend.S) = struct in if depth >= max_depth then clear_info_fields i - and clear ~max_depth depth t = + and clear ~max_depth depth (t : t) = clear_info ~v:(Atomic.get t.v) ~max_depth depth t.info (* export t to the given repo and clear the cache *) @@ -724,7 +743,9 @@ module Make (P : Backend.S) = struct type nonrec repo = repo let t ~env repo = function - | `Node k -> `Node (of_key ~env repo k) + | `Node (k, il) -> + `Node + (of_key ~env repo k, List.map (Contents.of_key ~env repo) il) | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) end) @@ -735,7 +756,8 @@ module Make (P : Backend.S) = struct type repo = unit let t ~env () = function - | `Node h -> `Node (pruned ~env h) + | `Node (h, il) -> + `Node (pruned ~env h, List.map (Contents.pruned ~env) il) | `Contents (h, m) -> `Contents (Contents.pruned ~env h, m) end) @@ -927,7 +949,8 @@ module Make (P : Backend.S) = struct let weaken_value : node_value -> pnode_value = function | `Contents (key, m) -> `Contents (P.Contents.Key.to_hash key, m) - | `Node key -> `Node (P.Node.Key.to_hash key) + | `Node (key, il) -> + `Node (P.Node.Key.to_hash key, List.map P.Contents.Key.to_hash il) let set_hash_cache ~cache t hash = let (_ : bool) = @@ -971,37 +994,61 @@ module Make (P : Backend.S) = struct bindings |> Seq.exists (fun (_, v) -> match v with - | `Node n -> Option.is_none (cached_key n) - | `Contents (c, _) -> Option.is_none (Contents.cached_key c)) + | `Node (n, _il) -> Option.is_none (cached_key n) + | `Contents (c, _) -> Option.is_none (Contents.cached_key c) + | `Contents_inlined_3 (c, _) -> + Option.is_none (Contents.cached_key c)) in if must_build_portable_node then let pnode = - bindings - |> Seq.map (fun (step, v) -> - match v with - | `Contents (c, m) -> (step, `Contents (Contents.hash c, m)) - | `Node n -> hash ~cache n (fun k -> (step, `Node k))) - |> Portable.of_seq + let seq = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + (step, `Contents (Contents.hash c, m)) + | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + (step, `Contents (Contents.hash c, m)) + | `Node (n, _il) -> + hash ~cache n (fun k -> (step, `Node (k, [])))) + in + Portable.of_seq seq [] in k (Pnode pnode) else let node = - bindings - |> Seq.map (fun (step, v) -> - match v with - | `Contents (c, m) -> ( - match Contents.cached_key c with - | Some k -> (step, `Contents (k, m)) - | None -> - (* We checked that all child keys are cached above *) - assert false) - | `Node n -> ( - match cached_key n with - | Some k -> (step, `Node k) - | None -> - (* We checked that all child keys are cached above *) - assert false)) - |> P.Node.Val.of_seq + let seq = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Node (n, _il) -> ( + match cached_key n with + | Some k -> (step, `Node (k, [])) + | None -> + (* We checked that all child keys are cached above *) + assert false)) + in + P.Node.Val.of_seq seq [] in if cache then Atomic.set t.info.value (Some node); k (Node node) @@ -1011,13 +1058,22 @@ module Make (P : Backend.S) = struct fun ~cache e k -> match e with | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match Contents.key c with + | Some key -> k (Node_value (`Contents (key, m))) + | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; match Contents.key c with | Some key -> k (Node_value (`Contents (key, m))) | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) - | `Node n -> ( + | `Node (n, _il) -> ( match key n with - | Some key -> k (Node_value (`Node key)) - | None -> hash ~cache n (fun hash -> k (Pnode_value (`Node hash)))) + | Some key -> k (Node_value (`Node (key, []))) + | None -> + hash ~cache n (fun hash -> k (Pnode_value (`Node (hash, []))))) and hash_preimage_of_updates : type r. cache:bool -> t -> hash_preimage -> updatemap -> (hash_preimage, r) cont @@ -1056,6 +1112,8 @@ module Make (P : Backend.S) = struct let hash ~cache k = hash ~cache k (fun x -> x) let value_of_key ~cache t repo k = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; match cached_value t with | Some v -> ok v | None -> ( @@ -1191,7 +1249,8 @@ module Make (P : Backend.S) = struct || match (x, y) with | `Contents x, `Contents y -> contents_equal x y - | `Node x, `Node y -> equal x y + | `Contents_inlined_3 x, `Contents_inlined_3 y -> contents_equal x y + | `Node (x, _il), `Node (y, _il') -> equal x y | _ -> false and map_equal (x : map) (y : map) = StepMap.equal elt_equal x y @@ -1291,10 +1350,14 @@ module Make (P : Backend.S) = struct Portable_value.is_empty_after_updates ~cache p um let findv_aux ~cache ~value_of_key ctx t step = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let of_map m = try Some (StepMap.find step m) with Not_found -> None in let of_value = Regular_value.findv ~cache ~env:t.info.env step t in let of_portable = Portable_value.findv ~cache ~env:t.info.env step t () in let of_t () = + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; match (Scan.cascade t [ @@ -1315,24 +1378,42 @@ module Make (P : Backend.S) = struct | `pruned ] Scan.t) with - | Map m -> of_map m - | Repo_value (repo, v) -> of_value repo v + | Map m -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_map m + | Repo_value (repo, v) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_value repo v | Repo_key (repo, k) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let v = value_of_key ~cache t repo k in let v = get_ok ctx v in of_value repo v | Value_dirty (repo, v, um) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; match StepMap.find_opt step um with | Some (Add v) -> Some v | Some Remove -> None | None -> of_value repo v) - | Portable p -> of_portable p + | Portable p -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_portable p | Portable_dirty (p, um) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; match StepMap.find_opt step um with | Some (Add v) -> Some v | Some Remove -> None | None -> of_portable p) - | Pruned h -> pruned_hash_exn ctx h + | Pruned h -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + pruned_hash_exn ctx h in match Atomic.get t.info.findv_cache with | None -> of_t () @@ -1450,7 +1531,7 @@ module Make (P : Backend.S) = struct in let rec aux : type r. (t, acc, r) cps_folder = fun ~path acc d t k -> - let apply acc = node path t acc |> tree path (`Node t) in + let apply acc = node path t acc |> tree path (`Node (t, [])) in let next acc = match force with | `True -> ( @@ -1533,7 +1614,7 @@ module Make (P : Backend.S) = struct fun ~path acc d (s, v) k -> let path = Path.rcons path s in match v with - | `Node n -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k + | `Node (n, _il) -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k | `Contents c -> ( let apply () = let tree path = tree path (`Contents c) in @@ -1546,6 +1627,18 @@ module Make (P : Backend.S) = struct | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc | Some (`Gt depth) -> if d >= depth then apply () else k acc) + | `Contents_inlined_3 c -> ( + let apply () = + let tree path = tree path (`Contents c) in + Contents.fold ~force ~cache ~path contents tree (fst c) acc |> k + in + match depth with + | None -> apply () + | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc + | Some (`Le depth) -> if d < depth then apply () else k acc + | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc + | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc + | Some (`Gt depth) -> if d >= depth then apply () else k acc) and steps : type r. ((step * elt) Seq.t, acc, r) cps_folder = fun ~path acc d s k -> match s () with @@ -1613,12 +1706,54 @@ module Make (P : Backend.S) = struct | Some m -> Some (StepMap.remove step m) let update t step up = + Fmt.pr "update %a@." (Repr.pp step_t) step; let env = t.info.env in let of_map m = let m' = match up with | Remove -> StepMap.remove step m - | Add v -> StepMap.add step v m + | Add v -> ( + let update_ t = + match t with None -> t | Some _ -> assert false + in + match v with + | `Node ({ v = _node; _ }, _) -> + (* Fmt.pr "Node:@."; + (match Atomic.get node with + | Map map -> + Fmt.pr "Map@."; + let p1, p2 = + StepMap.partition + (fun _ -> function + | `Contents_inlined_3 _ -> true | _ -> false) + map + in + let print = + StepMap.iter (fun step (elt : elt) -> + match elt with + | `Node _ -> + Fmt.pr "Node / step: %a@." (Repr.pp step_t) step + | `Contents _ -> + Fmt.pr "Contents / step: %a@." (Repr.pp step_t) + step + | `Contents_inlined_3 _ -> + Fmt.pr "Contents_inlined / step: %a@." + (Repr.pp step_t) step) + in + Fmt.pr "TO INLINE:@."; + print p1; + Fmt.pr "NOT TO INLINE:@."; + print p2 + | Key _ -> Fmt.pr "Key@." + | Value _ -> Fmt.pr "Value@." + | Portable_dirty _ -> Fmt.pr "Portable_dirty@." + | Pruned _ -> Fmt.pr "Pruned@."); *) + StepMap.add step v m + | `Contents_inlined_3 _ -> + (* Fmt.pr "Contents_inlined_3@."; *) + let m = StepMap.update step update_ m in + StepMap.add step v m + | _ -> StepMap.add step v m) in if m == m' then t else of_map ~env m' in @@ -1657,15 +1792,35 @@ module Make (P : Backend.S) = struct | `pruned ] Scan.t) with - | Map m -> of_map m - | Repo_value (repo, v) -> of_value repo v StepMap.empty + | Map m -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_map m + | Repo_value (repo, v) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_value repo v StepMap.empty | Repo_key (repo, k) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let v = value_of_key ~cache:true t repo k |> get_ok "update" in of_value repo v StepMap.empty - | Value_dirty (repo, v, um) -> of_value repo v um - | Portable p -> of_portable p StepMap.empty - | Portable_dirty (p, um) -> of_portable p um - | Pruned h -> pruned_hash_exn "update" h + | Value_dirty (repo, v, um) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_value repo v um + | Portable p -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_portable p StepMap.empty + | Portable_dirty (p, um) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + of_portable p um + | Pruned h -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + pruned_hash_exn "update" h let remove t step = update t step Remove let add t step v = update t step (Add v) @@ -1723,6 +1878,7 @@ module Make (P : Backend.S) = struct Merge.bind_promise old (fun old () -> match old with | `Contents (_, m) -> ok (Some m) + | `Contents_inlined_3 (_, m) -> ok (Some m) | `Node _ -> ok None) in Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> @@ -1730,19 +1886,22 @@ module Make (P : Backend.S) = struct Merge.bind_promise old (fun old () -> match old with | `Contents (c, _) -> ok (Some c) + | `Contents_inlined_3 (c, _) -> ok (Some c) | `Node _ -> ok None) in Merge.(f Contents.merge) ~old x y >>=* fun c -> Merge.ok (`Contents (c, m)) - | `Node x, `Node y -> + (* TODO inlined *) + | `Node (x, _il), `Node (y, _il') -> (merge [@tailcall]) (fun m -> let old = Merge.bind_promise old (fun old () -> match old with | `Contents _ -> ok None - | `Node n -> ok (Some n)) + | `Contents_inlined_3 _ -> ok None + | `Node (n, _il) -> ok (Some n)) in - Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node (n, []))) | _ -> Merge.conflict "add/add values" in k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) @@ -1754,13 +1913,18 @@ module Make (P : Backend.S) = struct type node_key = Node.key [@@deriving irmin ~pp] type contents_key = Contents.key [@@deriving irmin ~pp] - type kinded_key = [ `Contents of Contents.key * metadata | `Node of Node.key ] + type kinded_key = + [ `Contents of Contents.key * metadata + | `Node of Node.key * Contents.key list ] [@@deriving irmin] - type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + type kinded_hash = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin ~equal] - type t = [ `Node of node | `Contents of Contents.t * Metadata.t ] + type t = + [ `Node of node * Contents.t list + | `Contents of Contents.t * Metadata.t + | `Contents_inlined_3 of Contents.t * metadata ] [@@deriving irmin] let to_backend_node n = @@ -1775,8 +1939,13 @@ module Make (P : Backend.S) = struct Node.of_value ~length ~env repo n let dump ppf = function - | `Node n -> Fmt.pf ppf "node: %a" Node.dump n + | `Node (n, il) -> + Fmt.pf ppf "node: %a - %a" Node.dump n + Fmt.Dump.(list (Type.pp Contents.t)) + il | `Contents (c, _) -> Fmt.pf ppf "contents: %a" (Type.pp Contents.t) c + | `Contents_inlined_3 (c, _) -> + Fmt.pf ppf "inlined contents: %a" (Type.pp Contents.t) c let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = x1 == x2 @@ -1787,30 +1956,61 @@ module Make (P : Backend.S) = struct x == y || match (x, y) with - | `Node x, `Node y -> Node.equal x y + | `Node (x, _xi), `Node (y, _yi) -> Node.equal x y + (* TODO inline *) | `Contents x, `Contents y -> contents_equal x y - | `Node _, `Contents _ | `Contents _, `Node _ -> false + | `Contents_inlined_3 x, `Contents_inlined_3 y -> contents_equal x y + | `Node _, `Contents _ + | `Node _, `Contents_inlined_3 _ + | `Contents _, `Node _ + | `Contents _, `Contents_inlined_3 _ + | `Contents_inlined_3 _, `Node _ + | `Contents_inlined_3 _, `Contents _ -> + false let is_empty = function - | `Node n -> Node.is_empty ~cache:true n + | `Node (n, _il) -> Node.is_empty ~cache:true n | `Contents _ -> false + | `Contents_inlined_3 _ -> false - type elt = [ `Node of node | `Contents of contents * metadata ] + type elt = + [ `Node of node * contents list + | `Contents of contents * metadata + | `Contents_inlined_3 of contents * metadata ] - let of_node n = `Node n + let of_node n = `Node (n, []) let of_contents ?(metadata = Metadata.default) c = let env = Env.empty () in let c = Contents.of_value ~env c in - `Contents (c, metadata) + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + Fmt.pr "%a@." (Repr.pp Contents.t) c; + let len = + match Repr.Size.of_value Contents.t with + | Dynamic f -> f c + | Static len -> len + | Unknown -> assert false + in + Fmt.pr "%d@." len; + if len < 16 then `Contents_inlined_3 (c, metadata) + else `Contents (c, metadata) + + let of_contents_inlined ?(metadata = Metadata.default) c = + let env = Env.empty () in + let c = Contents.of_value ~env c in + `Contents_inlined_3 (c, metadata) let v : elt -> t = function + | `Contents_inlined_3 (c, metadata) -> of_contents_inlined ~metadata c | `Contents (c, metadata) -> of_contents ~metadata c - | `Node n -> `Node n + | `Node (n, il) -> + `Node (n, List.map (Contents.of_value ~env:(Env.empty ())) il) let pruned_with_env ~env = function | `Contents (h, meta) -> `Contents (Contents.pruned ~env h, meta) - | `Node h -> `Node (Node.pruned ~env h) + | `Node (h, il) -> + `Node (Node.pruned ~env h, List.map (Contents.pruned ~env) il) let pruned h = let env = Env.empty () in @@ -1819,8 +2019,9 @@ module Make (P : Backend.S) = struct let destruct x = x let clear ?(depth = 0) = function - | `Node n -> Node.clear ~max_depth:depth 0 n + | `Node (n, _il) -> Node.clear ~max_depth:depth 0 n | `Contents _ -> () + | `Contents_inlined_3 _ -> () let sub ~cache ctx t path = let rec aux node path = @@ -1828,10 +2029,13 @@ module Make (P : Backend.S) = struct | None -> Some node | Some (h, p) -> ( Node.findv ~cache ctx node h |> function - | None | Some (`Contents _) -> None - | Some (`Node n) -> (aux [@tailcall]) n p) + | None | Some (`Contents _) | Some (`Contents_inlined_3 _) -> None + | Some (`Node (n, _il)) -> (aux [@tailcall]) n p) in - match t with `Node n -> (aux [@tailcall]) n path | `Contents _ -> None + match t with + | `Node (n, _il) -> (aux [@tailcall]) n path + | `Contents _ -> None + | `Contents_inlined_3 _ -> None let find_tree (t : t) path = let cache = true in @@ -1851,7 +2055,10 @@ module Make (P : Backend.S) = struct | `Contents (c, _) as c' -> let tree path = tree path c' in Contents.fold ~force ~cache ~path:Path.empty contents tree c acc - | `Node n -> + | `Contents_inlined_3 (c, _) as c' -> + let tree path = tree path c' in + Contents.fold ~force ~cache ~path:Path.empty contents tree c acc + | `Node (n, _il) -> Node.fold ~order ~force ~cache ~uniq ~pre ~post ~path:Path.empty ?depth ~contents ~node ~tree n acc @@ -1892,6 +2099,9 @@ module Make (P : Backend.S) = struct | Some (`Contents (c, m)) -> let c = Contents.to_value ~cache:true c in Some (get_ok "find_all" c, m) + | Some (`Contents_inlined_3 (c, m)) -> + let c = Contents.to_value ~cache:true c in + Some (get_ok "find_all" c, m) let find t k = find_all t k |> function None -> None | Some (c, _) -> Some c @@ -1907,6 +2117,8 @@ module Make (P : Backend.S) = struct [%log.debug "Tree.kind %a" pp_path path]; match (t, Path.rdecons path) with | `Contents _, None -> Some `Contents + | `Contents_inlined_3 _, None -> Some `Contents_inlined__1 + (* TODO inlined *) | `Node _, None -> Some `Node | _, Some (dir, file) -> ( sub ~cache "kind.sub" t dir |> function @@ -1915,6 +2127,7 @@ module Make (P : Backend.S) = struct Node.findv ~cache "kind.findv" m file |> function | None -> None | Some (`Contents _) -> Some `Contents + | Some (`Contents_inlined_3 _) -> Some `Contents_inlined__1 | Some (`Node _) -> Some `Node)) let length t ?(cache = true) path = @@ -1927,19 +2140,22 @@ module Make (P : Backend.S) = struct [%log.debug "Tree.seq %a" pp_path path]; sub ~cache "seq.sub" t path |> function | None -> Seq.empty - | Some n -> Node.seq ?offset ?length ~cache n |> get_ok "seq" + | Some n -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + Node.seq ?offset ?length ~cache n |> get_ok "seq" let list t ?offset ?length ?(cache = true) path = seq t ?offset ?length ~cache path |> List.of_seq - let empty () = `Node (Node.empty ()) + let empty () = `Node (Node.empty (), []) let singleton k ?(metadata = Metadata.default) c = [%log.debug "Tree.singleton %a" pp_path k]; let env = Env.empty () in let base_tree = `Contents (Contents.of_value ~env c, metadata) in Path.fold_right k - ~f:(fun step child -> `Node (Node.singleton ~env step child)) + ~f:(fun step child -> `Node (Node.singleton ~env step child, [])) ~init:base_tree (** During recursive updates, we keep track of whether or not we've made a @@ -1951,14 +2167,16 @@ module Make (P : Backend.S) = struct if x == y then True else match (x, y) with - | `Node x, `Node y -> Node.maybe_equal x y + | `Node (x, _il), `Node (y, _il') -> Node.maybe_equal x y | _ -> if equal x y then True else False let get_env = function - | `Node n -> n.Node.info.env + | `Node (n, _il) -> n.Node.info.env | `Contents (c, _) -> c.Contents.info.env + | `Contents_inlined_3 (c, _) -> c.Contents.info.env - let update_tree ~cache ~f_might_return_empty_node ~f root_tree path = + let update_tree ~cache ~f_might_return_empty_node ~(f : t option -> t option) + root_tree path = (* User-introduced empty nodes will be removed immediately if necessary. *) let prune_empty : node -> bool = if not f_might_return_empty_node then Fun.const false @@ -1969,7 +2187,7 @@ module Make (P : Backend.S) = struct let empty_tree = match is_empty root_tree with | true -> root_tree - | false -> `Node (Node.empty ()) + | false -> `Node (Node.empty (), []) in match f (Some root_tree) with (* Here we consider "deleting" a root contents value or node to consist @@ -1984,13 +2202,20 @@ module Make (P : Backend.S) = struct | Some (`Contents c' as new_root) -> ( match root_tree with | `Contents c when contents_equal c c' -> root_tree + | _ -> new_root) + | Some (`Contents_inlined_3 c' as new_root) -> ( + match root_tree with + | `Contents_inlined_3 c when contents_equal c c' -> root_tree | _ -> new_root)) | Some (path, file) -> ( + Fmt.pr "HERE %a %a@." (Repr.pp path_t) path (Repr.pp step_t) file; let rec aux : type r. path -> node -> (node updated, r) cont = fun path parent_node k -> let changed n = k (Changed n) in match Path.decons path with | None -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; let with_new_child t = Node.add parent_node file t |> changed in let old_binding = Node.findv ~cache "update_tree.findv" parent_node file @@ -1999,12 +2224,13 @@ module Make (P : Backend.S) = struct match (old_binding, new_binding) with | None, None -> k Unchanged | None, Some (`Contents _ as t) -> with_new_child t - | None, Some (`Node n as t) -> ( + | None, Some (`Contents_inlined_3 _ as t) -> with_new_child t + | None, Some (`Node (n, _il) as t) -> ( match prune_empty n with | true -> k Unchanged | false -> with_new_child t) | Some _, None -> Node.remove parent_node file |> changed - | Some old_value, Some (`Node n as t) -> ( + | Some old_value, Some (`Node (n, _il) as t) -> ( match prune_empty n with | true -> Node.remove parent_node file |> changed | false -> ( @@ -2015,15 +2241,39 @@ module Make (P : Backend.S) = struct match contents_equal c c' with | true -> k Unchanged | false -> with_new_child t) - | Some (`Node _), Some (`Contents _ as t) -> with_new_child t) + | Some (`Contents_inlined_3 c), Some (`Contents c' as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Contents c'), Some (`Contents_inlined_3 c as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Contents_inlined_3 c'), Some (`Contents_inlined_3 c as t) + -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Node _), Some (`Contents _ as t) -> with_new_child t + | Some (`Node _), Some (`Contents_inlined_3 _ as t) -> + with_new_child t + (* | Some (`Contents_inlined_3 c), Some (`Contents_inlined_3 c') -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t + | ) *) + (* | Some (`Contents_inlined_3 _), _ -> assert false + | _, Some (`Contents_inlined_3 _) -> assert false) *) + ) | Some (step, key_suffix) -> let old_binding = Node.findv ~cache "update_tree.findv" parent_node step in let to_recurse = match old_binding with - | Some (`Node child) -> child - | None | Some (`Contents _) -> Node.empty () + | Some (`Node (child, _il)) -> child + | None | Some (`Contents _) | Some (`Contents_inlined_3 _) -> + Node.empty () in (aux [@tailcall]) key_suffix to_recurse (function | Unchanged -> @@ -2037,16 +2287,23 @@ module Make (P : Backend.S) = struct binding [h], so we remove the binding. *) Node.remove parent_node step |> changed | false -> - Node.add parent_node step (`Node child) |> changed)) + Fmt.pr + "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + Node.add parent_node step (`Node (child, [])) |> changed + )) in let top_node = - match root_tree with `Node n -> n | `Contents _ -> Node.empty () + match root_tree with + | `Node (n, _il) -> n + | `Contents _ -> Node.empty () + | `Contents_inlined_3 _ -> Node.empty () in aux path top_node @@ function | Unchanged -> root_tree | Changed node -> Env.copy ~into:node.info.env (get_env root_tree); - `Node node) + `Node (node, [])) let update t k ?(metadata = Metadata.default) f = let cache = true in @@ -2058,13 +2315,53 @@ module Make (P : Backend.S) = struct | Some (`Contents (c, _)) -> let c = Contents.to_value ~cache c in Some (get_ok "update" c) + | Some (`Contents_inlined_3 (c, _)) -> + let c = Contents.to_value ~cache c in + Some (get_ok "update" c) in match f old_contents with | None -> None | Some c -> of_contents ~metadata c |> Option.some) + let rec inline_tree (t : t) = + match t with + | `Node ({ v; _ }, _il) -> ( + match Atomic.get v with + | Map map -> + Fmt.pr "@[Map@,"; + StepMap.iter (fun _ t -> inline_tree t) map; + let p1, p2 = + StepMap.partition + (fun _ -> function `Contents_inlined_3 _ -> true | _ -> false) + map + in + let print = + StepMap.iter (fun step -> function + | `Node _ -> Fmt.pr "Node / step: %a@," (Repr.pp step_t) step + | `Contents _ -> + Fmt.pr "Contents / step: %a@," (Repr.pp step_t) step + | `Contents_inlined_3 _ -> + Fmt.pr "Contents_inlined / step: %a@," (Repr.pp step_t) step) + in + Fmt.pr "TO INLINE:@,"; + print p1; + Fmt.pr "NOT TO INLINE:@,"; + print p2; + Fmt.pr "@]@," + | Key _ -> Fmt.pr "Key@," + | Value _ -> Fmt.pr "Value@," + | Portable_dirty _ -> Fmt.pr "Portable_dirty@," + | Pruned _ -> Fmt.pr "Pruned@,") + | `Contents _ -> () + | `Contents_inlined_3 _ -> () + (* [ `Node of node + | `Contents of Contents.t * Metadata.t + | `Contents_inlined_3 of Contents.t * metadata ] *) + let add t k ?(metadata = Metadata.default) c = [%log.debug "Tree.add %a" pp_path k]; + ignore @@ inline_tree t; + (* update_tree ~cache:true (inline_tree t) k *) update_tree ~cache:true t k ~f:(fun _ -> Some (of_contents ~metadata c)) ~f_might_return_empty_node:false @@ -2093,16 +2390,18 @@ module Make (P : Backend.S) = struct let env = Env.empty () in Some (`Contents (Contents.of_key ~env repo k, m)) | false -> None) - | `Node k -> ( + | `Node (k, _il) -> ( Atomic.incr cnt.node_mem; P.Node.mem (P.Repo.node_t repo) k |> function | true -> let env = Env.empty () in - Some (`Node (Node.of_key ~env repo k)) + (* TODO inline *) + Some (`Node (Node.of_key ~env repo k, [])) | false -> None) let import_with_env ~env repo = function - | `Node k -> `Node (Node.of_key ~env repo k) + | `Node (k, il) -> + `Node (Node.of_key ~env repo k, List.map (Contents.of_key ~env repo) il) | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) let import_no_check repo f = @@ -2118,6 +2417,7 @@ module Make (P : Backend.S) = struct any un-persisted child values. *) let export ?clear repo contents_t node_t n = [%log.debug "Tree.export clear=%a" Fmt.(option bool) clear]; + let n = (n, []) in let cache = match clear with | Some true | None -> @@ -2128,7 +2428,7 @@ module Make (P : Backend.S) = struct | Some false -> true in - let add_node n v k = + let add_node n v _to_inline k = Atomic.incr cnt.node_add; let key = P.Node.add node_t v in let () = @@ -2152,46 +2452,57 @@ module Make (P : Backend.S) = struct k key in - let add_node_map n (x : Node.map) k = - let node = + let add_node_map n (x : Node.map) to_inline k = + let node_seq = (* Since we traverse in post-order, all children of [x] have already been added. Thus, their keys are cached and we can retrieve them. *) Atomic.incr cnt.node_val_v; StepMap.to_seq x - |> Seq.map (fun (step, v) -> + |> Seq.filter_map (fun (step, v) -> match v with - | `Node n -> ( + | `Node (n, _il) -> ( match Node.cached_key n with - | Some k -> (step, `Node k) + | Some k -> Some (step, `Node (k, [])) | None -> assertion_failure "Encountered child node value with uncached key \ during export:@,\ @ @[%a@]" dump v) + | `Contents_inlined_3 (_c, _m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; + None | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." + __FILE__ __FUNCTION__ __LINE__; match Contents.cached_key c with - | Some k -> (step, `Contents (k, m)) + | Some k -> Some (step, `Contents (k, m)) | None -> assertion_failure - "Encountered child contents value with uncached key \ + "Encountered child contents value 2 with uncached key \ during export:@,\ @ @[%a@]" dump v)) - |> P.Node.Val.of_seq in - add_node n node k + let _, to_inline = List.split to_inline in + Fmt.pr "1 LIST TO_INLINE: %d@." (List.length to_inline); + let node = P.Node.Val.of_seq node_seq to_inline in + let r = add_node n node to_inline k in + (* assert false; *) + r in - let add_updated_node n (v : Node.value) (updates : Node.updatemap) k = - let node = + let add_updated_node n (v : Node.value) (updates : Node.updatemap) to_inline + k = + let node_seq = StepMap.fold (fun k v acc -> match v with | Node.Remove -> P.Node.Val.remove acc k - | Node.Add (`Node n as v) -> ( + | Node.Add (`Node (n, _il) as v) -> ( match Node.cached_key n with - | Some ptr -> P.Node.Val.add acc k (`Node ptr) + | Some ptr -> P.Node.Val.add acc k (`Node (ptr, [])) | None -> assertion_failure "Encountered child node value with uncached key during \ @@ -2203,17 +2514,27 @@ module Make (P : Backend.S) = struct | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) | None -> assertion_failure - "Encountered child contents value with uncached key \ + "Encountered child contents value 3 with uncached key \ + during export:@,\ + @ @[%a@]" + dump v) + | Add (`Contents_inlined_3 (c, m) as v) -> ( + match Contents.cached_key c with + | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) + | None -> + assertion_failure + "Encountered child contents value 4 with uncached key \ during export:@,\ @ @[%a@]" dump v)) updates v in - add_node n node k + add_node n node_seq to_inline k in - let rec on_node : type r. [ `Node of node ] -> (node_key, r) cont = - fun (`Node n) k -> + let rec on_node : type r. + [ `Node of node * Contents.t list ] -> (node_key, r) cont = + fun (`Node (n, _il)) k -> let k key = (* All the nodes in the exported tree should be cleaned using [Node.export]. This ensures that [key] is stored in [n]. *) @@ -2319,11 +2640,19 @@ module Make (P : Backend.S) = struct in Seq.map (fun (_, x) -> x) seq in - on_node_seq new_children_seq @@ fun `Node_children_exported -> + on_node_seq new_children_seq [] + @@ fun (`Node_children_exported to_inline) -> + Fmt.pr "I EXPORTED MY CHILDREN@."; match (Atomic.get n.Node.v, Node.cached_value n) with - | Map x, _ -> add_node_map n x k - | Value (_, v, None), None | _, Some v -> add_node n v k - | Value (_, v, Some um), _ -> add_updated_node n v um k + | Map x, _ -> + Fmt.pr "NOW TURN OF MAP@."; + add_node_map n x to_inline k + | Value (_, v, None), None | _, Some v -> + Fmt.pr "NOW TURN OF VALUE@."; + add_node n v to_inline k + | Value (_, v, Some um), _ -> + Fmt.pr "NOW TURN OF VALUE UPDATED NODE@."; + add_updated_node n v um to_inline k | (Key _ | Portable_dirty _ | Pruned _), _ -> (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is excluded above. *) @@ -2355,19 +2684,61 @@ module Make (P : Backend.S) = struct Contents.export ?clear repo c key; k `Content_exported | Contents.Pruned h -> pruned_hash_exn "export" h + and on_contents_inlined : type r. + [ `Contents_inlined_3 of Contents.t * metadata ] -> + ( [ `Content_exported | `Content_to_inline of Contents.t * contents_key ], + r ) + cont = + fun (`Contents_inlined_3 (c, _)) k -> + match Atomic.get c.Contents.v with + | Contents.Key (_, key) -> + Contents.clear c; + (* TODO inlined *) + k (`Content_to_inline (c, key)) + | Contents.Value _ -> + let v = Contents.to_value ~cache c in + let v = get_ok "export" v in + Atomic.incr cnt.contents_add; + let key = P.Contents.add contents_t v in + let () = + let h = P.Contents.Key.to_hash key in + let h' = Contents.hash ~cache c in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent contents binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" + pp_contents_key key pp_contents v pp_hash h' + in + Contents.clear c; + k (`Content_to_inline (c, key)) + | Contents.Pruned h -> pruned_hash_exn "export" h and on_node_seq : type r. - Node.elt Seq.t -> ([ `Node_children_exported ], r) cont = - fun seq k -> + Node.elt Seq.t -> + (Contents.t * contents_key) List.t -> + ( [ `Node_children_exported of (Contents.t * contents_key) list ], + r ) + cont = + fun seq to_inline k -> match seq () with | Seq.Nil -> (* Have iterated on all children, let's export parent now *) - k `Node_children_exported + k (`Node_children_exported to_inline) | Seq.Cons ((`Node _ as n), rest) -> - on_node n (fun _node_key -> on_node_seq rest k) + on_node n (fun _node_key -> on_node_seq rest to_inline k) | Seq.Cons ((`Contents _ as c), rest) -> - on_contents c (fun `Content_exported -> on_node_seq rest k) + on_contents c (fun `Content_exported -> on_node_seq rest to_inline k) + | Seq.Cons ((`Contents_inlined_3 _ as c), rest) -> + Fmt.pr "EXPORTING INLINED CONTENTS@."; + on_contents_inlined c (function + | `Content_exported -> on_node_seq rest to_inline k + | `Content_to_inline c -> on_node_seq rest (c :: to_inline) k) in - on_node (`Node n) (fun key -> key) + let r = on_node (`Node n) (fun key -> key) in + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + r let merge : t Merge.t = let f ~old (x : t) y = @@ -2387,8 +2758,9 @@ module Make (P : Backend.S) = struct (fun (acc, todo) (k, v) -> let path = Path.rcons path k in match v with - | `Node v -> (acc, (path, v) :: todo) - | `Contents c -> ((path, c) :: acc, todo)) + | `Node (v, _il) -> (acc, (path, v) :: todo) + | `Contents c -> ((path, c) :: acc, todo) + | `Contents_inlined_3 c -> ((path, c) :: acc, todo)) (acc, todo) childs in (aux [@tailcall]) acc todo @@ -2442,7 +2814,10 @@ module Make (P : Backend.S) = struct | `Left (`Contents x) -> let x = removed !acc (path, x) in acc := x - | `Left (`Node x) -> + | `Left (`Contents_inlined_3 x) -> + let x = removed !acc (path, x) in + acc := x + | `Left (`Node (x, _il)) -> let xs = entries path x in let xs = List.fold_left removed !acc xs in acc := xs @@ -2450,23 +2825,36 @@ module Make (P : Backend.S) = struct | `Right (`Contents y) -> let y = added !acc (path, y) in acc := y - | `Right (`Node y) -> + | `Right (`Contents_inlined_3 y) -> + let y = added !acc (path, y) in + acc := y + | `Right (`Node (y, _il)) -> let ys = entries path y in let ys = List.fold_left added !acc ys in acc := ys (* Both *) - | `Both (`Node x, `Node y) -> todo := (path, x, y) :: !todo - | `Both (`Contents x, `Node y) -> + | `Both (`Node (x, _il), `Node (y, _il')) -> + todo := (path, x, y) :: !todo + | `Both (`Contents x, `Node (y, _il)) + | `Both (`Contents_inlined_3 x, `Node (y, _il)) -> let ys = entries path y in let x = removed !acc (path, x) in let ys = List.fold_left added x ys in acc := ys - | `Both (`Node x, `Contents y) -> + | `Both (`Node (x, _il), `Contents y) + | `Both (`Node (x, _il), `Contents_inlined_3 y) -> let xs = entries path x in let y = added !acc (path, y) in let ys = List.fold_left removed y xs in acc := ys | `Both (`Contents x, `Contents y) -> + let content_diffs = + diff_contents x y |> List.map (fun d -> (path, d)) + in + acc := content_diffs @ !acc + | `Both (`Contents x, `Contents_inlined_3 y) + | `Both (`Contents_inlined_3 x, `Contents y) + | `Both (`Contents_inlined_3 x, `Contents_inlined_3 y) -> let content_diffs = diff_contents x y |> List.map (fun d -> (path, d)) in @@ -2495,15 +2883,17 @@ module Make (P : Backend.S) = struct let c1 = Contents.to_value ~cache:true c1 |> get_ok "diff" in let c2 = Contents.to_value ~cache:true c2 |> get_ok "diff" in [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] - | `Node x, `Node y -> diff_node x y - | `Contents (x, m), `Node y -> + | `Node (x, _il), `Node (y, _il') -> diff_node x y + | `Contents (x, m), `Node (y, _il) -> let diff = diff_node (Node.empty ()) y in let x = Contents.to_value ~cache:true x |> get_ok "diff" in (Path.empty, `Removed (x, m)) :: diff - | `Node x, `Contents (y, m) -> + | `Node (x, _il), `Contents (y, m) -> let diff = diff_node x (Node.empty ()) in let y = Contents.to_value ~cache:true y |> get_ok "diff" in (Path.empty, `Added (y, m)) :: diff + (* TODO inlined *) + | _ -> assert false type concrete = [ `Tree of (Path.step * concrete) list @@ -2516,11 +2906,14 @@ module Make (P : Backend.S) = struct let rec concrete : type r. concrete -> (t or_empty, r) cont = fun t k -> match t with - | `Contents (c, m) -> k (Non_empty (of_contents ~metadata:m c)) + | `Contents (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + k (Non_empty (of_contents ~metadata:m c)) | `Tree childs -> tree StepMap.empty childs (function | Empty -> k Empty - | Non_empty n -> k (Non_empty (`Node n))) + | Non_empty n -> k (Non_empty (`Node (n, [])))) and tree : type r. Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont = @@ -2553,7 +2946,8 @@ module Make (P : Backend.S) = struct fun t k -> match t with | `Contents c -> contents c k - | `Node n -> + | `Contents_inlined_3 c -> contents c k + | `Node (n, _il) -> let m = Node.to_map ~cache:true n in let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in (node [@tailcall]) [] bindings (fun n -> @@ -2575,6 +2969,9 @@ module Make (P : Backend.S) = struct | `Node _ as n -> (tree [@tailcall]) n (fun tree -> node ((s, tree) :: childs) t k) | `Contents c -> + (contents [@tailcall]) c (fun c -> + (node [@tailcall]) ((s, c) :: childs) t k) + | `Contents_inlined_3 c -> (contents [@tailcall]) c (fun c -> (node [@tailcall]) ((s, c) :: childs) t k)) in @@ -2583,9 +2980,19 @@ module Make (P : Backend.S) = struct let key (t : t) = [%log.debug "Tree.key"]; match t with - | `Node n -> ( - match Node.key n with Some key -> Some (`Node key) | None -> None) + | `Node (n, _il) -> ( + match Node.key n with + | Some key -> Some (`Node (key, [])) + | None -> None) | `Contents (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + match Contents.key c with + | Some key -> Some (`Contents (key, m)) + | None -> None) + | `Contents_inlined_3 (c, m) -> ( + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; match Contents.key c with | Some key -> Some (`Contents (key, m)) | None -> None) @@ -2593,8 +3000,16 @@ module Make (P : Backend.S) = struct let hash ?(cache = true) (t : t) = [%log.debug "Tree.hash"]; match t with - | `Node n -> `Node (Node.hash ~cache n) - | `Contents (c, m) -> `Contents (Contents.hash ~cache c, m) + | `Node (n, il) -> + `Node (Node.hash ~cache n, List.map (Contents.hash ~cache) il) + | `Contents (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + `Contents (Contents.hash ~cache c, m) + | `Contents_inlined_3 (c, m) -> + Fmt.pr "\x1b[31;1m%s\x1b[0;m: \x1b[32;1m%s\x1b[0;m: %d@." __FILE__ + __FUNCTION__ __LINE__; + `Contents (Contents.hash ~cache c, m) let stats ?(force = false) (t : t) = let cache = true in @@ -2610,7 +3025,8 @@ module Make (P : Backend.S) = struct let inspect = function | `Contents _ -> `Contents - | `Node n -> + | `Contents_inlined_3 _ -> `Contents_inlined__2 + | `Node (n, _il) -> `Node (match Atomic.get n.Node.v with | Map _ -> `Map @@ -2637,8 +3053,9 @@ module Make (P : Backend.S) = struct let rec proof_of_tree : type a. irmin_tree -> (proof_tree -> a) -> a = fun tree k -> match tree with + | `Contents_inlined_3 (c, h) -> proof_of_contents c h k | `Contents (c, h) -> proof_of_contents c h k - | `Node node -> proof_of_node node k + | `Node (node, _il) -> proof_of_node node k and proof_of_contents : type a. Contents.t -> metadata -> (proof_tree -> a) -> a = @@ -2748,7 +3165,7 @@ module Make (P : Backend.S) = struct = fun ~env p k -> match p with - | Blinded_node h -> k (`Node h) + | Blinded_node h -> k (`Node (h, [])) | Node n -> load_node_proof ~env n k | Inode { length; proofs } -> load_inode_proof ~env length proofs k | Blinded_contents (h, m) -> k (`Contents (h, m)) @@ -2773,7 +3190,7 @@ module Make (P : Backend.S) = struct in let h = P.Node_portable.hash_exn v in Env.add_pnode_from_proof env h v; - k (`Node h)) + k (`Node (h, []))) and proof_of_extender len segments p : node_proof = List.fold_left @@ -2788,7 +3205,7 @@ module Make (P : Backend.S) = struct | [] -> let h = P.Node_portable.hash_exn acc in Env.add_pnode_from_proof env h acc; - k (`Node h) + k (`Node (h, [])) | (s, p) :: rest -> let k h = aux (P.Node_portable.add acc s h) rest in load_proof ~env p k @@ -2812,7 +3229,7 @@ module Make (P : Backend.S) = struct in let h = P.Node_portable.hash_exn v in Env.add_pnode_from_proof env h v; - k (`Node h) + k (`Node (h, [])) | (i, p) :: rest -> let k p = aux ((i, p) :: acc) rest in node_proof_of_proof ~env p k diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index 6e2e730177..6b191f3092 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -55,13 +55,16 @@ module type S = sig val of_node : node -> t (** [of_node n] is the subtree built from the node [n]. *) - type elt = [ `Node of node | `Contents of contents * metadata ] + type elt = + [ `Node of node * contents list + | `Contents of contents * metadata + | `Contents_inlined_3 of contents * metadata ] (** The type for tree elements. *) val v : elt -> t (** General-purpose constructor for trees. *) - type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + type kinded_hash = [ `Contents of hash * metadata | `Node of hash * hash list ] [@@deriving irmin] val pruned : kinded_hash -> t @@ -74,7 +77,7 @@ module type S = sig {!Pruned_hash} exception. Attempting to export a tree containing pruned sub-trees to a repository will fail similarly. *) - val kind : t -> path -> [ `Contents | `Node ] option + val kind : t -> path -> [ `Contents | `Contents_inlined__1 | `Node ] option (** [kind t k] is the type of [s] in [t]. It could either be a tree node or some file contents. It is [None] if [k] is not present in [t]. *) @@ -106,6 +109,16 @@ module type S = sig type 'a or_error = ('a, error) result + module Private : sig + module Env : sig + type t [@@deriving irmin] + + val is_empty : t -> bool + end + + val get_env : t -> Env.t + end + (** Operations on lazy tree contents. *) module Contents : sig type t @@ -131,6 +144,8 @@ module type S = sig val clear : t -> unit (** [clear t] clears [t]'s cache. *) + val of_value : contents -> env:Private.Env.t -> t + (** {2:caching caching} [cache] regulates the caching behaviour regarding the node's internal @@ -233,7 +248,11 @@ module type S = sig (** {1 Folds} *) - val destruct : t -> [ `Node of node | `Contents of Contents.t * metadata ] + val destruct : + t -> + [ `Node of node * Contents.t list + | `Contents of Contents.t * metadata + | `Contents_inlined_3 of Contents.t * metadata ] (** General-purpose destructor for trees. *) type marks @@ -398,7 +417,9 @@ module type S = sig val inspect : t -> - [ `Contents | `Node of [ `Map | `Key | `Value | `Portable_dirty | `Pruned ] ] + [ `Contents + | `Contents_inlined__2 + | `Node of [ `Map | `Key | `Value | `Portable_dirty | `Pruned ] ] (** [inspect t] is similar to {!kind}, with additional state information for nodes. It is primarily useful for debugging and testing. @@ -411,16 +432,6 @@ module type S = sig {!Node.Portable}. Currently only used with {!Proof}. - [`Pruned], if [t] is from {!pruned}. - Otherwise [`Key], the default state for a node loaded from a store. *) - - module Private : sig - module Env : sig - type t [@@deriving irmin] - - val is_empty : t -> bool - end - - val get_env : t -> Env.t - end end module type Sigs = sig @@ -440,7 +451,8 @@ module type Sigs = sig and type hash = B.Hash.t type kinded_key = - [ `Contents of B.Contents.Key.t * metadata | `Node of B.Node.Key.t ] + [ `Contents of B.Contents.Key.t * metadata + | `Node of B.Node.Key.t * B.Contents.Key.t list ] [@@deriving irmin] val import : B.Repo.t -> kinded_key -> t option