improve perf for Sync.export

src/irmin/irmin.mli

@@ -315,6 +315,9 @@ module Type: sig
   val compare: 'a t -> 'a -> 'a -> int
   (** [compare t] compares values of type [t]. *)
 
+  val hash: 'a t -> 'a -> int
+  (** [hash t x] is a short hash of [x] of type [t]. *)
+
   type 'a pp = 'a Fmt.t
   (** The type for pretty-printers for CLI arguments. *)
 
@@ -461,6 +464,7 @@ module Type: sig
     ?bin:('b encode_bin * 'b decode_bin * 'b size_of) ->
     ?equal:('b -> 'b -> bool) ->
     ?compare:('b -> 'b -> int) ->
+    ?hash:('b -> int) ->
      ('a -> 'b) -> ('b -> 'a) -> 'b t
 
   val like':
@@ -469,6 +473,7 @@ module Type: sig
     ?bin:('a encode_bin * 'a decode_bin * 'a size_of) ->
     ?equal:('a -> 'a -> bool) ->
     ?compare:('a -> 'a -> int) ->
+    ?hash:('a -> int) ->
     'a t -> 'a t
 
   type 'a ty = 'a t

src/irmin/object_graph.ml

@@ -87,7 +87,14 @@ module Make
 
     let equal = Type.equal t
     let compare = Type.compare t
-    let hash x = Hashtbl.hash (Type.to_string t x)
+
+    (* we are using cryptographic hashes here, so the first bytes
+       are good enough to be used as short hashes. *)
+    let hash (t:t): int = match t with
+      | `Contents (c, _) -> Type.hash Contents.t c
+      | `Node n          -> Type.hash Node.t n
+      | `Commit c        -> Type.hash Commit.t c
+      | `Branch b        -> Type.hash Branch.t b
   end
 
   module G = Graph.Imperative.Digraph.ConcreteBidirectional(X)
@@ -125,8 +132,9 @@ module Make
     let todo = Queue.create () in
     List.iter (fun k -> Queue.push (k,0) todo) max;
     let rec add () =
-      try
-        let (key, level) = Queue.pop todo in
+      match Queue.pop todo with
+      | exception Queue.Empty -> return_unit
+      | (key, level) ->
         if level >= depth then add ()
         else if has_mark key then add ()
         else (
@@ -138,7 +146,6 @@ module Make
           List.iter (fun k -> Queue.push (k, level+1) todo) keys;
           add ()
         )
-      with Queue.Empty -> return_unit
     in
     add () >>= fun () ->
     Lwt.return g

src/irmin/type.ml

@@ -78,6 +78,7 @@ type 'a decode_bin = string -> int -> int * 'a
 type 'a size_of = 'a -> [ `Size of int | `Buffer of string ]
 type 'a compare = 'a -> 'a -> int
 type 'a equal = 'a -> 'a -> bool
+type 'a hash = 'a -> int
 
 type 'a t =
   | Self   : 'a self -> 'a t
@@ -103,6 +104,7 @@ and ('a, 'b) like = {
   decode_json : 'b decode_json option;
   encode_bin  : 'b encode_bin option;
   decode_bin  : 'b decode_bin option;
+  hash        : 'b hash option;
   size_of     : 'b size_of option;
   compare     : 'b compare option;
   equal       : 'b equal option;
@@ -251,7 +253,7 @@ let split3 = function
   | Some (x, y, z) -> Some x, Some y, Some z
   | None           -> None  , None  , None
 
-let like (type a b) (x: a t) ?cli ?json ?bin ?equal ?compare
+let like (type a b) (x: a t) ?cli ?json ?bin ?equal ?compare ?hash
     (f: a -> b) (g: b -> a) =
   let pp, of_string = split2 cli in
   let encode_json, decode_json = split2 json in
@@ -260,10 +262,10 @@ let like (type a b) (x: a t) ?cli ?json ?bin ?equal ?compare
          pp; of_string;
          encode_json; decode_json;
          encode_bin; decode_bin; size_of;
-         compare; equal }
+         compare; equal; hash }
 
-let like' ?cli ?json ?bin ?equal ?compare t =
-  like ?cli ?json ?bin ?equal ?compare t (fun x -> x) (fun x -> x)
+let like' ?cli ?json ?bin ?equal ?compare ?hash t =
+  like ?cli ?json ?bin ?equal ?compare ?hash t (fun x -> x) (fun x -> x)
 
 (* fix points *)
 
@@ -1393,6 +1395,10 @@ let of_string t =
 
 type 'a ty = 'a t
 
+let hash t x = match t with
+  | Like { hash = Some h; _ } -> h x
+  | _ -> Hashtbl.hash (encode_bin t x)
+
 module type S = sig
   type t
   val t: t ty

src/irmin/type.mli

@@ -69,7 +69,7 @@ val mu2: ('a t -> 'b t -> 'a t * 'b t) -> 'a t * 'b t
 
 val equal: 'a t -> 'a -> 'a -> bool
 val compare: 'a t -> 'a -> 'a -> int
-
+val hash: 'a t -> 'a -> int
 
 (* CLI *)
 
@@ -108,6 +108,7 @@ val like: 'a t ->
   ?bin:('b encode_bin * 'b decode_bin * 'b size_of) ->
   ?equal:('b -> 'b -> bool) ->
   ?compare:('b -> 'b -> int) ->
+  ?hash:('b -> int) ->
   ('a -> 'b) -> ('b -> 'a) -> 'b t
 
 val like':
@@ -116,6 +117,7 @@ val like':
   ?bin:('a encode_bin * 'a decode_bin * 'a size_of) ->
   ?equal:('a -> 'a -> bool) ->
   ?compare:('a -> 'a -> int) ->
+  ?hash:('a -> int) ->
   'a t -> 'a t
 
 (* convenient functions. *)