Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / scheduling.ml @ 684d39e7

History | View | Annotate | Download (9.52 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 Lustre_types
14
open Corelang
15
open Graph
16
open Causality
17
open Scheduling_type
18

    
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
   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
   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

    
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
 List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)
36

    
37
(* 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
    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
  end
53

    
54
(* Chooses the next var to be sorted, taking priority into account.
55
   Modifies [pending] and [frontier] accordingly.
56
*)
57
let next_element eq_equiv g sort call pending frontier =
58
  begin
59
    if ISet.is_empty !pending
60
    then
61
      begin
62
	let choice = ISet.min_elt !frontier in
63
      (*Format.eprintf "-1-> %s@." choice;*)
64
	frontier := ISet.remove choice !frontier;
65
	let (p, f) = ISet.partition (eq_equiv choice) !frontier in
66
	pending := p;
67
	frontier := f;
68
	call := is_call_output choice g;
69
	add_successors eq_equiv g choice pending frontier;
70
	if not (ExprDep.is_ghost_var choice)
71
	then sort := [choice] :: !sort
72
      end
73
    else
74
      begin
75
	let choice = ISet.min_elt !pending in
76
      (*Format.eprintf "-2-> %s@." choice;*)
77
	pending := ISet.remove choice !pending;
78
	add_successors eq_equiv g choice pending frontier;
79
	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
      end
84
  end
85

    
86

    
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
  let call = ref false in
93
  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
      next_element eq_equiv g sorted call pending frontier;
103
    done;
104
    IdentDepGraph.clear g;
105
    !sorted
106
  end
107

    
108
(* 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
let schedule_node n =
117
  (* let node_vars = get_node_vars n in *)
118
  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

    
124
  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
     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
     DONE !
130
  *)
131

    
132
  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

    
138

    
139
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
    if !Options.print_reuse
144
    then
145
      begin
146
	Log.report ~level:0 
147
	  (fun fmt -> 
148
	    Format.fprintf fmt
149
	      "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
	      "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
*)
167
    reuse
168

    
169

    
170
let schedule_prog prog =
171
  List.fold_right (
172
    fun top_decl (accu_prog, sch_map)  ->
173
      match top_decl.top_decl_desc with
174
      | 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
	| _ -> top_decl::accu_prog, sch_map
179
    ) 
180
    prog
181
    ([],IMap.empty)
182
  
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

    
205
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
let pp_schedule fmt node_schs =
212
 IMap.iter
213
   (fun nd report ->
214
     Format.fprintf fmt "%s schedule: %a@."
215
       nd
216
       (fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)
217
   node_schs
218

    
219
let pp_fanin_table fmt node_schs =
220
  IMap.iter
221
    (fun nd report ->
222
      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
    node_schs
230

    
231
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
	 (fun u ->
240
	   let vu = get_node_var u nd in
241
	   if vu.var_orig
242
	   then Format.fprintf fmt "  Warning: variable '%s' seems unused@,  %a@,@," u Location.pp_loc vu.var_loc)
243
	 unused
244
   )
245
   node_schs
246

    
247

    
248
   (* 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
(* Local Variables: *)
284
(* compile-command:"make -C .." *)
285
(* End: *)