Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / scheduling.ml @ 684d39e7

History | View | Annotate | Download (9.52 KB)

1 a2d97a3e ploc
(********************************************************************)
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 22fe1c93 ploc
12
open Utils
13 8446bf03 ploc
open Lustre_types
14 22fe1c93 ploc
open Corelang
15
open Graph
16
open Causality
17 95fb046e ploc
open Scheduling_type
18 22fe1c93 ploc
19
(* Topological sort with a priority for variables belonging in the same equation lhs.
20
   For variables still unrelated, standard compare is used to choose the minimal element.
21
   This priority is used since it helps a lot in factorizing generated code.
22 b1655a21 xthirioux
   Moreover, the dependency graph is browsed in a depth-first manner whenever possible,
23
   to improve the behavior of optimization algorithms applied in forthcoming compilation steps. 
24 22fe1c93 ploc
   In the following functions:
25
   - [eq_equiv] is the equivalence relation between vars of the same equation lhs
26
   - [g] the (imperative) graph to be topologically sorted
27
   - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var
28
   - [frontier] is the set of unsorted root variables so far, not belonging in [pending]
29
   - [sort] is the resulting topological order
30
*)
31 a38c681e xthirioux
32
(* Checks whether the currently scheduled variable [choice]
33
   is an output of a call, possibly among others *)
34
let is_call_output choice g =
35 04d15b97 xthirioux
 List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)
36 a38c681e xthirioux
37 22fe1c93 ploc
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv],
38
   then removes [v] from [g] 
39
*)
40
let add_successors eq_equiv g v pending frontier =
41
  let succs_v = IdentDepGraph.succ g v in
42
  begin
43
    IdentDepGraph.remove_vertex g v;
44 b84a138e ploc
    List.iter 
45
      (fun v' -> 
46
	if is_graph_root v' g then 
47
	  (if eq_equiv v v' then 
48
	      pending := ISet.add v' !pending 
49
	   else
50
	      frontier := ISet.add v' !frontier)
51
      ) succs_v;
52 22fe1c93 ploc
  end
53
54
(* Chooses the next var to be sorted, taking priority into account.
55
   Modifies [pending] and [frontier] accordingly.
56
*)
57 a38c681e xthirioux
let next_element eq_equiv g sort call pending frontier =
58 8ea13d96 xthirioux
  begin
59
    if ISet.is_empty !pending
60
    then
61
      begin
62
	let choice = ISet.min_elt !frontier in
63 22fe1c93 ploc
      (*Format.eprintf "-1-> %s@." choice;*)
64 8ea13d96 xthirioux
	frontier := ISet.remove choice !frontier;
65
	let (p, f) = ISet.partition (eq_equiv choice) !frontier in
66
	pending := p;
67
	frontier := f;
68 a38c681e xthirioux
	call := is_call_output choice g;
69 8ea13d96 xthirioux
	add_successors eq_equiv g choice pending frontier;
70 a38c681e xthirioux
	if not (ExprDep.is_ghost_var choice)
71
	then sort := [choice] :: !sort
72 8ea13d96 xthirioux
      end
73
    else
74
      begin
75
	let choice = ISet.min_elt !pending in
76 22fe1c93 ploc
      (*Format.eprintf "-2-> %s@." choice;*)
77 8ea13d96 xthirioux
	pending := ISet.remove choice !pending;
78
	add_successors eq_equiv g choice pending frontier;
79 a38c681e xthirioux
	if not (ExprDep.is_ghost_var choice)
80
	then sort := (if !call
81
		      then (choice :: List.hd !sort) :: List.tl !sort
82
		      else [choice] :: !sort)
83 8ea13d96 xthirioux
      end
84
  end
85
86 22fe1c93 ploc
87
(* Topological sort of dependency graph [g], with priority.
88
 *)
89
let topological_sort eq_equiv g =
90
  let roots = graph_roots g in
91
  assert (roots <> []);
92 a38c681e xthirioux
  let call = ref false in
93 22fe1c93 ploc
  let frontier = ref (List.fold_right ISet.add roots ISet.empty) in
94
  let pending = ref ISet.empty in
95
  let sorted = ref [] in
96
  begin
97
    while not (ISet.is_empty !frontier && ISet.is_empty !pending)
98
    do
99
      (*Format.eprintf "frontier = {%a}, pending = {%a}@."
100
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier
101
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*)
102 a38c681e xthirioux
      next_element eq_equiv g sorted call pending frontier;
103 22fe1c93 ploc
    done;
104 8ea13d96 xthirioux
    IdentDepGraph.clear g;
105 22fe1c93 ploc
    !sorted
106
  end
107
108 54d032f5 xthirioux
(* Filters out normalization variables and renames instance variables to keep things readable,
109
   in a case of a dependency error *)
110
let filter_original n vl =
111
 List.fold_right (fun v res ->
112
   if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else
113
   let vdecl = get_node_var v n in
114
   if vdecl.var_orig then v :: res else res) vl []
115
116 7afcba5a xthirioux
let schedule_node n =
117 04a63d25 xthirioux
  (* let node_vars = get_node_vars n in *)
118 e7cc5186 ploc
  let eq_equiv = ExprDep.node_eq_equiv n in
119
  let eq_equiv v1 v2 =
120
    try
121
      Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2
122
    with Not_found -> false in
123 cd670fe1 ploc
124 e7cc5186 ploc
  let n', g = global_dependency n in
125
  
126
  (* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs
127 0e1049dc xthirioux
     compute: coi predecessors of outputs
128
     warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)
129 e7cc5186 ploc
     DONE !
130
  *)
