New version of ocaml-git

.ocamlformat

@@ -1,7 +1,7 @@
+version=0.15.0
 module-item-spacing=compact
 break-struct=natural
 break-infix=fit-or-vertical
 parens-tuple=multi-line-only
 wrap-comments=false
 break-collection-expressions=wrap
-version=0.14.2

.travis.yml

@@ -3,12 +3,11 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.t
 script: bash -ex .travis-opam.sh
 env:
   global:
-    - PINS="git.dev:. git-http.dev:. git-unix.dev:. git-mirage.dev:."
+    - PINS="carton.dev:. carton-lwt.dev:. carton-git.dev:. nss.dev:. git.dev:. git-unix.dev:. git-mirage.dev:."
   matrix:
-    - OCAML_VERSION=4.07 PACKAGE="git.dev"
     - OCAML_VERSION=4.08 PACKAGE="git.dev"
     - OCAML_VERSION=4.09 PACKAGE="git.dev"
-    - OCAML_VERSION=4.07 PACKAGE="git-unix.dev"
-    - OCAML_VERSION=4.07 PACKAGE="git-unix.dev"
-    - OCAML_VERSION=4.07 PACKAGE="git-mirage.dev"
-    - OCAML_VERSION=4.07 PACKAGE="git.dev" REVDEPS=*
+    - OCAML_VERSION=4.10 PACKAGE="git.dev"
+    - OCAML_VERSION=4.08 PACKAGE="git-unix.dev"
+    - OCAML_VERSION=4.08 PACKAGE="git-unix.dev"
+    - OCAML_VERSION=4.08 PACKAGE="git.dev" REVDEPS=*

appveyor.yml

@@ -6,10 +6,10 @@ environment:
     FORK_USER: ocaml
     FORK_BRANCH: master
     CYG_ROOT: C:\cygwin64
-    OPAM_SWITCH: 4.07.0+mingw64c
-    PINS: "git.dev:. git-http.dev:. git-unix.dev:. git-mirage.dev:."
+    OPAM_SWITCH: 4.08.1+mingw64c
+    PINS: "carton.dev:. carton-lwt.dev:. carton-git.dev:. nss.dev:. git.dev:. git-unix.dev:. git-mirage.dev:."
   matrix:
-  - PACKAGE: "git-mirage.dev"
+  - PACKAGE: "git.dev"
   - PACKAGE: "git-unix.dev"
 
 install:

bench/bench_pack.ml

