lustrec / src / scheduling.ml @ 6a1a01d2
History  View  Annotate  Download (7.63 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 = Disjunction.clock_disjoint_map node_vars in 
157 

158 
Log.report ~level:2 
159 
(fun fmt > 
160 
Format.fprintf fmt 
161 
"clock disjoint map for node %s: %a" 
162 
n'.node_id 
163 
Disjunction.pp_disjoint_map disjoint 
164 
); 
165  
166 
let reuse = Liveness.compute_reuse_policy n sort disjoint gg in 
167 
Log.report ~level:2 
168 
(fun fmt > 
169 
Format.fprintf fmt 
170 
"reuse policy for node %s: %a" 
171 
n'.node_id 
172 
Liveness.pp_reuse_policy reuse 
173 
); 
174 

175 
n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse } 
176 
with (Causality.Cycle vl) as exc > 
177 
let vl = filter_original n vl in 
178 
pp_error Format.err_formatter vl; 
179 
raise exc 
180  
181 
let schedule_prog prog = 
182 
List.fold_right ( 
183 
fun top_decl (accu_prog, sch_map) > 
184 
match top_decl.top_decl_desc with 
185 
 Node nd > 
186 
let nd', report = schedule_node nd in 
187 
{top_decl with top_decl_desc = Node nd'}::accu_prog, 
188 
IMap.add nd.node_id report sch_map 
189 
 _ > top_decl::accu_prog, sch_map 
190 
) 
191 
prog 
192 
([],IMap.empty) 
193  
194 
let pp_eq_schedule fmt vl = 
195 
match vl with 
196 
 [] > assert false 
197 
 [v] > Format.fprintf fmt "%s" v 
198 
 _ > Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v > Format.fprintf fmt "%s" v)) vl 
199 

200 
let pp_schedule fmt node_schs = 
201 
IMap.iter 
202 
(fun nd report > 
203 
Format.fprintf fmt "%s schedule: %a@." 
204 
nd 
205 
(fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule) 
206 
node_schs 
207  
208 
let pp_fanin_table fmt node_schs = 
209 
IMap.iter 
210 
(fun nd report > 
211 
Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table) 
212 
node_schs 
213  
214 
let pp_warning_unused fmt node_schs = 
215 
IMap.iter 
216 
(fun nd report > 
217 
let unused = report.unused_vars in 
218 
if not (ISet.is_empty unused) 
219 
then 
220 
let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd > nd  _ > assert false in 
221 
ISet.iter 
222 
(fun u > 
223 
Format.fprintf fmt "Warning: variable '%s' seems unused@.%a@." 
224 
u 
225 
Location.pp_loc (get_node_var u nd).var_loc) 
226 
unused 
227 
) 
228 
node_schs 
229  
230 
(* Local Variables: *) 
231 
(* compilecommand:"make C .." *) 
232 
(* End: *) 