Make was caching too much, thus some targets were not rebuild properly

diff --git a/helm/software/components/library/librarian.ml b/helm/software/components/library/librarian.ml
index 124b1a1f5a57ece6cb0260e213986709543b6231..f53de728c6a1ab554fed38f3bad8011c0d627f40 100644 (file)
--- a/helm/software/components/library/librarian.ml
+++ b/helm/software/components/library/librarian.ml
@@ -150,65 +150,88 @@ module type Format =
 
 module Make = functor (F:Format) -> struct
 
-  let prerr_endline s = if debug then prerr_endline ("make: "^s);; 
+  let say s = if debug then prerr_endline ("make: "^s);; 
 
   let unopt_or_call x f y = match x with Some _ -> x | None -> f y;;
 
-  let younger_s_t a fa b fb = 
-    let a = unopt_or_call a F.mtime_of_source_object fa in
-    let b = unopt_or_call b F.mtime_of_target_object fb in
-    match a,b with 
+  let younger_s_t (_,cs,ct) a b = 
+    let a = try Hashtbl.find cs a with Not_found -> assert false in
+    let b = 
+      try
+        match Hashtbl.find ct b with
+        | Some _ as x -> x
+        | None ->
+           match F.mtime_of_target_object b with
+           | Some t as x -> Hashtbl.add ct b x; x
+           | x -> x
+      with Not_found -> assert false
+    in
+    match a, b with 
     | Some a, Some b -> a < b
     | _ -> false
   ;;
 
-  let younger_t_t a fa b fb = 
-    let a = unopt_or_call a F.mtime_of_target_object fa in
-    let b = unopt_or_call b F.mtime_of_target_object fb in
+  let younger_t_t (_,_,ct) a b = 
+    let a = 
+      try
+        match Hashtbl.find ct a with
+        | Some _ as x -> x
+        | None ->
+           match F.mtime_of_target_object a with
+           | Some t as x -> Hashtbl.add ct a x; x
+           | x -> x
+      with Not_found -> assert false
+    in
+    let b = 
+      try
+        match Hashtbl.find ct b with
+        | Some _ as x -> x
+        | None ->
+           match F.mtime_of_target_object b with
+           | Some t as x -> Hashtbl.add ct b x; x
+           | x -> x
+      with Not_found -> assert false
+    in
     match a, b with
     | Some a, Some b -> a < b
     | _ -> false
   ;;
 
-  let is_built opts mt t mtgt tgt = 
-    younger_s_t mt t mtgt tgt
+  let is_built opts t tgt = 
+    younger_s_t opts t tgt
   ;;
 
-  let assoc6 l k = List.find (fun (k1,_,_,_,_,_) -> k1 = k) l;;
+  let assoc4 l k = List.find (fun (k1,_,_,_) -> k1 = k) l;;
 
-  let fst6 = function (x,_,_,_,_,_) -> x;;
+  let fst4 = function (x,_,_,_) -> x;;
 
-  let rec needs_build opts deps compiled (t,dependencies,root,tgt,mt,mtgt) =
-    prerr_endline ("Checking if "^F.string_of_source_object t^
-      " needs to be built");
+  let rec needs_build opts deps compiled (t,dependencies,root,tgt) =
+    say ("Checking if "^F.string_of_source_object t^ " needs to be built");
     if List.mem t compiled then
-      (prerr_endline "already compiled";
-      false)
+      (say "already compiled"; false)
     else