@@ -0,0 +1,96 @@
+module Unix_scheduler = Carton.Make (struct type 'a t = 'a end)
+open Unix_scheduler
+
+let bomb_pack = "../test/carton/bomb.pack"
+let bomb_idx = "../test/carton/bomb.idx"
+
+let scheduler =
+  { Carton.bind = (fun x f -> f (prj x)); Carton.return = (fun x -> inj x) }
+
+let map fd ~pos len =
+  let { Unix.LargeFile.st_size; _ } = Unix.LargeFile.fstat fd in
+  let len =
+    if Int64.of_int len <= Int64.sub st_size pos then len
+    else Int64.(to_int (sub st_size pos))
+  in
+  let res =
+    Unix.map_file fd ~pos Bigarray.char Bigarray.c_layout false [| len |]
+  in
+  let res = Bigarray.array1_of_genarray res in
+  inj res
+
+let fd = Unix.openfile bomb_pack Unix.[ O_RDONLY ] 0o644
+let () = at_exit (fun () -> Unix.close fd)
+
+let index =
+  let tbl = Hashtbl.create 0x100 in
+
+  let fd = Unix.openfile bomb_idx Unix.[ O_RDONLY ] 0o644 in
+  let st = Unix.fstat fd in
+  let payload = prj (map fd ~pos:0L st.Unix.st_size) in
+  Unix.close fd;
+
+  let idx =
+    Carton.Dec.Idx.make payload ~uid_ln:Digestif.SHA1.digest_size
+      ~uid_rw:Digestif.SHA1.to_raw_string ~uid_wr:Digestif.SHA1.of_raw_string
+  in
+  let f ~uid ~offset ~crc:_ = Hashtbl.add tbl uid offset in
+  Carton.Dec.Idx.iter ~f idx;
+  tbl
+
+let z = De.bigstring_create De.io_buffer_size
+let w = De.make_window ~bits:15
+let allocate _ = w
+
+let pack =
+  Carton.Dec.make fd ~z ~allocate ~uid_ln:Digestif.SHA1.digest_size
+    ~uid_rw:Digestif.SHA1.of_raw_string (fun uid -> Hashtbl.find index uid)
+
+let ( >>= ) = scheduler.Carton.bind
+let return = scheduler.Carton.return
+let uid_0 = Digestif.SHA1.of_hex "7af99c9e7d4768fa681f4fe4ff61259794cf719b"
+let uid_1 = Digestif.SHA1.of_hex "d9513477b01825130c48c4bebed114c4b2d50401"
+
+let load uid =
+  Carton.Dec.weight_of_uid scheduler ~map pack ~weight:Carton.Dec.null uid
+  >>= fun weight ->
+  let raw = Carton.Dec.make_raw ~weight in
+  Carton.Dec.of_uid scheduler ~map pack raw uid >>= fun _ -> return ()
+
+let fn_map =
+  Benchmark.V (fun () -> ignore (prj (map fd ~pos:10L (1024 * 1024))))
+
+let fn_load_0 = Benchmark.V (fun () -> ignore (prj (load uid_0)))
+let fn_load_1 = Benchmark.V (fun () -> ignore (prj (load uid_1)))
+let s x = Mtime.Span.of_uint64_ns (Int64.mul (Int64.of_int x) 1_000_000_000L)
+
+let run fn_load title =
+  let (Benchmark.V fn) = fn_load in
+  let _ = fn () in
+  let samples_map = Benchmark.run (s 8) fn_map in
+  let samples_load = Benchmark.run (s 8) fn_load in
+
+  match
+    ( Linear_algebra.ols
+        (fun m -> m.(1))
+        [| (fun m -> m.(0)); (fun _ -> 1.) |]
+        samples_map,
+      Linear_algebra.ols
+        (fun m -> m.(1))
+        [| (fun m -> m.(0)); (fun _ -> 1.) |]
+        samples_load )
+  with
+  | Ok (estimate_map, r_map), Ok (estimate_load, r_load) ->
+      Fmt.pr "%15.2fns (r²: %f) [map syscall].\n%!" estimate_map.(0) r_map;
+      Fmt.pr "%15.2fns (r²: %f) [load %s].\n%!" estimate_load.(0) r_load title
+  | Error (`Msg err), _ | _, Error (`Msg err) ->
+      Fmt.epr "%s: %s.\n%!" Sys.argv.(0) err
+
+let () =
+  match Sys.argv with
+  | [| _; "0" |] -> run fn_load_0 "commit (0 delta)"
+  | [| _; "1" |] -> run fn_load_1 "tree (1 delta)"
+  | _ ->
+      Fmt.epr "%s [0|1].\n" Sys.argv.(0);
+      Fmt.epr "0    commit (0 delta).\n%!";
+      Fmt.epr "1    tree (1 delta).\n%!"

bench/benchmark.ml

