X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Flibrary%2Flibrarian.ml;h=62a8a892c3887f5b965266e49077846456ffa227;hb=b91dfc5e2b00e6b0b4cb81109192bb2b825055a1;hp=32b6de48bfd6a599b905ee30820f6f5457839a90;hpb=e45ba2323380ad74c296dd4ec16a71be51c069ba;p=helm.git diff --git a/helm/software/components/library/librarian.ml b/helm/software/components/library/librarian.ml index 32b6de48b..62a8a892c 100644 --- a/helm/software/components/library/librarian.ml +++ b/helm/software/components/library/librarian.ml @@ -23,14 +23,18 @@ * http://helm.cs.unibo.it/ *) -let debug = false;; - -let timestamp msg = - if debug then - let times = Unix.times () in - let utime = times.Unix.tms_utime in - let msg = Printf.sprintf "UTIMESTAMP (%s): %f" msg utime in - prerr_endline msg +let debug = ref false + +let time_stamp = + let old = ref 0.0 in + fun msg -> + if !debug then begin + let times = Unix.times () in + let stamp = times.Unix.tms_utime +. times.Unix.tms_stime in + let lap = stamp -. !old in + Printf.eprintf "TIME STAMP (%s): %f\n" msg lap; flush stderr; + old := stamp + end exception NoRootFor of string @@ -187,7 +191,9 @@ module type Format = val string_of_target_object: target_object -> string val build: options -> source_object -> bool val root_and_target_of: - options -> source_object -> string option * target_object + options -> source_object -> + (* root, writeable target, read only target *) + string option * target_object * target_object val mtime_of_source_object: source_object -> float option val mtime_of_target_object: target_object -> float option val is_readonly_buri_of: options -> source_object -> bool @@ -198,13 +204,17 @@ module Make = functor (F:Format) -> struct type status = Done of bool | Ready of bool - let say 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 fst4 = function (x,_,_,_) -> x;; let modified_before_s_t (_,cs, ct, _, _) a b = +(* + time_stamp ("L s_t: a " ^ F.string_of_source_object a); + time_stamp ("L s_t: b " ^ F.string_of_target_object b); +*) let a = try Hashtbl.find cs a with Not_found -> assert false in let b = try @@ -218,20 +228,28 @@ module Make = functor (F:Format) -> struct | x -> x with Not_found -> assert false in - match a, b with - | Some a, Some b -> a < b - | _ -> false - ;; + let r = match a, b with + | Some a, Some b -> a <= b + | _ -> false + in +(* + time_stamp ("L s_t: " ^ string_of_bool r); +*) + r - let modified_before_t_t (_,_,ct, _, _) a b = + let modified_before_t_t (_,_,ct, _, _) a b = +(* + time_stamp ("L t_t: a " ^ F.string_of_target_object a); + time_stamp ("L t_t: b " ^ F.string_of_target_object b); +*) let a = try match Hashtbl.find ct a with | Some _ as x -> x | None -> - match F.mtime_of_target_object a with + match F.mtime_of_target_object a with | Some t as x -> - Hashtbl.remove ct a; + Hashtbl.remove ct a; Hashtbl.add ct a x; x | x -> x with Not_found -> assert false @@ -243,15 +261,24 @@ module Make = functor (F:Format) -> struct | None -> match F.mtime_of_target_object b with | Some t as x -> - Hashtbl.remove ct b; + Hashtbl.remove ct b; 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 r = match a, b with + | Some a, Some b -> +(* + time_stamp ("tt: a " ^ string_of_float a); + time_stamp ("tt: b " ^ string_of_float b); +*) + a <= b + | _ -> false + in +(* + time_stamp ("L t_t: " ^ string_of_bool r); +*) + r let rec purge_unwanted_roots wanted deps = let roots, rest = @@ -317,13 +344,13 @@ module Make = functor (F:Format) -> struct aux [] [] l let rec make_aux root (lo,_,ct, cc, _ as opts) ok deps = - timestamp "filter get_status: begin"; + time_stamp "filter get_status: begin"; let map what = match get_status opts what with | Done _ -> None | Ready b -> Some b in let todo, deps = list_partition_filter_rev map deps in - timestamp "filter get_status: end"; + time_stamp "filter get_status: end"; let todo = let local, remote = List.partition (fun (_,_,froot,_) -> froot = Some root) todo @@ -343,9 +370,9 @@ module Make = functor (F:Format) -> struct | Some froot when froot = root -> Hashtbl.remove ct tgt; Hashtbl.add ct tgt None; - timestamp "building"; + time_stamp "building"; let r = F.build lo file in - timestamp "done"; r + time_stamp "done"; r | Some froot -> make froot [file] | None -> HLog.error ("No root for: "^F.string_of_source_object file); @@ -369,40 +396,48 @@ module Make = functor (F:Format) -> struct and make_one root opts ok what = let lo, _, ct, cc, cd = opts in let t, deps, froot, tgt = what in + let str = F.string_of_source_object t in let map (okd, okt) d = let (_, _, _, tgtd) as whatd = (Hashtbl.find cd d) in - make_one root opts okd whatd, okt && modified_before_t_t opts tgtd tgt + let r = make_one root opts okd whatd in + r, okt && modified_before_t_t opts tgtd tgt in - try ok && Hashtbl.find cc t + time_stamp ("L : processing " ^ str); + try + let r = Hashtbl.find cc t in + time_stamp ("L : " ^ string_of_bool r ^ " " ^ str); + ok && r (* say "already built" *) with Not_found -> let okd, okt = List.fold_left map (true, modified_before_s_t opts t tgt) deps in let res = if okd then if okt then true else - let str = F.string_of_source_object t in match froot with | Some froot when froot = root -> if is_not_ro opts what then begin Hashtbl.remove ct tgt; Hashtbl.add ct tgt None; - timestamp "building"; + time_stamp ("L : BUILDING " ^ str); let res = F.build lo t in - timestamp "done"; res + time_stamp ("L : DONE " ^ str); res end else begin - HLog.warn("Read only baseuri for: "^ str); false + HLog.error ("Read only baseuri for: "^ str^ + ", I won't compile it even if it is out of date"); + false end | Some froot -> make froot [t] | None -> HLog.error ("No root for: " ^ str); false else false in + time_stamp ("L : " ^ string_of_bool res ^ " " ^ str); Hashtbl.add cc t res; ok && res (****************************************************************************) and make root targets = - timestamp "entering"; + time_stamp "L : ENTERING"; HLog.debug ("Entering directory '"^root^"'"); let old_root = Sys.getcwd () in Sys.chdir root; @@ -415,11 +450,21 @@ module Make = functor (F:Format) -> struct let deps = List.map (fun (file,d) -> - let r,tgt = F.root_and_target_of local_options file in + let r,wtgt,rotgt = F.root_and_target_of local_options file in Hashtbl.add caches file (F.mtime_of_source_object file); - Hashtbl.add cachet tgt (F.mtime_of_target_object tgt); - Hashtbl.add cached file (file, d, r, tgt); - (file, d, r, tgt) + (* if a read only target exists, we use that one, otherwise + we use the writeable one that may be compiled *) + let _,_,_, tgt as tuple = + match F.mtime_of_target_object rotgt with + | Some _ as mtime -> + Hashtbl.add cachet rotgt mtime; + (file, d, r, rotgt) + | None -> + Hashtbl.add cachet wtgt (F.mtime_of_target_object wtgt); + (file, d, r, wtgt) + in + Hashtbl.add cached file tuple; + tuple ) deps in @@ -433,7 +478,7 @@ module Make = functor (F:Format) -> struct in HLog.debug ("Leaving directory '"^root^"'"); Sys.chdir old_root; - timestamp "leaving"; + time_stamp "L : LEAVING"; ok ;;