Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / scheduling.ml @ 15003796

History | View | Annotate | Download (9.4 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
   Moreover, the dependency graph is browsed in a depth-first 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

    
209
(* Sort the set of equations of node [nd] according
210
   to the computed schedule [sch]
211
*)
212
let sort_equations_from_schedule nd sch =
213
  let find_eq xl eqs =
214
    let rec aux accu eqs =
215
      match eqs with
216
      | [] ->
217
	begin
218
	  Format.eprintf "Looking for variables %a in the following equations@.%a@."
219
	    (Utils.fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) xl
220
	    Printers.pp_node_eqs eqs;
221
	  assert false
222
	end
223
      | hd::tl ->
224
	if List.exists (fun x -> List.mem x hd.eq_lhs) xl then hd, accu@tl else aux (hd::accu) tl
225
    in
226
    aux [] eqs
227
  in
228
  (*Format.eprintf "%s schedule: %a@."
229
    nd.node_id
230
    (Utils.fprintf_list ~sep:" ; " Scheduling.pp_eq_schedule) sch;*)
231
  let split_eqs = Splitting.tuple_split_eq_list (get_node_eqs nd) in
232
  let eqs_rev, remainder =
233
    List.fold_left
234
      (fun (accu, node_eqs_remainder) vl ->
235
       if List.exists (fun eq -> List.exists (fun v -> List.mem v eq.eq_lhs) vl) accu
236
       then
237
	 (accu, node_eqs_remainder)
238
       else
239
	 let eq_v, remainder = find_eq vl node_eqs_remainder in
240
	 eq_v::accu, remainder
241
      )
242
      ([], split_eqs)
243
      sch
244
  in
245
  begin
246
    if List.length remainder > 0 then (
247
      Format.eprintf "Equations not used are@.%a@.Full equation set is:@.%a@.@?"
248
		     Printers.pp_node_eqs remainder
249
      		     Printers.pp_node_eqs (get_node_eqs nd);
250
      assert false);
251
    List.rev eqs_rev
252
  end
253

    
254

    
255
let pp_eq_schedule fmt vl =
256
  match vl with
257
  | []  -> assert false
258
  | [v] -> Format.fprintf fmt "%s" v
259
  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
260
 
261
let pp_schedule fmt node_schs =
262
 IMap.iter
263
   (fun nd report ->
264
     Format.fprintf fmt "%s schedule: %a@."
265
       nd
266
       (fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)
267
   node_schs
268

    
269
let pp_fanin_table fmt node_schs =
270
  IMap.iter
271
    (fun nd report ->
272
      Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table)
273
    node_schs
274

    
275
let pp_warning_unused fmt node_schs =
276
 IMap.iter
277
   (fun nd report ->
278
     let unused = report.unused_vars in
279
     if not (ISet.is_empty unused)
280
     then
281
       let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in
282
       ISet.iter
283
	 (fun u ->
284
	   let vu = get_node_var u nd in
285
	   if vu.var_orig
286
	   then Format.fprintf fmt "Warning: variable '%s' seems unused@.%a@." u Location.pp_loc vu.var_loc)
287
	 unused
288
   )
289
   node_schs
290

    
291
(* Local Variables: *)
292
(* compile-command:"make -C .." *)
293
(* End: *)