lustrec / src / scheduling.ml @ b38ffff3
History | View | Annotate | Download (7.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 |
In the following functions: |
34 |
- [eq_equiv] is the equivalence relation between vars of the same equation lhs |
35 |
- [g] the (imperative) graph to be topologically sorted |
36 |
- [pending] is the set of unsorted root variables so far, equivalent to the last sorted var |
37 |
- [frontier] is the set of unsorted root variables so far, not belonging in [pending] |
38 |
- [sort] is the resulting topological order |
39 |
*) |
40 |
|
41 |
(* Checks whether the currently scheduled variable [choice] |
42 |
is an output of a call, possibly among others *) |
43 |
let is_call_output choice g = |
44 |
List.for_all ExprDep.is_instance_var (IdentDepGraph.succ g choice) |
45 |
|
46 |
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv], |
47 |
then removes [v] from [g] |
48 |
*) |
49 |
let add_successors eq_equiv g v pending frontier = |
50 |
let succs_v = IdentDepGraph.succ g v in |
51 |
begin |
52 |
IdentDepGraph.remove_vertex g v; |
53 |
List.iter |
54 |
(fun v' -> |
55 |
if is_graph_root v' g then |
56 |
(if eq_equiv v v' then |
57 |
pending := ISet.add v' !pending |
58 |
else |
59 |
frontier := ISet.add v' !frontier) |
60 |
) succs_v; |
61 |
end |
62 |
|
63 |
(* Chooses the next var to be sorted, taking priority into account. |
64 |
Modifies [pending] and [frontier] accordingly. |
65 |
*) |
66 |
let next_element eq_equiv g sort call pending frontier = |
67 |
begin |
68 |
if ISet.is_empty !pending |
69 |
then |
70 |
begin |
71 |
let choice = ISet.min_elt !frontier in |
72 |
(*Format.eprintf "-1-> %s@." choice;*) |
73 |
frontier := ISet.remove choice !frontier; |
74 |
let (p, f) = ISet.partition (eq_equiv choice) !frontier in |
75 |
pending := p; |
76 |
frontier := f; |
77 |
call := is_call_output choice g; |
78 |
add_successors eq_equiv g choice pending frontier; |
79 |
if not (ExprDep.is_ghost_var choice) |
80 |
then sort := [choice] :: !sort |
81 |
end |
82 |
else |
83 |
begin |
84 |
let choice = ISet.min_elt !pending in |
85 |
(*Format.eprintf "-2-> %s@." choice;*) |
86 |
pending := ISet.remove choice !pending; |
87 |
add_successors eq_equiv g choice pending frontier; |
88 |
if not (ExprDep.is_ghost_var choice) |
89 |
then sort := (if !call |
90 |
then (choice :: List.hd !sort) :: List.tl !sort |
91 |
else [choice] :: !sort) |
92 |
end |
93 |
end |
94 |
|
95 |
|
96 |
(* Topological sort of dependency graph [g], with priority. |
97 |
*) |
98 |
let topological_sort eq_equiv g = |
99 |
let roots = graph_roots g in |
100 |
assert (roots <> []); |
101 |
let call = ref false in |
102 |
let frontier = ref (List.fold_right ISet.add roots ISet.empty) in |
103 |
let pending = ref ISet.empty in |
104 |
let sorted = ref [] in |
105 |
begin |
106 |
while not (ISet.is_empty !frontier && ISet.is_empty !pending) |
107 |
do |
108 |
(*Format.eprintf "frontier = {%a}, pending = {%a}@." |
109 |
(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier |
110 |
(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*) |
111 |
next_element eq_equiv g sorted call pending frontier; |
112 |
done; |
113 |
IdentDepGraph.clear g; |
114 |
!sorted |
115 |
end |
116 |
|
117 |
let schedule_node n = |
118 |
try |
119 |
let eq_equiv = ExprDep.node_eq_equiv n in |
120 |
let eq_equiv v1 v2 = |
121 |
try |
122 |
Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2 |
123 |
with Not_found -> false in |
124 |
|
125 |
let n', g = global_dependency n in |
126 |
Log.report ~level:5 |
127 |
(fun fmt -> |
128 |
Format.fprintf fmt |
129 |
"dependency graph for node %s: %a" |
130 |
n'.node_id |
131 |
pp_dep_graph g |
132 |
); |
133 |
|
134 |
(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs |
135 |
compute: coi predecessors of outputs |
136 |
warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output) |
137 |
DONE ! |
138 |
*) |
139 |
|
140 |
let gg = IdentDepGraph.copy g in |
141 |
let sort = topological_sort eq_equiv g in |
142 |
let unused = Liveness.compute_unused_variables n gg in |
143 |
let fanin = Liveness.compute_fanin n gg in |
144 |
|
145 |
let disjoint = Disjunction.clock_disjoint_map (get_node_vars n) in |
146 |
|
147 |
Log.report ~level:2 |
148 |
(fun fmt -> |
149 |
Format.fprintf fmt |
150 |
"clock disjoint map for node %s: %a" |
151 |
n'.node_id |
152 |
Disjunction.pp_disjoint_map disjoint |
153 |
); |
154 |
|
155 |
let reuse = Hashtbl.create 23 (*Liveness.compute_reuse_policy n sort disjoint gg*) in |
156 |
Log.report ~level:2 |
157 |
(fun fmt -> |
158 |
Format.fprintf fmt |
159 |
"reuse policy for node %s: %a" |
160 |
n'.node_id |
161 |
Liveness.pp_reuse_policy reuse |
162 |
); |
163 |
|
164 |
n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse } |
165 |
with (Causality.Cycle v) as exc -> |
166 |
pp_error Format.err_formatter v; |
167 |
raise exc |
168 |
|
169 |
let schedule_prog prog = |
170 |
List.fold_right ( |
171 |
fun top_decl (accu_prog, sch_map) -> |
172 |
match top_decl.top_decl_desc with |
173 |
| Node nd -> |
174 |
let nd', report = schedule_node nd in |
175 |
{top_decl with top_decl_desc = Node nd'}::accu_prog, |
176 |
IMap.add nd.node_id report sch_map |
177 |
| _ -> top_decl::accu_prog, sch_map |
178 |
) |
179 |
prog |
180 |
([],IMap.empty) |
181 |
|
182 |
let pp_eq_schedule fmt vl = |
183 |
match vl with |
184 |
| [] -> assert false |
185 |
| [v] -> Format.fprintf fmt "%s" v |
186 |
| _ -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl |
187 |
|
188 |
let pp_schedule fmt node_schs = |
189 |
IMap.iter |
190 |
(fun nd report -> |
191 |
Format.fprintf fmt "%s schedule: %a@." |
192 |
nd |
193 |
(fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule) |
194 |
node_schs |
195 |
|
196 |
let pp_fanin_table fmt node_schs = |
197 |
IMap.iter |
198 |
(fun nd report -> |
199 |
Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table) |
200 |
node_schs |
201 |
|
202 |
let pp_warning_unused fmt node_schs = |
203 |
IMap.iter |
204 |
(fun nd report -> |
205 |
let unused = report.unused_vars in |
206 |
if not (ISet.is_empty unused) |
207 |
then |
208 |
let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in |
209 |
ISet.iter |
210 |
(fun u -> |
211 |
Format.fprintf fmt "Warning: variable '%s' seems unused@.%a@." |
212 |
u |
213 |
Location.pp_loc (get_node_var u nd).var_loc) |
214 |
unused |
215 |
) |
216 |
node_schs |
217 |
|
218 |
(* Local Variables: *) |
219 |
(* compile-command:"make -C .." *) |
220 |
(* End: *) |