* http://helm.cs.unibo.it/
*)
-let debug = false;;
+let debug = ref 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 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
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
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 younger_s_t (_,cs, ct, _, _) a b =
+ 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
| 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 younger_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 b;
+ Hashtbl.remove ct a;
Hashtbl.add ct a x; x
| x -> x
with Not_found -> assert false
| 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 =
| Some root -> not (F.is_readonly_buri_of opts f)
| None -> assert false
;;
-
+(* FG: Old sorting algorithm ************************************************)
+(*
let rec get_status opts what =
let _, _, _, cc, cd = opts in
let t, dependencies, root, tgt = what in
begin match st, get_status opts whatd with
| _, Done false -> Hashtbl.add cc t false; Done false
| Done true, Done true ->
- if younger_t_t opts tgt tgtd then Ready true else Done true
+ if modified_before_t_t opts tgt tgtd then Ready true else Done true
(* 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") *)
| Done true, Ready _ -> Ready false
| Ready true, Ready _ -> Ready false
| _ -> st
end
in
- let st = if younger_s_t opts t tgt then Done true else Ready true in
+ let st = if modified_before_s_t opts t tgt then Done true else Ready true in
match List.fold_left map st dependencies with
| Done true -> Hashtbl.add cc t true; Done true
(* say(F.string_of_source_object t^" is built" *)
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
let rc =
match froot with
| Some froot when froot = root ->
- Hashtbl.remove ct tgt;
+ 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);
end
else
ok
+*)
+(* FG: new sorting algorithm ************************************************)
+
+ let rec make_aux root opts ok deps =
+ List.fold_left (make_one root opts) ok deps
+
+ 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
+ let r = make_one root opts okd whatd in
+ r, okt && modified_before_t_t opts tgtd tgt
+ in
+ 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
+ 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;
+ time_stamp ("L : BUILDING " ^ str);
+ let res = F.build lo t in
+ time_stamp ("L : DONE " ^ str); res
+ end else begin
+ 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";
+ and make root targets =
+ time_stamp "L : ENTERING";
HLog.debug ("Entering directory '"^root^"'");
let old_root = Sys.getcwd () in
Sys.chdir root;
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
in
HLog.debug ("Leaving directory '"^root^"'");
Sys.chdir old_root;
- timestamp "leaving";
+ time_stamp "L : LEAVING";
ok
;;