From: Enrico Tassi Date: Fri, 11 Jan 2008 09:52:46 +0000 (+0000) Subject: Make was caching too much, thus some targets were not rebuild properly X-Git-Tag: make_still_working~5691 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=419668fb5326eb03278d4e917f2d9bd8a2ca50fc;p=helm.git 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 124b1a1f5..f53de728c 100644 --- 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;