lustrec / src / scheduling.ml @ e2068500
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 indegree *) 
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 depthfirst 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 
(* compilecommand:"make C .." *) 
246 
(* End: *) 