[ocamlbuild] Move some functions from Pathname to Resource and use Digest_cache.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8668 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

9 files changed, 109 insertions, 132 deletions

diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml
index 501411c47..bc3652533 100644
--- a/ocamlbuild/main.ml
+++ b/ocamlbuild/main.ml
@@ -30,7 +30,7 @@ let clean () =
       Slurp.map (fun _ _ _ -> true)
         (Slurp.slurp Filename.current_dir_name)
     in
-    Slurp.force (Pathname.clean_up_links entry)
+    Slurp.force (Resource.clean_up_links entry)
   end;
   raise Exit_silently
 ;;
@@ -145,7 +145,7 @@ let proceed () =
     show_documentation ();
     raise Exit_silently
   end;
-  Resource.Cache.init ();
+  Digest_cache.init ();
 
   Sys.catch_break true;
 
diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml
index 57632b718..c0d8d2611 100644
--- a/ocamlbuild/ocaml_compiler.ml
+++ b/ocamlbuild/ocaml_compiler.ml
@@ -246,7 +246,7 @@ let link_units table extensions cmX_ext cma_ext a_ext linker tagger contents_lis
   let _ = Rule.build_deps_of_tags build tags in
   let dir =
     let dir1 = Pathname.remove_extensions cmX in
-    if Pathname.exists_in_source_dir dir1 then dir1
+    if Resource.exists_in_source_dir dir1 then dir1
     else Pathname.dirname cmX in
   let include_dirs = Pathname.include_dirs_of dir in
   let extension_keys = List.map fst extensions in
diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml
index 4a10bf1dc..f98ab207c 100644
--- a/ocamlbuild/ocaml_dependencies.ml
+++ b/ocamlbuild/ocaml_dependencies.ml
@@ -111,7 +111,7 @@ module Make (I : INPUT) = struct
       if pack_mode then
         if Filename.check_suffix x ".cmi" then
           let caml_obj = Pathname.update_extensions caml_obj_ext x in
-          if Pathname.exists_in_build_dir caml_obj then
+          if Resource.exists_in_build_dir caml_obj then
             caml_obj
           else
             x
diff --git a/ocamlbuild/pathname.ml b/ocamlbuild/pathname.ml
index f2ba6aa48..c6410336f 100644
--- a/ocamlbuild/pathname.ml
+++ b/ocamlbuild/pathname.ml
@@ -43,9 +43,6 @@ module Operators = struct
 end
 open Operators
 
-let in_source_dir p =
-  if is_implicit p then pwd/p else invalid_arg (sprintf "in_source_dir: %S" p)
-
 let equal x y = x = y
 
 let to_string x = x
@@ -98,38 +95,6 @@ let get_extensions x =
 let update_extensions ext x =
   add_extension ext (chop_extensions x)
 
-let clean_up_links entry =
-  if not !Options.make_links then entry else
-  Slurp.filter begin fun path name _ ->
-    let pathname = in_source_dir (path/name) in
-    if link_to_dir pathname !Options.build_dir then
-      let z = readlink pathname in
-      (* Here is one exception where one can use Sys.file_exists directly *)
-      (if not (Sys.file_exists z) then
-        Shell.rm pathname; false)
-    else true
-  end entry
-
-let clean_up_link_to_build () =
-  Options.entry := Some(clean_up_links (the !Options.entry))
-
-let source_dir_path_set_without_links_to_build =
-  lazy begin
-    clean_up_link_to_build ();
-    Slurp.fold (fun path name _ -> StringSet.add (path/name))
-               (the !Options.entry) StringSet.empty
-  end
-
-let exists_in_source_dir p =
-  if !*My_unix.is_degraded then sys_file_exists (in_source_dir p)
-  else StringSet.mem p !*source_dir_path_set_without_links_to_build
-
-let clean_links () =
-  if !*My_unix.is_degraded then
-    ()
-  else
-    ignore (clean_up_link_to_build ())
-
 let exists = sys_file_exists
 
 let copy = Shell.cp
@@ -143,8 +108,6 @@ let with_output_file = with_output_file
 
 let print_path_list = List.print print
 
-let root = mk "__root__"
-
 let context_table = Hashtbl.create 107
 
 let rec include_dirs_of dir =
@@ -162,20 +125,5 @@ let define_context dir context =
   let dir = if dir = "" then current_dir_name else dir in
   Hashtbl.replace context_table dir& List.union context& include_dirs_of dir
 
-let in_build_dir p =
-  if is_relative p then p
-  else
-    root/p (* XXX: Never reached *)
-
-let exists_in_build_dir p = exists (in_build_dir p)
-
 let same_contents x y = Digest.file x = Digest.file y
 