131 0e1049dc xthirioux
132 e7cc5186 ploc
  let gg = IdentDepGraph.copy g in
133
  let sort = topological_sort eq_equiv g in
134
  let unused = Liveness.compute_unused_variables n gg in
135
  let fanin = Liveness.compute_fanin n gg in
136
  { node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; }
137 ec433d69 xthirioux
138 b1a97ade xthirioux
139 04a63d25 xthirioux
let compute_node_reuse_table report =
140
  let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in
141
  let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in
142
(*
143 89a70069 xthirioux
    if !Options.print_reuse
144
    then
145
      begin
146
	Log.report ~level:0 
147
	  (fun fmt -> 
148
	    Format.fprintf fmt
149 790765c0 xthirioux
	      "OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found -> true)
150
	  );
151
	Log.report ~level:0 
152
	  (fun fmt -> 
153
	    Format.fprintf fmt
154 89a70069 xthirioux
	      "OPT:clock disjoint map for node %s: %a" 
155
	      n'.node_id
156
	      Disjunction.pp_disjoint_map disjoint
157
	  );
158
	Log.report ~level:0 
159
	  (fun fmt -> 
160
	    Format.fprintf fmt
161
	      "OPT:reuse policy for node %s: %a" 
162
	      n'.node_id
163
	      Liveness.pp_reuse_policy reuse
164
	  );
165
      end;
166 04a63d25 xthirioux
*)
167
    reuse
168
169 22fe1c93 ploc
170 88486aaf ploc
let schedule_prog prog =
171
  List.fold_right (
172 3bfed7f9 xthirioux
    fun top_decl (accu_prog, sch_map)  ->
173 88486aaf ploc
      match top_decl.top_decl_desc with
174 f4050bef ploc
      | Node nd ->
175
	let report = schedule_node nd in
176
	{top_decl with top_decl_desc = Node report.node}::accu_prog, 
177
	IMap.add nd.node_id report sch_map
178 3bfed7f9 xthirioux
	| _ -> top_decl::accu_prog, sch_map
179 88486aaf ploc
    ) 
180
    prog
181 3bfed7f9 xthirioux
    ([],IMap.empty)
182 04a63d25 xthirioux
  
183
184
let compute_prog_reuse_table report =
185
  IMap.map compute_node_reuse_table report
186
187
(* removes inlined local variables from schedule report, 
188
   which are now useless *)
189
let remove_node_inlined_locals locals report =
190
  let is_inlined v = IMap.exists (fun l _ -> v = l) locals in
191
  let schedule' =
192
    List.fold_right (fun heads q -> let heads' = List.filter (fun v -> not (is_inlined v)) heads
193
				    in if heads' = [] then q else heads'::q)
