lustrec / src / scheduling.ml @ 2823bc51
History | View | Annotate | Download (9.1 KB)
1 |
(********************************************************************) |
---|---|
2 |
(* *) |
3 |
(* The LustreC compiler toolset / The LustreC Development Team *) |
4 |
(* Copyright 2012 - -- ONERA - CNRS - INPT *) |
5 |
(* *) |
6 |
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) |
7 |
(* under the terms of the GNU Lesser General Public License *) |
8 |
(* version 2.1. *) |
9 |
(* *) |
10 |
(********************************************************************) |
11 |
|
12 |
open Utils |
13 |
open LustreSpec |
14 |
open Corelang |
15 |
open Graph |
16 |
open Causality |
17 |
|
18 |
type schedule_report = |
19 |
{ |
20 |
(* the scheduled node *) |
21 |
node : node_desc; |
22 |
(* a schedule computed wrt the dependency graph *) |
23 |
schedule : ident list list; |
24 |
(* the set of unused variables (no output or mem depends on them) *) |
25 |
unused_vars : ISet.t; |
26 |
(* the table mapping each local var to its in-degree *) |
27 |
fanin_table : (ident, int) Hashtbl.t; |
28 |
(* the dependency graph *) |
29 |
dep_graph : IdentDepGraph.t; |
30 |
(* the table mapping each assignment to a reusable variable *) |
31 |
(*reuse_table : (ident, var_decl) Hashtbl.t*) |
32 |
} |
33 |
|
34 |
(* Topological sort with a priority for variables belonging in the same equation lhs. |
35 |
For variables still unrelated, standard compare is used to choose the minimal element. |
36 |
This priority is used since it helps a lot in factorizing generated code. |
37 |
Moreover, the dependency graph is browsed in a depth-first manner whenever possible, |
38 |
to improve the behavior of optimization algorithms applied in forthcoming compilation steps. |
39 |
In the following functions: |
40 |
- [eq_equiv] is the equivalence relation between vars of the same equation lhs |
41 |
- [g] the (imperative) graph to be topologically sorted |
42 |
- [pending] is the set of unsorted root variables so far, equivalent to the last sorted var |
43 |
- [frontier] is the set of unsorted root variables so far, not belonging in [pending] |
44 |
- [sort] is the resulting topological order |
45 |
*) |
46 |
|
47 |
(* Checks whether the currently scheduled variable [choice] |
48 |
is an output of a call, possibly among others *) |
49 |
let is_call_output choice g = |
50 |
List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice) |
51 |
|
52 |
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv], |
53 |
then removes [v] from [g] |
54 |
*) |
55 |
let add_successors eq_equiv g v pending frontier = |
56 |
let succs_v = IdentDepGraph.succ g v in |
57 |
begin |
58 |
IdentDepGraph.remove_vertex g v; |
59 |
List.iter |
60 |
(fun v' -> |
61 |
if is_graph_root v' g then |
62 |
(if eq_equiv v v' then |
63 |
pending := ISet.add v' !pending |
64 |
else |
65 |
frontier := ISet.add v' !frontier) |
66 |
) succs_v; |
67 |
end |
68 |
|
69 |
(* Chooses the next var to be sorted, taking priority into account. |
70 |
Modifies [pending] and [frontier] accordingly. |
71 |
*) |
72 |
let next_element eq_equiv g sort call pending frontier = |
73 |
begin |
74 |
if ISet.is_empty !pending |
75 |
then |
76 |
begin |
77 |
let choice = ISet.min_elt !frontier in |
78 |
(*Format.eprintf "-1-> %s@." choice;*) |
79 |
frontier := ISet.remove choice !frontier; |
80 |
let (p, f) = ISet.partition (eq_equiv choice) !frontier in |
81 |
pending := p; |
82 |
frontier := f; |
83 |
call := is_call_output choice g; |
84 |
add_successors eq_equiv g choice pending frontier; |
85 |
if not (ExprDep.is_ghost_var choice) |
86 |
then sort := [choice] :: !sort |
87 |
end |
88 |
else |
89 |
begin |
90 |
let choice = ISet.min_elt !pending in |
91 |
(*Format.eprintf "-2-> %s@." choice;*) |
92 |
pending := ISet.remove choice !pending; |
93 |
add_successors eq_equiv g choice pending frontier; |
94 |
if not (ExprDep.is_ghost_var choice) |
95 |
then sort := (if !call |
96 |
then (choice :: List.hd !sort) :: List.tl !sort |
97 |
else [choice] :: !sort) |
98 |
end |
99 |
end |
100 |
|
101 |
|
102 |
(* Topological sort of dependency graph [g], with priority. |
103 |
*) |
104 |
let topological_sort eq_equiv g = |
105 |
let roots = graph_roots g in |
106 |
assert (roots <> []); |
107 |
let call = ref false in |
108 |
let frontier = ref (List.fold_right ISet.add roots ISet.empty) in |
109 |
let pending = ref ISet.empty in |
110 |
let sorted = ref [] in |
111 |
begin |
112 |
while not (ISet.is_empty !frontier && ISet.is_empty !pending) |
113 |
do |
114 |
(*Format.eprintf "frontier = {%a}, pending = {%a}@." |
115 |
(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier |
116 |
(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*) |
117 |
next_element eq_equiv g sorted call pending frontier; |
118 |
done; |
119 |
IdentDepGraph.clear g; |
120 |
!sorted |
121 |
end |
122 |
|
123 |
(* Filters out normalization variables and renames instance variables to keep things readable, |
124 |
in a case of a dependency error *) |
125 |
let filter_original n vl = |
126 |
List.fold_right (fun v res -> |
127 |
if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else |
128 |
let vdecl = get_node_var v n in |
129 |
if vdecl.var_orig then v :: res else res) vl [] |
130 |
|
131 |
let schedule_node n = |
132 |
(* let node_vars = get_node_vars n in *) |
133 |
try |
134 |
let eq_equiv = ExprDep.node_eq_equiv n in |
135 |
let eq_equiv v1 v2 = |
136 |
try |
137 |
Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2 |
138 |
with Not_found -> false in |
139 |
|
140 |
let n', g = global_dependency n in |
141 |
|
142 |
(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs |
143 |
compute: coi predecessors of outputs |
144 |
warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output) |
145 |
DONE ! |
146 |
*) |
147 |
|
148 |
let gg = IdentDepGraph.copy g in |
149 |
let sort = topological_sort eq_equiv g in |
150 |
let unused = Liveness.compute_unused_variables n gg in |
151 |
let fanin = Liveness.compute_fanin n gg in |
152 |
{ node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; } |
153 |
|
154 |
with (Causality.Error err) as exc -> |
155 |
match err with |
156 |
| DataCycle vl -> |
157 |
let _ (*vl*) = filter_original n vl in |
158 |
Causality.pp_error Format.err_formatter err; |
159 |
raise exc |
160 |
| _ -> raise exc |
161 |
|
162 |
let compute_node_reuse_table report = |
163 |
let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in |
164 |
let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in |
165 |
(* |
166 |
if !Options.print_reuse |
167 |
then |
168 |
begin |
169 |
Log.report ~level:0 |
170 |
(fun fmt -> |
171 |
Format.fprintf fmt |
172 |
"OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found -> true) |
173 |
); |
174 |
Log.report ~level:0 |
175 |
(fun fmt -> |
176 |
Format.fprintf fmt |
177 |
"OPT:clock disjoint map for node %s: %a" |
178 |
n'.node_id |
179 |
Disjunction.pp_disjoint_map disjoint |
180 |
); |
181 |
Log.report ~level:0 |
182 |
(fun fmt -> |
183 |
Format.fprintf fmt |
184 |
"OPT:reuse policy for node %s: %a" |
185 |
n'.node_id |
186 |
Liveness.pp_reuse_policy reuse |
187 |
); |
188 |
end; |
189 |
*) |
190 |
reuse |
191 |
|
192 |
|
193 |
let schedule_prog prog = |
194 |
List.fold_right ( |
195 |
fun top_decl (accu_prog, sch_map) -> |
196 |
match top_decl.top_decl_desc with |
197 |
| Node nd -> |
198 |
let report = schedule_node nd in |
199 |
{top_decl with top_decl_desc = Node report.node}::accu_prog, |
200 |
IMap.add nd.node_id report sch_map |
201 |
| _ -> top_decl::accu_prog, sch_map |
202 |
) |
203 |
prog |
204 |
([],IMap.empty) |
205 |
|
206 |
|
207 |
let compute_prog_reuse_table report = |
208 |
IMap.map compute_node_reuse_table report |
209 |
|
210 |
(* removes inlined local variables from schedule report, |
211 |
which are now useless *) |
212 |
let remove_node_inlined_locals locals report = |
213 |
let is_inlined v = IMap.exists (fun l _ -> v = l) locals in |
214 |
let schedule' = |
215 |
List.fold_right (fun heads q -> let heads' = List.filter (fun v -> not (is_inlined v)) heads |
216 |
in if heads' = [] then q else heads'::q) |
217 |
report.schedule [] in |
218 |
begin |
219 |
IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals; |
220 |
IMap.iter (fun v _ -> let iv = ExprDep.mk_instance_var v |
221 |
in Liveness.replace_in_dep_graph v iv report.dep_graph) locals; |
222 |
{ report with schedule = schedule' } |
223 |
end |
224 |
|
225 |
let remove_prog_inlined_locals removed reuse = |
226 |
IMap.mapi (fun id -> remove_node_inlined_locals (IMap.find id removed)) reuse |
227 |
|
228 |
let pp_eq_schedule fmt vl = |
229 |
match vl with |
230 |
| [] -> assert false |
231 |
| [v] -> Format.fprintf fmt "%s" v |
232 |
| _ -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl |
233 |
|
234 |
let pp_schedule fmt node_schs = |
235 |
IMap.iter |
236 |
(fun nd report -> |
237 |
Format.fprintf fmt "%s schedule: %a@." |
238 |
nd |
239 |
(fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule) |
240 |
node_schs |
241 |
|
242 |
let pp_fanin_table fmt node_schs = |
243 |
IMap.iter |
244 |
(fun nd report -> |
245 |
Format.fprintf fmt "%s: %a" nd Liveness.pp_fanin report.fanin_table) |
246 |
node_schs |
247 |
|
248 |
let pp_dep_graph fmt node_schs = |
249 |
IMap.iter |
250 |
(fun nd report -> |
251 |
Format.fprintf fmt "%s dependency graph: %a" nd pp_dep_graph report.dep_graph) |
252 |
node_schs |
253 |
|
254 |
let pp_warning_unused fmt node_schs = |
255 |
IMap.iter |
256 |
(fun nd report -> |
257 |
let unused = report.unused_vars in |
258 |
if not (ISet.is_empty unused) |
259 |
then |
260 |
let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in |
261 |
ISet.iter |
262 |
(fun u -> |
263 |
let vu = get_node_var u nd in |
264 |
if vu.var_orig |
265 |
then Format.fprintf fmt " Warning: variable '%s' seems unused@, %a@,@," u Location.pp_loc vu.var_loc) |
266 |
unused |
267 |
) |
268 |
node_schs |
269 |
|
270 |
|
271 |
(* Local Variables: *) |
272 |
(* compile-command:"make -C .." *) |
273 |
(* End: *) |