-let is_up_to_date b p =
-  let x = in_build_dir p in
-  if b then exists_in_source_dir p && exists x && same_contents x (in_source_dir p)
-  else not (exists_in_source_dir p) || exists x && same_contents x (in_source_dir p)
-
-let import_in_build_dir p =
-  let p_in_build_dir = in_build_dir p in
-  Shell.mkdir_p (dirname p); copy (in_source_dir p) p_in_build_dir
diff --git a/ocamlbuild/pathname.mli b/ocamlbuild/pathname.mli
index 1bd1f09db..63deaf9cf 100644
--- a/ocamlbuild/pathname.mli
+++ b/ocamlbuild/pathname.mli
@@ -12,11 +12,4 @@
 (* $Id$ *)
 (* Original author: Nicolas Pouillard *)
 include Signatures.PATHNAME
-
-val is_up_to_date : bool -> t -> bool
-val clean_up_links : bool Slurp.entry -> bool Slurp.entry
-val exists_in_source_dir : t -> bool
-val exists_in_build_dir : t -> bool
-val import_in_build_dir : t -> unit
-val in_build_dir : t -> t
-val in_source_dir : t -> t
+val link_to_dir : t -> t -> bool
diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml
index 0d13e854e..26fb5ba83 100644
--- a/ocamlbuild/resource.ml
+++ b/ocamlbuild/resource.ml
@@ -14,6 +14,7 @@
 open My_std
 open Format
 open Log
+open Pathname.Operators
 
 module Resources = Set.Make(Pathname)
 
@@ -22,8 +23,48 @@ let print = Pathname.print
 let equal = (=)
 let compare = compare
 
+let in_source_dir p =
+  if Pathname.is_implicit p then Pathname.pwd/p else invalid_arg (Printf.sprintf "in_source_dir: %S" p)
+
+let in_build_dir p =
+  if Pathname.is_relative p then p
+  else invalid_arg (Printf.sprintf "in_build_dir: %S" p)
+
+let clean_up_links entry =
+  if not !Options.make_links then entry else
+  Slurp.filter begin fun path name _ ->
+    let pathname = in_source_dir (path/name) in
+    if Pathname.link_to_dir pathname !Options.build_dir then
+      let z = Pathname.readlink pathname in
+      (* Here is one exception where one can use Sys.file_exists directly *)
+      (if not (Sys.file_exists z) then
+        Shell.rm pathname; false)
+    else true
+  end entry
+
+let clean_up_link_to_build () =
+  Options.entry := Some(clean_up_links (the !Options.entry))
+
+let source_dir_path_set_without_links_to_build =
+  lazy begin
+    clean_up_link_to_build ();
+    Slurp.fold (fun path name _ -> StringSet.add (path/name))
+               (the !Options.entry) StringSet.empty
+  end
+
+let clean_links () =
+  if !*My_unix.is_degraded then
+    ()
+  else
+    ignore (clean_up_link_to_build ())
+
+let exists_in_source_dir p =
+  if !*My_unix.is_degraded then sys_file_exists (in_source_dir p)
+  else StringSet.mem p !*source_dir_path_set_without_links_to_build
+
+let clean p = Shell.rm_f p
+
 module Cache = struct
-  open Pathname.Operators
 
   let clean () = Shell.chdir Pathname.pwd; Shell.rm_rf !Options.build_dir
 
@@ -97,6 +138,13 @@ module Cache = struct
     dprintf 10 "resource_changed:@ %a" print r;
     (get r).changed <- Yes
 
+  let source_is_up_to_date r_in_source_dir r_in_build_dir =
+    Pathname.exists r_in_build_dir && Digest.file r_in_build_dir = Digest.file r_in_source_dir
+
+  let prod_is_up_to_date p =
+    let x = in_build_dir p in
+    not (exists_in_source_dir p) || Pathname.exists x && Pathname.same_contents x (in_source_dir p)
+
   let rec resource_has_changed r =
     let cache_entry = get r in
     match cache_entry.changed with
@@ -108,19 +156,32 @@ module Cache = struct
         | Bbuilt -> false
         | Bsuspension _ -> assert false
         | Bcannot_be_built -> false
-        | Bnot_built_yet -> not (Pathname.is_up_to_date false r) in
+        | Bnot_built_yet -> not (prod_is_up_to_date r) in
       let () = cache_entry.changed <- if res then Yes else No in res
 
   let resource_state r = (get r).built
 
-  let resource_is_built r = (get r).built = Bbuilt
-
   let resource_built r = (get r).built <- Bbuilt
 
-  let resource_is_failed r = (get r).built = Bcannot_be_built
-
   let resource_failed r = (get r).built <- Bcannot_be_built
 