@@ -0,0 +1,61 @@
+external tick : unit -> (int64[@unboxed]) = "none" "get_tick" [@@noalloc]
+external now : unit -> (int64[@unboxed]) = "none" "get_now" [@@noalloc]
+
+type t = V : (unit -> 'a) -> t
+
+let stabilize_garbage_collector () =
+  let rec go limit last_heap_live_words =
+    if limit <= 0 then
+      failwith "Unable to stabilize the number of live words in the heap";
+    Gc.compact ();
+    let stat = Gc.stat () in
+    if stat.Gc.live_words <> last_heap_live_words then
+      go (pred limit) stat.Gc.live_words
+  in
+  go 10 0
+
+let runnable f i =
+  for _ = 1 to i do
+    ignore @@ Sys.opaque_identity (f ())
+  done
+  [@@inline]
+
+let samples = 1000
+
+let exceeded_allowed_time allowed_time_span t =
+  let t' = Mtime.of_uint64_ns (now ()) in
+  Mtime.Span.compare (Mtime.span t t') allowed_time_span > 0
+
+let run quota t =
+  let idx = ref 0 in
+  let run = ref 0 in
+  let (V fn) = t in
+
+  let m = Array.create_float (samples * 2) in
+
+  stabilize_garbage_collector ();
+  let init_time = Mtime.of_uint64_ns (now ()) in
+
+  while (not (exceeded_allowed_time quota init_time)) && !idx < samples do
+    let current_run = !run in
+    let current_idx = !idx in
+
+    let time_0 = now () in
+
+    runnable fn current_run;
+
+    let time_1 = now () in
+
+    m.((current_idx * 2) + 0) <- float_of_int current_run;
+    m.((current_idx * 2) + 1) <- Int64.to_float (Int64.sub time_1 time_0);
+
+    let next =
+      (max : int -> int -> int)
+        (int_of_float (float_of_int current_run *. 1.01))
+        (succ current_run)
+    in
+    run := next;
+    incr idx
+  done;
+
+  Array.init samples (fun i -> [| m.((i * 2) + 0); m.((i * 2) + 1) |])

bench/dune

@@ -0,0 +1,19 @@
+(executable
+ (name bench_pack)
+ (libraries bigstringaf mtime fmt decompress.de decompress.zl digestif.c
+   bigarray-compat carton unix)
+ (foreign_stubs
+  (language c)
+  (names rdtsc)))
+
+(rule
+ (alias runbench)
+ (package carton)
+ (deps
+  (:bench bench_pack.exe)
+  ../test/carton/bomb.idx
+  ../test/carton/bomb.pack)
+ (action
+  (progn
+   (run %{bench} 0)
+   (run %{bench} 1))))

bench/linear_algebra.ml

@@ -0,0 +1,128 @@
+(* Code under Apache License 2.0 - Jane Street Group, LLC <opensource@janestreet.com> *)
+
+let col_norm a column =
+  let acc = ref 0. in
+  for i = 0 to Array.length a - 1 do
+    let entry = a.(i).(column) in
+    acc := !acc +. (entry *. entry)
+  done;
+  sqrt !acc
+
+let col_inner_prod t j1 j2 =
+  let acc = ref 0. in
+  for i = 0 to Array.length t - 1 do
+    acc := !acc +. (t.(i).(j1) *. t.(i).(j2))
+  done;
+  !acc
+
+let qr_in_place a =
+  let m = Array.length a in
+  if m = 0 then [||], [||]
+  else
+    let n = Array.length a.(0) in
+    let r = Array.make_matrix n n 0. in
+    for j = 0 to n - 1 do
+      let alpha = col_norm a j in
+      r.(j).(j) <- alpha;
+      let one_over_alpha = 1. /. alpha in
+      for i = 0 to m - 1 do
+        a.(i).(j) <- a.(i).(j) *. one_over_alpha
+      done;
+      for j2 = j + 1 to n - 1 do
+        let c = col_inner_prod a j j2 in
+        r.(j).(j2) <- c;
+        for i = 0 to m - 1 do
+          a.(i).(j2) <- a.(i).(j2) -. (c *. a.(i).(j))
+        done
+      done
+    done;
+    a, r
+
+let qr ?(in_place = false) a =
+  let a = if in_place then a else Array.map Array.copy a in
+  qr_in_place a
+
+let mul_mv ?(trans = false) a x =
+  let rows = Array.length a in
+  if rows = 0 then [||]
+  else
+    let cols = Array.length a.(0) in
+    let m, n, get =
+      if trans then
+        let get i j = a.(j).(i) in
+        cols, rows, get
+      else
+        let get i j = a.(i).(j) in
+        rows, cols, get
+    in
+    if n <> Array.length x then failwith "Dimension mismatch";
+    let result = Array.make m 0. in
+    for i = 0 to m - 1 do
+      let v, _ =
+        Array.fold_left
+          (fun (acc, j) x -> acc +. (get i j *. x), succ j)
+          (0., 0) x
+      in
+      result.(i) <- v
+    done;
+    result
+
+let is_nan v = match classify_float v with FP_nan -> true | _ -> false
+let error_msg msg = Error (`Msg msg)
+
+let triu_solve r b =
+  let m = Array.length b in
+  if m <> Array.length r then
+    error_msg
+      "triu_solve R b requires R to be square with same number of rows as b"
+  else if m = 0 then Ok [||]
+  else if m <> Array.length r.(0) then
+    error_msg "triu_solve R b requires R to be a square"
+  else
+    let sol = Array.copy b in
+    for i = m - 1 downto 0 do
+      sol.(i) <- sol.(i) /. r.(i).(i);
+      for j = 0 to i - 1 do
+        sol.(j) <- sol.(j) -. (r.(j).(i) *. sol.(i))
+      done
+    done;
+    if Array.exists is_nan sol then error_msg "triu_solve detected NaN result"
+    else Ok sol
+
+let ols ?(in_place = false) a b =
+  let q, r = qr ~in_place a in
+  triu_solve r (mul_mv ~trans:true q b)
+
+let make_lr_inputs responder predictors m =
+  ( Array.init (Array.length m) (fun i ->
+        Array.map (fun a -> a m.(i)) predictors),
+    Array.init (Array.length m) (fun i -> responder m.(i)) )
+
+let r_square m responder predictors r =
+  let predictors_matrix, responder_vector =
+    make_lr_inputs responder predictors m
+  in
+  let sum_responder = Array.fold_left ( +. ) 0. responder_vector in
+  let mean = sum_responder /. float (Array.length responder_vector) in
+  let tot_ss = ref 0. in
+  let res_ss = ref 0. in
+  let predicted i =
+    let x = ref 0. in
+    for j = 0 to Array.length r - 1 do
+      x := !x +. (predictors_matrix.(i).(j) *. r.(j))
+    done;
+    !x
+  in
+  for i = 0 to Array.length responder_vector - 1 do
+    tot_ss := !tot_ss +. ((responder_vector.(i) -. mean) ** 2.);
+    res_ss := !res_ss +. ((responder_vector.(i) -. predicted i) ** 2.)
+  done;
+  1. -. (!res_ss /. !tot_ss)
+
+let ols responder predictors m =
+  let matrix, vector = make_lr_inputs responder predictors m in
+  match ols ~in_place:true matrix vector with
+  | Ok estimates ->
+      let r_square = r_square m responder predictors estimates in
+      Ok (estimates, r_square)
+  | Error _ as err -> err

bench/rdtsc.c

@@ -0,0 +1,33 @@
+#include <stdint.h>
+#include <time.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+#ifndef __unused
+#define __unused(x) x __attribute((unused))
+#endif
+#define __unit() value __unused(unit)
+
+uint64_t
+get_now(__unit ())
+{
+  struct timespec ts;
+
+  clock_gettime(CLOCK_MONOTONIC, &ts);
+
+  return ((uint64_t) ts.tv_sec
+          * (uint64_t) 1000000000LL
+          + (uint64_t) ts.tv_nsec);
+}
+
+uint64_t
+get_tick(__unit ())
+{
+  unsigned hi, lo;
+  __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi));
+
+  return (((unsigned long long) lo) | (((unsigned long long) hi) << 32));
+}