lustrec / src / scheduling.ml @ d50b0dc0
History | View | Annotate | Download (8.04 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 |
(* a schedule computed wrt the dependency graph *) |
21 |
schedule : ident list list; |
22 |
(* the set of unused variables (no output or mem depends on them) *) |
23 |
unused_vars : ISet.t; |
24 |
(* the table mapping each local var to its in-degree *) |
25 |
fanin_table : (ident, int) Hashtbl.t; |
26 |
(* the table mapping each assignment to a reusable variable *) |
27 |
reuse_table : (ident, var_decl) Hashtbl.t |
28 |
} |
29 |
|
30 |
(* Topological sort with a priority for variables belonging in the same equation lhs. |
31 |
For variables still unrelated, standard compare is used to choose the minimal element. |
32 |
This priority is used since it helps a lot in factorizing generated code. |
33 |
Moreover, the dependency graph is browsed in a depth-first manner whenever possible, |
34 |
to improve the behavior of optimization algorithms applied in forthcoming compilation steps. |
35 |
In the following functions: |
36 |
- [eq_equiv] is the equivalence relation between vars of the same equation lhs |
37 |
- [g] the (imperative) graph to be topologically sorted |
38 |
- [pending] is the set of unsorted root variables so far, equivalent to the last sorted var |
39 |
- [frontier] is the set of unsorted root variables so far, not belonging in [pending] |
40 |
- [sort] is the resulting topological order |
41 |
*) |
42 |
|
43 |
(* Checks whether the currently scheduled variable [choice] |
44 |
is an output of a call, possibly among others *) |
45 |
let is_call_output choice g = |
46 |
List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice) |
47 |
|
48 |
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv], |
49 |
then removes [v] from [g] |
50 |
*) |
51 |
let add_successors eq_equiv g v pending frontier = |
52 |
let succs_v = IdentDepGraph.succ g v in |
53 |
begin |
54 |
IdentDepGraph.remove_vertex g v; |
55 |
List.iter |
56 |
(fun v' -> |
57 |
if is_graph_root v' g then |
58 |
(if eq_equiv v v' then |
59 |
pending := ISet.add v' !pending |
60 |
else |
61 |
frontier := ISet.add v' !frontier) |
62 |
) succs_v; |
63 |
end |
64 |
|
65 |
(* Chooses the next var to be sorted, taking priority into account. |
66 |
Modifies [pending] and [frontier] accordingly. |
67 |
*) |
68 |
let next_element eq_equiv g sort call pending frontier = |
69 |
begin |
70 |
if ISet.is_empty !pending |
71 |
then |
72 |
begin |
73 |
let choice = ISet.min_elt !frontier in |
74 |
(*Format.eprintf "-1-> %s@." choice;*) |
75 |
frontier := ISet.remove choice !frontier; |
76 |
let (p, f) = ISet.partition (eq_equiv choice) !frontier in |
77 |
pending := p; |
78 |
frontier := f; |
79 |
call := is_call_output choice g; |
80 |
add_successors eq_equiv g choice pending frontier; |
81 |
if not (ExprDep.is_ghost_var choice) |
82 |
then sort := [choice] :: !sort |
83 |
end |
84 |
else |
85 |
begin |
86 |
let choice = ISet.min_elt !pending in |
87 |
(*Format.eprintf "-2-> %s@." choice;*) |
88 |
pending := ISet.remove choice !pending; |
89 |
add_successors eq_equiv g choice pending frontier; |
90 |
if not (ExprDep.is_ghost_var choice) |
91 |
then sort := (if !call |
92 |
then (choice :: List.hd !sort) :: List.tl !sort |
93 |
else [choice] :: !sort) |
94 |
end |
95 |
end |
96 |
|
97 |
|
98 |
(* Topological sort of dependency graph [g], with priority. |
99 |
*) |
100 |
let topological_sort eq_equiv g = |
101 |
let roots = graph_roots g in |
102 |
assert (roots <> []); |
103 |
let call = ref false in |
104 |
let frontier = ref (List.fold_right ISet.add roots ISet.empty) in |
105 |
let pending = ref ISet.empty in |
106 |
let sorted = ref [] in |
107 |
begin |
108 |
while not (ISet.is_empty !frontier && ISet.is_empty !pending) |
109 |
do |
110 |
(*Format.eprintf "frontier = {%a}, pending = {%a}@." |
111 |
(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier |
112 |
(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*) |
113 |
next_element eq_equiv g sorted call pending frontier; |
114 |
done; |
115 |
IdentDepGraph.clear g; |
116 |
!sorted |
117 |
end |
118 |
|
119 |
(* Filters out normalization variables and renames instance variables to keep things readable, |
120 |
in a case of a dependency error *) |
121 |
let filter_original n vl = |
122 |
List.fold_right (fun v res -> |
123 |
if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else |
124 |
let vdecl = get_node_var v n in |
125 |
if vdecl.var_orig then v :: res else res) vl [] |
126 |
|
127 |
let schedule_node n = |
128 |
let node_vars = get_node_vars n in |
129 |
try |
130 |
let eq_equiv = ExprDep.node_eq_equiv n in |
131 |
let eq_equiv v1 v2 = |
132 |
try |
133 |
Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2 |
134 |
with Not_found -> false in |
135 |
|
136 |
let n', g = global_dependency n in |
137 |
Log.report ~level:5 |
138 |
(fun fmt -> |
139 |
Format.fprintf fmt |
140 |
"dependency graph for node %s: %a" |
141 |
n'.node_id |
142 |
pp_dep_graph g |
143 |
); |
144 |
|
145 |
(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs |
146 |
compute: coi predecessors of outputs |
147 |
warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output) |
148 |
DONE ! |
149 |
*) |
150 |
|
151 |
let gg = IdentDepGraph.copy g in |
152 |
let sort = topological_sort eq_equiv g in |
153 |
let unused = Liveness.compute_unused_variables n gg in |
154 |
let fanin = Liveness.compute_fanin n gg in |
155 |
|
156 |
let (disjoint, reuse) = |
157 |
if !Options.optimization >= 3 |
158 |
then |
159 |
let disjoint = Disjunction.clock_disjoint_map node_vars in |
160 |
(disjoint, |
161 |
Liveness.compute_reuse_policy n sort disjoint gg) |
162 |
else |
163 |
(Hashtbl.create 1, |
164 |
Hashtbl.create 1) 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 |
n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse } |
190 |
with (Causality.Cycle vl) as exc -> |
191 |
let vl = filter_original n vl in |
192 |
pp_error Format.err_formatter vl; |
193 |
raise exc |
194 |
|
195 |
let schedule_prog prog = |
196 |
List.fold_right ( |
197 |
fun top_decl (accu_prog, sch_map) -> |
198 |
match top_decl.top_decl_desc with |
199 |
| Node nd -> |
200 |
let nd', report = schedule_node nd in |
201 |
{top_decl with top_decl_desc = Node nd'}::accu_prog, |
202 |
IMap.add nd.node_id report sch_map |
203 |
| _ -> top_decl::accu_prog, sch_map |
204 |
) |
205 |
prog |
206 |
([],IMap.empty) |
207 |
|
208 |
let pp_eq_schedule fmt vl = |
209 |
match vl with |
210 |
| [] -> assert false |
211 |
| [v] -> Format.fprintf fmt "%s" v |
212 |
| _ -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl |
213 |
|
214 |
let pp_schedule fmt node_schs = |
215 |
IMap.iter |
216 |
(fun nd report -> |
217 |
Format.fprintf fmt "%s schedule: %a@." |
218 |
nd |
219 |
(fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule) |
220 |
node_schs |
221 |
|
222 |
let pp_fanin_table fmt node_schs = |
223 |
IMap.iter |
224 |
(fun nd report -> |
225 |
Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table) |
226 |
node_schs |
227 |
|
228 |
let pp_warning_unused fmt node_schs = |
229 |
IMap.iter |
230 |
(fun nd report -> |
231 |
let unused = report.unused_vars in |
232 |
if not (ISet.is_empty unused) |
233 |
then |
234 |
let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in |
235 |
ISet.iter |
236 |
(fun u -> |
237 |
let vu = get_node_var u nd in |
238 |
if vu.var_orig |
239 |
then Format.fprintf fmt "Warning: variable '%s' seems unused@.%a@." u Location.pp_loc vu.var_loc) |
240 |
unused |
241 |
) |
242 |
node_schs |
243 |
|
244 |
(* Local Variables: *) |
245 |
(* compile-command:"make -C .." *) |
246 |
(* End: *) |