+  let import_in_build_dir r =
+    if exists_in_source_dir r then begin
+      let cache_entry = get r in
+      let r_in_build_dir = in_build_dir r in
+      let r_in_source_dir = in_source_dir r in
+      if source_is_up_to_date r_in_source_dir r_in_build_dir then begin
+        dprintf 5 "%a exists and up to date" print r;
+      end else begin
+        dprintf 5 "%a exists in source dir -> import it" print r;
+        Shell.mkdir_p (Pathname.dirname r);
+        Pathname.copy r_in_source_dir r_in_build_dir;
+        cache_entry.changed <- Yes;
+      end;
+      cache_entry.built <- Bbuilt;
+      true
+    end else false
+
   let suspend_resource r cmd kont prods =
     let cache_entry = get r in
     match cache_entry.built with
@@ -165,43 +226,16 @@ module Cache = struct
 
   let print_dependencies = print_graph
 
-  let digest_resource p =
-    let f = Pathname.to_string (Pathname.in_build_dir p) in
-    let buf = Buffer.create 1024 in
-    Buffer.add_string buf f;
-    (if sys_file_exists f then Buffer.add_string buf (Digest.file f));
-    Digest.string (Buffer.contents buf)
-
-  let digests = Hashtbl.create 103
-
-  let get_digest_for name =
-    try Some (Hashtbl.find digests name)
-    with Not_found -> None
-  let store_digest name d = Hashtbl.replace digests name d
-
-  let _digests = lazy (Pathname.pwd / !Options.build_dir / (Pathname.mk "_digests"))
-
-  let finalize () =
-    with_output_file !*_digests begin fun oc ->
-      Hashtbl.iter begin fun name digest ->
-        Printf.fprintf oc "%S: %S\n" name digest
-      end digests
-    end
-
-  let init () =
-    Shell.chdir !Options.build_dir;
-    if Pathname.exists !*_digests then
-      with_input_file !*_digests begin fun ic ->
-        try while true do
-          let l = input_line ic in
-          Scanf.sscanf l "%S: %S" store_digest
-        done with End_of_file -> ()
-      end;
-    My_unix.at_exit_once finalize
-
 end
 
-let clean p = Shell.rm_f p
+let digest p =
+  let f = Pathname.to_string (in_build_dir p) in
+  let buf = Buffer.create 1024 in
+  Buffer.add_string buf f;
+  (if sys_file_exists f then Buffer.add_string buf (Digest.file f));
+  Digest.string (Buffer.contents buf)
+
+let exists_in_build_dir p = Pathname.exists (in_build_dir p)
 
 (*
 type env = string
@@ -233,8 +267,6 @@ let rec subst percent r =
 let print_env = pp_print_string
 *)
 
-let is_up_to_date path = Pathname.is_up_to_date true path
-
 let import x = x
 
 module MetaPath : sig
diff --git a/ocamlbuild/resource.mli b/ocamlbuild/resource.mli
index 03004df1c..56157a67d 100644
--- a/ocamlbuild/resource.mli
+++ b/ocamlbuild/resource.mli
@@ -21,6 +21,7 @@ module Resources : Set.S with type elt = t
 
 module Cache :
   sig
+    type cache_entry
     type suspension
 
     type build_status =
@@ -30,29 +31,34 @@ module Cache :
       | Bsuspension of suspension
 
     val clean : unit -> unit
-    val init : unit -> unit
     val resource_state : t -> build_status
     val resource_changed : t -> unit
     val resource_has_changed : t -> bool
-    val resource_is_built : t -> bool
     val resource_built : t -> unit
-    val resource_is_failed : t -> bool
     val resource_failed : t -> unit
+    val import_in_build_dir : t -> bool
     val suspend_resource : t -> Command.t -> (unit -> unit) -> t list -> unit
     val resume_resource : t -> unit
     val resume_suspension : suspension -> unit
     val get_optional_resource_suspension : t -> (Command.t * (unit -> unit)) option
     val clear_resource_failed : t -> unit
-    val dependencies : t -> Resources.t
     val add_dependency : t -> t -> unit
-    val get_digest_for : string -> string option
-    val store_digest : string -> string -> unit
-    val digest_resource : t -> string
+    val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a
+
+    (* These are not currently used by others modules. *)
+    val dependencies : t -> Resources.t
     val print_cache : Format.formatter -> unit -> unit
     val print_dependencies : Format.formatter -> unit -> unit
-    val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a
   end
 
+val digest : t -> string
+val exists_in_source_dir : t -> bool
+val exists_in_build_dir : t -> bool
+val in_build_dir : t -> t
+val in_source_dir : t -> t
+
+val clean_up_links : bool Slurp.entry -> bool Slurp.entry
+
 val compare : t -> t -> int
 val print : Format.formatter -> t -> unit
 val print_pattern : Format.formatter -> resource_pattern -> unit
@@ -64,5 +70,5 @@ val matchit : resource_pattern -> t -> env option
 val subst : env -> t -> t
 val subst_any : env -> t -> t
 val subst_pattern : env -> resource_pattern -> t