194
      report.schedule [] in
195
  begin
196
    IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;
197
    IMap.iter (fun v _ -> let iv = ExprDep.mk_instance_var v
198
			  in Liveness.replace_in_dep_graph v iv report.dep_graph) locals;
199
    { report with schedule = schedule' }
200
  end
201
202
let remove_prog_inlined_locals removed reuse =
203
  IMap.mapi (fun id -> remove_node_inlined_locals (IMap.find id removed)) reuse
204 3bfed7f9 xthirioux
205 a38c681e xthirioux
let pp_eq_schedule fmt vl =
206
  match vl with
207
  | []  -> assert false
208
  | [v] -> Format.fprintf fmt "%s" v
209
  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
210
 
211 8a183477 xthirioux
let pp_schedule fmt node_schs =
212
 IMap.iter
213
   (fun nd report ->
214
     Format.fprintf fmt "%s schedule: %a@."
215
       nd
216 a38c681e xthirioux
       (fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)
217 8a183477 xthirioux
   node_schs
218
219
let pp_fanin_table fmt node_schs =
220
  IMap.iter
221
    (fun nd report ->
222 04a63d25 xthirioux
      Format.fprintf fmt "%s: %a" nd Liveness.pp_fanin report.fanin_table)
223
    node_schs
224
225
let pp_dep_graph fmt node_schs =
226
  IMap.iter
227
    (fun nd report ->
228
      Format.fprintf fmt "%s dependency graph: %a" nd pp_dep_graph report.dep_graph)
229 8a183477 xthirioux
    node_schs
230
231 3bfed7f9 xthirioux
let pp_warning_unused fmt node_schs =
232
 IMap.iter
233
   (fun nd report ->
234
     let unused = report.unused_vars in
235
     if not (ISet.is_empty unused)
236
     then
237
       let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in
238
       ISet.iter
239 df39e35a xthirioux
	 (fun u ->
240
	   let vu = get_node_var u nd in
241
	   if vu.var_orig
242 04a63d25 xthirioux
	   then Format.fprintf fmt "  Warning: variable '%s' seems unused@,  %a@,@," u Location.pp_loc vu.var_loc)
243 3bfed7f9 xthirioux
	 unused
244
   )
245
   node_schs
246 22fe1c93 ploc
247 04a63d25 xthirioux
248 eb9a8c3c ploc
   (* Sort eqs according to schedule *)
249
(* Sort the set of equations of node [nd] according
250
   to the computed schedule [sch]
251
*)
252
let sort_equations_from_schedule nd sch =
253
  (* Format.eprintf "%s schedule: %a@." *)
254
  (* 		 nd.node_id *)
255
  (* 		 (Utils.fprintf_list ~sep:" ; " Scheduling.pp_eq_schedule) sch; *)
256
  let eqs, auts = get_node_eqs nd in
257
  assert (auts = []); (* Automata should be expanded by now *)
258
  let split_eqs = Splitting.tuple_split_eq_list eqs in
259
  let eqs_rev, remainder =
260
    List.fold_left
261
      (fun (accu, node_eqs_remainder) vl ->
262
       if List.exists (fun eq -> List.exists (fun v -> List.mem v eq.eq_lhs) vl) accu
263
       then
264
	 (accu, node_eqs_remainder)
265
       else
266
	 let eq_v, remainder = find_eq vl node_eqs_remainder in
267
	 eq_v::accu, remainder
268
      )
269
      ([], split_eqs)
270
      sch
271
  in
272
  begin
273
    if List.length remainder > 0 then (
274
      let eqs, auts = get_node_eqs nd in
275
      assert (auts = []); (* Automata should be expanded by now *)
276
      Format.eprintf "Equations not used are@.%a@.Full equation set is:@.%a@.@?"
277
		     Printers.pp_node_eqs remainder
278
      		     Printers.pp_node_eqs eqs;
279
      assert false);
280
    List.rev eqs_rev
281
  end
282
283 22fe1c93 ploc
(* Local Variables: *)
284
(* compile-command:"make -C .." *)
285
(* End: *)