Use mtime + inode to detect when we need to rehash

Previously we were only using mtime but it's not precise on OSX.

Fix #456

CHANGES.md

@@ -87,6 +87,9 @@
 - Always build `boot.exe` as a bytecode program. It makes the build of
   jbuilder faster and fix the build on some architectures (#463, fixes #446)
 
+- Fix incremental builds on OSX. Uses mtime + inode number to detect
+  when files need to be rehashed (#460, fix #456)
+
 1.0+beta16 (05/11/2017)
 -----------------------
 

src/action.ml

@@ -594,9 +594,11 @@ module Promotion = struct
     let register t = db := t :: !db
 
     let promote { src; dst } =
-      Format.eprintf "Promoting %s to %s.@."
-        (Path.to_string_maybe_quoted src)
-        (Path.to_string_maybe_quoted dst);
+      (* It is important to delete the file first. On OSX, timestamps are not precise
+         enough, so if the build is fast enough, mtime won't be enough to detect that the
+         file might has changed, which will break incremental compilation. *)
+      Path.unlink_no_err dst;
+      Utils.Cached_digest.remove dst;
       Io.copy_file
         ~src:(Path.to_string src)
         ~dst:(Path.to_string dst)
@@ -634,6 +636,9 @@ module Promotion = struct
       match srcs with
       | [] -> assert false
       | src :: others ->
+        Format.eprintf "Promoting %s to %s.@."
+          (Path.to_string_maybe_quoted src)
+          (Path.to_string_maybe_quoted dst);
         File.promote { src; dst };
         List.iter others ~f:(fun path ->
           Format.eprintf " -> ignored %s.@."

src/action.mli

@@ -140,6 +140,9 @@ module Promotion : sig
 
     (** Register a file to promote *)
     val register : t -> unit
+
+    (** Promote a file immediatly *)
+    val promote : t -> unit
   end
 
   (** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of

src/build_system.ml

@@ -712,9 +712,10 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
           let in_source_tree = Option.value_exn (Path.drop_build_context path) in
           if mode = Promote_but_delete_on_clean then
             Promoted_to_delete.add in_source_tree;
-          Io.copy_file
-            ~src:(Path.to_string path)
-            ~dst:(Path.to_string in_source_tree))
+          Action.Promotion.File.promote
+            { src = path
+            ; dst = in_source_tree
+            })
     ) else
       return ()
   in
@@ -1056,7 +1057,6 @@ module Trace = struct
   let file = "_build/.db"
 
   let dump (trace : t) =
-    Utils.Cached_digest.dump ();
     let sexp =
       Sexp.List (
         Hashtbl.fold trace ~init:Pmap.empty ~f:(fun ~key ~data acc ->
@@ -1069,7 +1069,6 @@ module Trace = struct
       Io.write_file file (Sexp.to_string sexp)
 
   let load () =
-    Utils.Cached_digest.load ();
     let trace = Hashtbl.create 1024 in
     if Sys.file_exists file then begin
       let sexp = Sexp.load ~fname:file ~mode:Single in
@@ -1090,11 +1089,15 @@ let all_targets t =
   Hashtbl.fold t.files ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc)
 
 let finalize t =
+  (* Promotion must be handled before dumping the digest cache, as it might delete some
+     entries. *)
+  Action.Promotion.finalize ();
   Promoted_to_delete.dump ();
-  Trace.dump t.trace;
-  Action.Promotion.finalize ()
+  Utils.Cached_digest.dump ();
+  Trace.dump t.trace
 
 let create ~contexts ~file_tree =
+  Utils.Cached_digest.load ();
   let contexts =
     List.map contexts ~f:(fun c -> (c.Context.name, c))
     |> String_map.of_alist_exn

src/utils.ml

@@ -164,44 +164,66 @@ let install_file ~package ~findlib_toolchain =
   | Some x -> sprintf "%s-%s.install" package x
 
 module Cached_digest = struct
+  module Stats = struct
+    (* Subset of [Unix.stat].
+
+       The intent is to have the smallest structure such that if the file contents
+       changes, this structure changes as well. *)
+    type t =
+      { inode : int
+      ; mtime : float
+      }
+
+    let of_file fn =
+      let st = Unix.stat (Path.to_string fn) in
+      { inode = st.st_ino
+      ; mtime = st.st_mtime
+      }
+
+    let equal t { inode; mtime } =
+      t.inode = inode &&
+      t.mtime = mtime
+  end
+
   type file =
-    { mutable digest            : Digest.t
-    ; mutable timestamp         : float
-    ; mutable timestamp_checked : bool
+    { mutable digest        : Digest.t
+    ; mutable stats         : Stats.t
+    ; mutable stats_checked : bool
     }
 
   let cache = Hashtbl.create 1024
 
   let file fn =
     match Hashtbl.find cache fn with
     | Some x ->
-      if x.timestamp_checked then
+      if x.stats_checked then
         x.digest
       else begin
-        let mtime = (Unix.stat (Path.to_string fn)).st_mtime in
-        if mtime <> x.timestamp then begin
+        let stats = Stats.of_file fn in
+        if not (Stats.equal stats x.stats) then begin
           let digest = Digest.file (Path.to_string fn) in
-          x.digest    <- digest;
-          x.timestamp <- mtime;
+          x.digest <- digest;
+          x.stats  <- stats;
         end;
-        x.timestamp_checked <- true;
+        x.stats_checked <- true;
         x.digest
       end
     | None ->
       let digest = Digest.file (Path.to_string fn) in
       Hashtbl.add cache ~key:fn
         ~data:{ digest
-              ; timestamp = (Unix.stat (Path.to_string fn)).st_mtime
-              ; timestamp_checked = true
+              ; stats = Stats.of_file fn
+              ; stats_checked = true
               };
       digest
 
   let remove fn =
     match Hashtbl.find cache fn with
     | None -> ()
-    | Some file -> file.timestamp_checked <- false
+    | Some file -> file.stats_checked <- false
 
-  let db_file = "_build/.digest-db"
+  let old_files = ["_build/.digest-db"]
+  let db_file = "_build/.digest-db.v2"
 
   let dump () =
     let module Pmap = Path.Map in
@@ -211,31 +233,42 @@ module Cached_digest = struct
           Pmap.add acc ~key ~data)
         |> Path.Map.bindings
         |> List.map ~f:(fun (path, file) ->
+          let { digest; stats = { inode; mtime }; stats_checked = _ } = file in
           Sexp.List [ Atom (Path.to_string path)
-                    ; Atom (Digest.to_hex file.digest)
-                    ; Atom (Int64.to_string (Int64.bits_of_float file.timestamp))
+                    ; Atom (Digest.to_hex digest)
+                    ; Atom (string_of_int inode)
+                    ; Atom (Int64.to_string (Int64.bits_of_float mtime))
                     ]))
     in
-    if Sys.file_exists "_build" then
-      Io.write_file db_file (Sexp.to_string sexp)
+    if Sys.file_exists "_build" then begin
+      Io.write_file db_file (Sexp.to_string sexp);
+      List.iter old_files ~f:(fun fn ->
+        try Sys.remove fn with _ -> ())
+    end
 
   let load () =
     if Sys.file_exists db_file then begin
       let sexp = Sexp.load ~fname:db_file ~mode:Single in
-      let bindings =
+      let binding (sexp : Sexp.Ast.t) =
         let open Sexp.Of_sexp in
-        list
-          (triple
-             Path.t
-             (fun s -> Digest.from_hex (string s))
-             (fun s -> Int64.float_of_bits (Int64.of_string (string s)))
-          ) sexp
+        match sexp with
+        | List (_, [path; digest; inode; mtime]) ->
+          let path = Path.t path in
+          let file =
+            { digest = Digest.from_hex (string digest)
+            ; stats = { inode = int inode
+                      ; mtime = Int64.float_of_bits
+                                  (Int64.of_string (string mtime))
+                      }
+            ; stats_checked = false
+            }
+          in
+          Hashtbl.add cache ~key:path ~data:file
+        | _ ->
+          of_sexp_error sexp "S-expression of the form (_ _ _ _) expected"
       in
-      List.iter bindings ~f:(fun (path, digest, timestamp) ->
-        Hashtbl.add cache ~key:path
-          ~data:{ digest
-                ; timestamp
-                ; timestamp_checked = false
-                });
+      match sexp with
+      | Atom _ -> Sexp.Of_sexp.of_sexp_error sexp "list expected"
+      | List (_, l) -> List.iter l ~f:binding
     end
 end

test/blackbox-tests/test-cases/promote/run.t

@@ -1,4 +1,4 @@
-  $ echo titi > x
+  $ printf titi > x
 
   $ $JBUILDER build --root . -j1 --diff-command false @blah 2>&1 | sed 's/.*false.*/DIFF/'
             sh (internal) (exit 1)
@@ -15,7 +15,7 @@
   $ cat x
   toto
 
-  $ echo titi > x
+  $ printf titi > x
   $ $JBUILDER build --root . -j1 --diff-command false @blah --auto-promote 2>&1 | sed 's/.*false.*/DIFF/'
             sh (internal) (exit 1)
   DIFF