-val is_up_to_date : t -> bool
+(* val is_up_to_date : t -> bool *)
 val print_env : Format.formatter -> env -> unit
diff --git a/ocamlbuild/rule.ml b/ocamlbuild/rule.ml
index e717c3da9..a6fb57dd7 100644
--- a/ocamlbuild/rule.ml
+++ b/ocamlbuild/rule.ml
@@ -90,14 +90,13 @@ let can_produce target rule =
 
 let digest_prods r =
   List.fold_right begin fun p acc ->
-    let f = Pathname.to_string (Pathname.in_build_dir p) in
+    let f = Pathname.to_string (Resource.in_build_dir p) in
     if sys_file_exists f then (f, Digest.file f) :: acc else acc
   end r.prods []
 
 let digest_deps r dyndeps =
   let buf = Buffer.create 1024 in
-  let add_resource r = Buffer.add_string buf (Digest.to_hex
-  (Resource.Cache.digest_resource r)) in
+  let add_resource r = Buffer.add_string buf (Digest.to_hex (Resource.digest r)) in
   Buffer.add_string buf "deps:";
   List.iter add_resource r.deps;
   Buffer.add_string buf "dyndeps:";
@@ -107,7 +106,7 @@ let digest_deps r dyndeps =
 let digest_rule r dyndeps action =
   let buf = Buffer.create 1024 in
   Buffer.add_string buf action.digest;
-  let add_resource r = Buffer.add_string buf (Resource.Cache.digest_resource r) in
+  let add_resource r = Buffer.add_string buf (Resource.digest r) in
   Buffer.add_string buf "prods:";
   List.iter add_resource r.prods;
   Buffer.add_string buf "deps:";
@@ -116,6 +115,12 @@ let digest_rule r dyndeps action =
   Resources.iter add_resource dyndeps;
   Digest.string (Buffer.contents buf)
 
+let cached_digest r =
+  try Some (Digest_cache.get ("Rule: " ^ r.name))
+  with Not_found -> None
+
+let store_digest r digest = Digest_cache.put ("Rule: " ^ r.name) digest
+
 let print_digest f x = pp_print_string f (Digest.to_hex x)
 
 let exists2 find p rs =
@@ -184,7 +189,7 @@ let call builder r =
   let dyndeps = !dyndeps in
   let () = dprintf 10 "dyndeps: %a" Resources.print dyndeps in
   let (reason, cached) =
-    match exists2 List.find (fun r -> not (Pathname.exists_in_build_dir r)) r.prods with
+    match exists2 List.find (fun r -> not (Resource.exists_in_build_dir r)) r.prods with
     | Some r -> (`cache_miss_missing_prod r, false)
     | _ ->
       begin match exists2 List.find Resource.Cache.resource_has_changed r.deps with
@@ -193,7 +198,7 @@ let call builder r =
         begin match exists2 Resources.find Resource.Cache.resource_has_changed dyndeps with
         | Some r -> (`cache_miss_changed_dyn_dep r, false)
         | _ ->
-            begin match Resource.Cache.get_digest_for r.name with
+            begin match cached_digest r with
             | None -> (`cache_miss_no_digest, false)
             | Some d ->
                 begin match action.contents with
@@ -256,9 +261,9 @@ let call builder r =
       (if not cached then
         let new_rule_digest = digest_rule r dyndeps action in
         let new_prod_digests = digest_prods r in
-        let () = Resource.Cache.store_digest r.name new_rule_digest in
+        let () = store_digest r new_rule_digest in
         List.iter begin fun p ->
-          let f = Pathname.to_string (Pathname.in_build_dir p) in
+          let f = Pathname.to_string (Resource.in_build_dir p) in
           (try let digest = List.assoc f prod_digests in
                let new_digest = List.assoc f new_prod_digests in
                if digest <> new_digest then raise Not_found
diff --git a/ocamlbuild/solver.ml b/ocamlbuild/solver.ml
index eedaa5764..11804a2ab 100644
--- a/ocamlbuild/solver.ml
+++ b/ocamlbuild/solver.ml
@@ -46,14 +46,7 @@ let rec self depth on_the_go_orig target =
       (dprintf 5 "%a was suspended -> resuming" Resource.print target;
        Resource.Cache.resume_suspension s)
   | Resource.Cache.Bnot_built_yet ->
-    if Resource.is_up_to_date target then
-      (dprintf 5 "%a exists and up to date" Resource.print target;
-       Resource.Cache.resource_built target)
-    else if Pathname.exists_in_source_dir target then
-        (dprintf 5 "%a exists in source dir -> import it" Resource.print target;
-         Pathname.import_in_build_dir target;
-         Resource.Cache.resource_built target;
-         Resource.Cache.resource_changed target)
+    if Resource.Cache.import_in_build_dir target then ()
     else
     (* FIXME tags of target
     let tags = Configuration.tags_of_target target in