1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
(***********************************************************************)
(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Original author: Nicolas Pouillard *)
open My_std
open Log
open Format
open Outcome
type backtrace =
| Leaf of Pathname.t
| Choice of backtrace list
| Depth of Pathname.t * backtrace
| Target of string * backtrace
exception Failed of backtrace
exception Circular of Pathname.t * Pathname.t list
let failed target backtrace =
Resource.Cache.resource_failed target;
raise (Failed backtrace)
let rec pp_repeat f (n, s) =
if n > 0 then (pp_print_string f s; pp_repeat f (n - 1, s))
(* Targets must be normalized pathnames.
* Recursive calls are either on input targets
* or dependencies of these targets (returned by Rule.deps_of_rule).
*)
let rec self depth on_the_go_orig target =
let rules = Rule.get_rules () in
let on_the_go = target :: on_the_go_orig in
dprintf 4 "==%a> %a" pp_repeat (depth, "==") Resource.print target;
if List.mem target on_the_go_orig then raise (Circular(target, on_the_go_orig));
match Resource.Cache.resource_state target with
| Resource.Cache.Bbuilt ->
(dprintf 5 "%a already built" Resource.print target)
| Resource.Cache.Bcannot_be_built ->
(dprintf 5 "%a already failed" Resource.print target; failed target (Leaf target))
| Resource.Cache.Bsuspension(s) ->
(dprintf 5 "%a was suspended -> resuming" Resource.print target;
Resource.Cache.resume_suspension s)
| Resource.Cache.Bnot_built_yet ->
if not (Pathname.is_relative target) && Pathname.exists target then
if Resource.Cache.external_is_up_to_date target then ()
else (* perhaps the error can be refined *) failed target (Leaf target)
else
if Resource.exists_in_source_dir target then
Resource.Cache.import_in_build_dir target
else
match List.filter_opt (Rule.can_produce target) rules with
| [] -> failed target (Leaf target)
| matching_rules ->
let rec until_works rs backtraces =
match rs with
| [] -> assert false
| r :: rs ->
try
List.iter (force_self (depth + 1) on_the_go) (Rule.deps_of_rule r);
try
Rule.call (self_firsts (depth + 1) on_the_go) r
with Rule.Failed -> raise (Failed (Leaf target))
with Failed backtrace ->
if rs = [] then failed target (Depth (target, Choice (backtrace :: backtraces)))
else
let () =
match backtrace with
| Depth (top_prod, _) -> Resource.Cache.clear_resource_failed top_prod
| Target _ | Choice _ | Leaf _ -> ()
in until_works rs (backtrace :: backtraces)
in until_works matching_rules []
(* Build the first target that is buildable *)
and self_first depth on_the_go already_failed rs =
match rs with
| [] -> Bad (Failed (Choice already_failed))
| r :: rs ->
try self depth on_the_go r; Good r
with Failed backtrace -> self_first depth on_the_go (backtrace :: already_failed) rs
(* This variant is the one (once partially applied) called the 'build'
* function in the rule actions.
*
* This one takes a list of list of pathnames to build.
* This is a parallel conjonction of sequential alternatives.
* This means that in each sublist of pathnames, the first
* target that is buildable will be picked. The outer list
* denotes that one can build each target in parallel.
*)
and self_firsts depth on_the_go rss =
let results = List.map (self_first depth on_the_go []) rss in
let cmds, thunks =
List.fold_right begin fun res ((acc1, acc2) as acc) ->
match res with
| Bad _ -> acc
| Good res ->
match Resource.Cache.get_optional_resource_suspension res with
| None -> acc
| Some (cmd, thunk) -> (cmd :: acc1, thunk :: acc2)
end results ([], []) in
let count = List.length cmds in
let job_debug = if !Command.jobs = 1 then 10 else 5 in
if count > 1 then dprintf job_debug ">>> PARALLEL: %d" count;
let opt_exn = Command.execute_many cmds in
if count > 1 then dprintf job_debug "<<< PARALLEL";
begin match opt_exn with
| Some(res, exn) ->
List.iter2 (fun res thunk -> if res then thunk ()) res thunks;
Log.finish ~how:`Error ();
raise exn
| None ->
List.iter (fun thunk -> thunk ()) thunks
end;
results
and force_self depth on_the_go x = self depth on_the_go x; Resource.Cache.resume_resource x
let solve = force_self 0 []
let solve_target name rs =
match self_first 0 [] [] rs with
| Good res -> Resource.Cache.resume_resource res; res
| Bad (Failed backtrace) -> raise (Failed (Target (name, backtrace)))
| Bad exn -> raise exn
|
