lustrec / src / scheduling.ml @ 684d39e7
History  View  Annotate  Download (9.52 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 Lustre_types 
14 
open Corelang 
15 
open Graph 
16 
open Causality 
17 
open Scheduling_type 
18  
19 
(* Topological sort with a priority for variables belonging in the same equation lhs. 
20 
For variables still unrelated, standard compare is used to choose the minimal element. 
21 
This priority is used since it helps a lot in factorizing generated code. 
22 
Moreover, the dependency graph is browsed in a depthfirst manner whenever possible, 
23 
to improve the behavior of optimization algorithms applied in forthcoming compilation steps. 
24 
In the following functions: 
25 
 [eq_equiv] is the equivalence relation between vars of the same equation lhs 
26 
 [g] the (imperative) graph to be topologically sorted 
27 
 [pending] is the set of unsorted root variables so far, equivalent to the last sorted var 
28 
 [frontier] is the set of unsorted root variables so far, not belonging in [pending] 
29 
 [sort] is the resulting topological order 
30 
*) 
31  
32 
(* Checks whether the currently scheduled variable [choice] 
33 
is an output of a call, possibly among others *) 
34 
let is_call_output choice g = 
35 
List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice) 
36  
37 
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv], 
38 
then removes [v] from [g] 
39 
*) 
40 
let add_successors eq_equiv g v pending frontier = 
41 
let succs_v = IdentDepGraph.succ g v in 
42 
begin 
43 
IdentDepGraph.remove_vertex g v; 
44 
List.iter 
45 
(fun v' > 
46 
if is_graph_root v' g then 
47 
(if eq_equiv v v' then 
48 
pending := ISet.add v' !pending 
49 
else 
50 
frontier := ISet.add v' !frontier) 
51 
) succs_v; 
52 
end 
53  
54 
(* Chooses the next var to be sorted, taking priority into account. 
55 
Modifies [pending] and [frontier] accordingly. 
56 
*) 
57 
let next_element eq_equiv g sort call pending frontier = 
58 
begin 
59 
if ISet.is_empty !pending 
60 
then 
61 
begin 
62 
let choice = ISet.min_elt !frontier in 
63 
(*Format.eprintf "1> %s@." choice;*) 
64 
frontier := ISet.remove choice !frontier; 
65 
let (p, f) = ISet.partition (eq_equiv choice) !frontier in 
66 
pending := p; 
67 
frontier := f; 
68 
call := is_call_output choice g; 
69 
add_successors eq_equiv g choice pending frontier; 
70 
if not (ExprDep.is_ghost_var choice) 
71 
then sort := [choice] :: !sort 
72 
end 
73 
else 
74 
begin 
75 
let choice = ISet.min_elt !pending in 
76 
(*Format.eprintf "2> %s@." choice;*) 
77 
pending := ISet.remove choice !pending; 
78 
add_successors eq_equiv g choice pending frontier; 
79 
if not (ExprDep.is_ghost_var choice) 
80 
then sort := (if !call 
81 
then (choice :: List.hd !sort) :: List.tl !sort 
82 
else [choice] :: !sort) 
83 
end 
84 
end 
85  
86  
87 
(* Topological sort of dependency graph [g], with priority. 
88 
*) 
89 
let topological_sort eq_equiv g = 
90 
let roots = graph_roots g in 
91 
assert (roots <> []); 
92 
let call = ref false in 
93 
let frontier = ref (List.fold_right ISet.add roots ISet.empty) in 
94 
let pending = ref ISet.empty in 
95 
let sorted = ref [] in 
96 
begin 
97 
while not (ISet.is_empty !frontier && ISet.is_empty !pending) 
98 
do 
99 
(*Format.eprintf "frontier = {%a}, pending = {%a}@." 
100 
(fun fmt > ISet.iter (fun e > Format.pp_print_string fmt e)) !frontier 
101 
(fun fmt > ISet.iter (fun e > Format.pp_print_string fmt e)) !pending;*) 
102 
next_element eq_equiv g sorted call pending frontier; 
103 
done; 
104 
IdentDepGraph.clear g; 
105 
!sorted 
106 
end 
107  
108 
(* Filters out normalization variables and renames instance variables to keep things readable, 
109 
in a case of a dependency error *) 
110 
let filter_original n vl = 
111 
List.fold_right (fun v res > 
112 
if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else 
113 
let vdecl = get_node_var v n in 
114 
if vdecl.var_orig then v :: res else res) vl [] 
115  
116 
let schedule_node n = 
117 
(* let node_vars = get_node_vars n in *) 
118 
let eq_equiv = ExprDep.node_eq_equiv n in 
119 
let eq_equiv v1 v2 = 
120 
try 
121 
Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2 
122 
with Not_found > false in 
123  
124 
let n', g = global_dependency n in 
125 

126 
(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs 
127 
compute: coi predecessors of outputs 
128 
warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output) 
129 
DONE ! 
130 
*) 
131  
132 
let gg = IdentDepGraph.copy g in 
133 
let sort = topological_sort eq_equiv g in 
134 
let unused = Liveness.compute_unused_variables n gg in 
135 
let fanin = Liveness.compute_fanin n gg in 
136 
{ node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; } 
137  
138  
139 
let compute_node_reuse_table report = 
140 
let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in 
141 
let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in 
142 
(* 
143 
if !Options.print_reuse 
144 
then 
145 
begin 
146 
Log.report ~level:0 
147 
(fun fmt > 
148 
Format.fprintf fmt 
149 
"OPT:%B@." (try (Hashtbl.iter (fun s1 v2 > if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found > true) 
150 
); 
151 
Log.report ~level:0 
152 
(fun fmt > 
153 
Format.fprintf fmt 
154 
"OPT:clock disjoint map for node %s: %a" 
155 
n'.node_id 
156 
Disjunction.pp_disjoint_map disjoint 
157 
); 
158 
Log.report ~level:0 
159 
(fun fmt > 
160 
Format.fprintf fmt 
161 
"OPT:reuse policy for node %s: %a" 
162 
n'.node_id 
163 
Liveness.pp_reuse_policy reuse 
164 
); 
165 
end; 
166 
*) 
167 
reuse 
168  
169  
170 
let schedule_prog prog = 
171 
List.fold_right ( 
172 
fun top_decl (accu_prog, sch_map) > 
173 
match top_decl.top_decl_desc with 
174 
 Node nd > 
175 
let report = schedule_node nd in 
176 
{top_decl with top_decl_desc = Node report.node}::accu_prog, 
177 
IMap.add nd.node_id report sch_map 
178 
 _ > top_decl::accu_prog, sch_map 
179 
) 
180 
prog 
181 
([],IMap.empty) 
182 

183  
184 
let compute_prog_reuse_table report = 
185 
IMap.map compute_node_reuse_table report 
186  
187 
(* removes inlined local variables from schedule report, 
188 
which are now useless *) 
189 
let remove_node_inlined_locals locals report = 
190 
let is_inlined v = IMap.exists (fun l _ > v = l) locals in 
191 
let schedule' = 
192 
List.fold_right (fun heads q > let heads' = List.filter (fun v > not (is_inlined v)) heads 
193 
in if heads' = [] then q else heads'::q) 
194 
report.schedule [] in 
195 
begin 
196 
IMap.iter (fun v _ > Hashtbl.remove report.fanin_table v) locals; 
197 
IMap.iter (fun v _ > let iv = ExprDep.mk_instance_var v 
198 
in Liveness.replace_in_dep_graph v iv report.dep_graph) locals; 
199 
{ report with schedule = schedule' } 
200 
end 
201  
202 
let remove_prog_inlined_locals removed reuse = 
203 
IMap.mapi (fun id > remove_node_inlined_locals (IMap.find id removed)) reuse 
204  
205 
let pp_eq_schedule fmt vl = 
206 
match vl with 
207 
 [] > assert false 
208 
 [v] > Format.fprintf fmt "%s" v 
209 
 _ > Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v > Format.fprintf fmt "%s" v)) vl 
210 

211 
let pp_schedule fmt node_schs = 
212 
IMap.iter 
213 
(fun nd report > 
214 
Format.fprintf fmt "%s schedule: %a@." 
215 
nd 
216 
(fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule) 
217 
node_schs 
218  
219 
let pp_fanin_table fmt node_schs = 
220 
IMap.iter 
221 
(fun nd report > 
222 
Format.fprintf fmt "%s: %a" nd Liveness.pp_fanin report.fanin_table) 
223 
node_schs 
224  
225 
let pp_dep_graph fmt node_schs = 
226 
IMap.iter 
227 
(fun nd report > 
228 
Format.fprintf fmt "%s dependency graph: %a" nd pp_dep_graph report.dep_graph) 
229 
node_schs 
230  
231 
let pp_warning_unused fmt node_schs = 
232 
IMap.iter 
233 
(fun nd report > 
234 
let unused = report.unused_vars in 
235 
if not (ISet.is_empty unused) 
236 
then 
237 
let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd > nd  _ > assert false in 
238 
ISet.iter 
239 
(fun u > 
240 
let vu = get_node_var u nd in 
241 
if vu.var_orig 
242 
then Format.fprintf fmt " Warning: variable '%s' seems unused@, %a@,@," u Location.pp_loc vu.var_loc) 
243 
unused 
244 
) 
245 
node_schs 
246  
247  
248 
(* Sort eqs according to schedule *) 
249 
(* Sort the set of equations of node [nd] according 
250 
to the computed schedule [sch] 
251 
*) 
252 
let sort_equations_from_schedule nd sch = 
253 
(* Format.eprintf "%s schedule: %a@." *) 
254 
(* nd.node_id *) 
255 
(* (Utils.fprintf_list ~sep:" ; " Scheduling.pp_eq_schedule) sch; *) 
256 
let eqs, auts = get_node_eqs nd in 
257 
assert (auts = []); (* Automata should be expanded by now *) 
258 
let split_eqs = Splitting.tuple_split_eq_list eqs in 
259 
let eqs_rev, remainder = 
260 
List.fold_left 
261 
(fun (accu, node_eqs_remainder) vl > 
262 
if List.exists (fun eq > List.exists (fun v > List.mem v eq.eq_lhs) vl) accu 
263 
then 
264 
(accu, node_eqs_remainder) 
265 
else 
266 
let eq_v, remainder = find_eq vl node_eqs_remainder in 
267 
eq_v::accu, remainder 
268 
) 
269 
([], split_eqs) 
270 
sch 
271 
in 
272 
begin 
273 
if List.length remainder > 0 then ( 
274 
let eqs, auts = get_node_eqs nd in 
275 
assert (auts = []); (* Automata should be expanded by now *) 
276 
Format.eprintf "Equations not used are@.%a@.Full equation set is:@.%a@.@?" 
277 
Printers.pp_node_eqs remainder 
278 
Printers.pp_node_eqs eqs; 
279 
assert false); 
280 
List.rev eqs_rev 
281 
end 
282  
283 
(* Local Variables: *) 
284 
(* compilecommand:"make C .." *) 
285 
(* End: *) 