lustrec / src / scheduling.ml @ 6aeb3388
History  View  Annotate  Download (7.19 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.for_all 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 
let schedule_node n = 
120 
try 
121 
let eq_equiv = ExprDep.node_eq_equiv n in 
122 
let eq_equiv v1 v2 = 
123 
try 
124 
Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2 
125 
with Not_found > false in 
126  
127 
let n', g = global_dependency n in 
128 
Log.report ~level:5 
129 
(fun fmt > 
130 
Format.fprintf fmt 
131 
"dependency graph for node %s: %a" 
132 
n'.node_id 
133 
pp_dep_graph g 
134 
); 
135 

136 
(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs 
137 
compute: coi predecessors of outputs 
138 
warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output) 
139 
DONE ! 
140 
*) 
141  
142 
let gg = IdentDepGraph.copy g in 
143 
let sort = topological_sort eq_equiv g in 
144 
let unused = Liveness.compute_unused_variables n gg in 
145 
let fanin = Liveness.compute_fanin n gg in 
146  
147 
let disjoint = Disjunction.clock_disjoint_map (get_node_vars n) in 
148 

149 
Log.report ~level:2 
150 
(fun fmt > 
151 
Format.fprintf fmt 
152 
"clock disjoint map for node %s: %a" 
153 
n'.node_id 
154 
Disjunction.pp_disjoint_map disjoint 
155 
); 
156  
157 
let reuse = Liveness.compute_reuse_policy n sort disjoint gg in 
158 
Log.report ~level:2 
159 
(fun fmt > 
160 
Format.fprintf fmt 
161 
"reuse policy for node %s: %a" 
162 
n'.node_id 
163 
Liveness.pp_reuse_policy reuse 
164 
); 
165 

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

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