- 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
- in
- remote @ local
- in
- List.fold_left
- (fun (c,f) (file,_,froot,tgt) ->
+ let is_not_ro (opts,_,_,_,_) (f,_,r,_) =
+ match r with
+ | 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
+ try Done (Hashtbl.find cc t)
+(* say "already built" *)
+ with Not_found ->
+ let map st d = match st with
+ | Done false -> st
+ | Ready false -> st
+ | _ ->
+ let whatd = Hashtbl.find cd d in
+ let _, _, _, tgtd = whatd in
+ begin match st, get_status opts whatd with
+ | _, Done false -> Hashtbl.add cc t false; Done false
+ | Done true, 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
+(* say (F.string_of_source_object t^" depends on "^ F.string_of_source_object (fst4 unsat)^ " that is not built, thus is not ready") *)
+ | Ready true, Done true -> Ready true
+ | _ -> st
+ end
+ 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" *)
+ | st -> st
+
+ let list_partition_filter_rev filter l =
+ let rec aux l1 l2 = function
+ | [] -> l1, l2
+ | hd :: tl ->
+ begin match filter hd with
+ | None -> aux l1 l2 tl
+ | Some true -> aux (hd :: l1) l2 tl
+ | Some false -> aux l1 (hd :: l2) tl
+ end
+ in
+ aux [] [] l
+
+ let rec make_aux root (lo,_,ct, cc, _ as opts) ok deps =
+ 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
+ time_stamp "filter get_status: end";
+ let todo =
+ let local, remote =
+ List.partition (fun (_,_,froot,_) -> froot = Some root) todo
+ in
+ let local, skipped = List.partition (is_not_ro opts) local in
+ List.iter
+ (fun x ->
+ HLog.warn("Read only baseuri for: "^F.string_of_source_object(fst4 x)))
+ skipped;
+ remote @ local
+ in
+ if todo <> [] then begin
+ let ok = List.fold_left
+ (fun ok (file,_,froot,tgt) ->