-    if not (is_built opts mt t mtgt tgt) then
-      (prerr_endline (F.string_of_source_object t^
-       " is not built, thus needs to be built");
+    if not (is_built opts t tgt) then
+      (say(F.string_of_source_object t^" is not built, thus needs to be built");
       true)
     else
     try
       let unsat =
         List.find
           (needs_build opts deps compiled) 
-          (List.map (assoc6 deps) dependencies)
+          (List.map (assoc4 deps) dependencies)
       in
-        prerr_endline 
-         (F.string_of_source_object t^" depends on "^
-         F.string_of_source_object (fst6 unsat)^
+        say (F.string_of_source_object t^" depends on "^
+         F.string_of_source_object (fst4 unsat)^
          " that needs to be built, thus needs to be built");
         true
     with Not_found ->
       try 
-        let _,_,_,unsat,_,_ = 
+        let _,_,_,unsat = 
           List.find 
-           (fun (_,_,_,tgt1,_,mtgt1) -> younger_t_t mtgt tgt mtgt1 tgt1) 
-           (List.map (assoc6 deps) dependencies)
+           (fun (_,_,_,tgt1) -> younger_t_t opts tgt tgt1) 
+           (List.map (assoc4 deps) dependencies)
         in
-          prerr_endline 
+          say 
            (F.string_of_source_object t^" depends on "^F.string_of_target_object
            unsat^" and "^F.string_of_source_object t^".o is younger than "^
            F.string_of_target_object unsat^", thus needs to be built");
@@ -216,26 +239,25 @@ module Make = functor (F:Format) -> struct
       with Not_found -> false
   ;;
 
-  let is_buildable opts compiled deps (t,dependencies,root,tgt,_,_ as what) =
-    prerr_endline ("Checking if "^F.string_of_source_object t^" is buildable");
+  let is_buildable opts compiled deps (t,dependencies,root,tgt as what) =
+    say ("Checking if "^F.string_of_source_object t^" is buildable");
     let b = needs_build opts deps compiled what in
     if not b then
-      (prerr_endline (F.string_of_source_object t^
+      (say (F.string_of_source_object t^
        " does not need to be built, thus it not buildable");
       false)
     else
     try  
-      let unsat,_,_,_,_,_ =
+      let unsat,_,_,_ =
         List.find (needs_build opts deps compiled) 
-          (List.map (assoc6 deps) dependencies)
+          (List.map (assoc4 deps) dependencies)
       in
-        prerr_endline 
-          (F.string_of_source_object t^" depends on "^
+        say (F.string_of_source_object t^" depends on "^
           F.string_of_source_object unsat^
           " that needs build, thus is not buildable");
         false
     with Not_found -> 
-      prerr_endline 
+      say 
         ("None of "^F.string_of_source_object t^
         " dependencies needs to be built, thus it is buildable");
       true
@@ -244,37 +266,37 @@ module Make = functor (F:Format) -> struct
   let rec purge_unwanted_roots wanted deps =
     let roots, rest = 
        List.partition 
-         (fun (t,d,_,_,_,_) ->
-           not (List.exists (fun (_,d1,_,_,_,_) -> List.mem t d1) deps))
+         (fun (t,d,_,_) ->
+           not (List.exists (fun (_,d1,_,_) -> List.mem t d1) deps))
          deps
     in
-    let newroots = List.filter (fun (t,_,_,_,_,_) -> List.mem t wanted) roots in
+    let newroots = List.filter (fun (t,_,_,_) -> List.mem t wanted) roots in
     if newroots = roots then
       deps
     else
       purge_unwanted_roots wanted (newroots @ rest)
   ;;
 
-
-  let rec make_aux root local_options compiled failed deps = 
-    let todo = List.filter (is_buildable local_options compiled deps) deps in
-    let todo = List.filter (fun (f,_,_,_,_,_)->not (List.mem f failed)) todo in
+  let rec make_aux root (lo,_,ct as opts) compiled failed deps = 
+    let todo = List.filter (is_buildable opts compiled deps) deps in
+    let todo = List.filter (fun (f,_,_,_)->not (List.mem f failed)) todo in
     if todo <> [] then
       let compiled, failed = 
         let todo =
           let local, remote =
-            List.partition (fun (_,_,froot,_,_,_) -> froot = Some root) todo
+            List.partition (fun (_,_,froot,_) -> froot = Some root) todo
           in
           remote @ local
         in
         List.fold_left 
-          (fun (c,f) (file,_,froot,_,_,_) ->
+          (fun (c,f) (file,_,froot,tgt) ->
             let rc = 
               match froot with
-              | Some froot when froot = root ->
-                  F.build local_options file 
-              | Some froot ->
-                  make froot [file]
+              | Some froot when froot = root -> 
+                  Hashtbl.remove ct tgt;
+                  Hashtbl.add ct tgt None;
+                  F.build lo file 
+              | Some froot -> make froot [file]
               | None -> 
                   HLog.error ("No root for: "^F.string_of_source_object file);
                   false
@@ -283,7 +305,7 @@ module Make = functor (F:Format) -> struct
             else (c,file::f))
           (compiled,failed) todo
       in
-        make_aux root local_options compiled failed deps
+        make_aux root opts compiled failed deps
     else
       compiled, failed
 
@@ -293,20 +315,23 @@ module Make = functor (F:Format) -> struct
     Sys.chdir root;
     let deps = F.load_deps_file (root^"/depends") in
     let local_options = load_root_file (root^"/root") in
+    let caches,cachet = Hashtbl.create 73, Hashtbl.create 73 in
+    (* deps are enriched with these informations to sped up things later *)
     let deps = 
       List.map 
         (fun (file,d) -> 
-                HLog.debug (F.string_of_source_object file);
           let r,tgt = F.root_and_target_of local_options file in
-          file, d, r, tgt, F.mtime_of_source_object file, 
-          F.mtime_of_target_object tgt) 
+          Hashtbl.add caches file (F.mtime_of_source_object file);
+          Hashtbl.add cachet tgt (F.mtime_of_target_object tgt); 
+          file, d, r, tgt)
         deps
     in
+    let opts = local_options, caches, cachet in
     let _compiled, failed =
       if targets = [] then 
-        make_aux root local_options [] [] deps
+        make_aux root opts [] [] deps
       else
-        make_aux root local_options [] [] (purge_unwanted_roots targets deps)
+        make_aux root opts [] [] (purge_unwanted_roots targets deps)
     in
     HLog.debug ("Leaving directory '"^root^"'");
     Sys.chdir old_root;