Project

General

Profile

Download (10.2 KB) Statistics
| Branch: | Tag: | Revision:
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 eq_equiv eq_equiv_hash =
117
  fun v1 v2 ->
118
  try
119
    Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2
120
  with Not_found -> false
121

    
122
let schedule_node n =
123
  (* let node_vars = get_node_vars n in *)
124
  Log.report ~level:5 (fun fmt -> Format.fprintf fmt "scheduling node %s@," n.node_id);
125
  let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in
126

    
127
  let n', g = global_dependency n in
128
  
129
  (* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs
130
     compute: coi predecessors of outputs
131
     warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)
132
     DONE !
133
  *)
134

    
135
  let gg = IdentDepGraph.copy g in
136
  let sort = topological_sort eq_equiv g in
137
  let unused = Liveness.compute_unused_variables n gg in
138
  let fanin = Liveness.compute_fanin n gg in
139
  { node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; }
140

    
141
(* let schedule_eqs eqs =
142
 *   let eq_equiv = eq_equiv (ExprDep.eqs_eq_equiv eqs) in
143
 *   assert false (\* TODO: continue to implement scheduling of eqs for spec *\) *)
144

    
145
let compute_node_reuse_table report =
146
  let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in
147
  let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in
148
(*
149
    if !Options.print_reuse
150
    then
151
      begin
152
	Log.report ~level:0 
153
	  (fun fmt -> 
154
	    Format.fprintf fmt
155
	      "OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found -> true)
156
	  );
157
	Log.report ~level:0 
158
	  (fun fmt -> 
159
	    Format.fprintf fmt
160
	      "OPT:clock disjoint map for node %s: %a" 
161
	      n'.node_id
162
	      Disjunction.pp_disjoint_map disjoint
163
	  );
164
	Log.report ~level:0 
165
	  (fun fmt -> 
166
	    Format.fprintf fmt
167
	      "OPT:reuse policy for node %s: %a" 
168
	      n'.node_id
169
	      Liveness.pp_reuse_policy reuse
170
	  );
171
      end;
172
*)
173
    reuse
174

    
175

    
176
let schedule_prog prog =
177
  List.fold_right (
178
    fun top_decl (accu_prog, sch_map)  ->
179
      match top_decl.top_decl_desc with
180
      | Node nd ->
181
	let report = schedule_node nd in
182
	{top_decl with top_decl_desc = Node report.node}::accu_prog, 
183
	IMap.add nd.node_id report sch_map
184
	| _ -> top_decl::accu_prog, sch_map
185
    ) 
186
    prog
187
    ([],IMap.empty)
188
  
189

    
190
let compute_prog_reuse_table report =
191
  IMap.map compute_node_reuse_table report
192

    
193
(* removes inlined local variables from schedule report, 
194
   which are now useless *)
195
let remove_node_inlined_locals locals report =
196
  let is_inlined v = IMap.exists (fun l _ -> v = l) locals in
197
  let schedule' =
198
    List.fold_right (fun heads q -> let heads' = List.filter (fun v -> not (is_inlined v)) heads
199
				    in if heads' = [] then q else heads'::q)
200
      report.schedule [] in
201
  begin
202
    IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;
203
    IMap.iter (fun v _ -> let iv = ExprDep.mk_instance_var v
204
			  in Liveness.replace_in_dep_graph v iv report.dep_graph) locals;
205
    { report with schedule = schedule' }
206
  end
207

    
208
let remove_prog_inlined_locals removed reuse =
209
  IMap.mapi (fun id -> remove_node_inlined_locals (IMap.find id removed)) reuse
210

    
211
let pp_eq_schedule fmt vl =
212
  match vl with
213
  | []  -> assert false
214
  | [v] -> Format.fprintf fmt "%s" v
215
  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
216
 
217
let pp_schedule fmt node_schs =
218
 IMap.iter
219
   (fun nd report ->
220
     Format.fprintf fmt "%s schedule: %a@."
221
       nd
222
       (fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)
223
   node_schs
224

    
225
let pp_fanin_table fmt node_schs =
226
  IMap.iter
227
    (fun nd report ->
228
      Format.fprintf fmt "%s: %a" nd Liveness.pp_fanin report.fanin_table)
229
    node_schs
230

    
231
let pp_dep_graph fmt node_schs =
232
  IMap.iter
233
    (fun nd report ->
234
      Format.fprintf fmt "%s dependency graph: %a" nd pp_dep_graph report.dep_graph)
235
    node_schs
236

    
237
let pp_warning_unused fmt node_schs =
238
 IMap.iter
239
   (fun nd report ->
240
     let unused = report.unused_vars in
241
     if not (ISet.is_empty unused)
242
     then
243
       let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in
244
       ISet.iter
245
	 (fun u ->
246
	   let vu = get_node_var u nd in
247
	   if vu.var_orig
248
	   then Format.fprintf fmt "  Warning: variable '%s' seems unused@,  %a@,@," u Location.pp_loc vu.var_loc)
249
	 unused
250
   )
251
   node_schs
252

    
253

    
254
(* Sort eqs according to schedule *)
255
(* Sort the set of equations of node [nd] according
256
   to the computed schedule [sch]
257
*)
258
let sort_equations_from_schedule eqs sch =
259
  (* Format.eprintf "%s schedule: %a@." *)
260
  (* 		 nd.node_id *)
261
  (* 		 (Utils.fprintf_list ~sep:" ; " Scheduling.pp_eq_schedule) sch; *)
262
  let split_eqs = Splitting.tuple_split_eq_list eqs in
263
  let eqs_rev, remainder =
264
    List.fold_left
265
      (fun (accu, node_eqs_remainder) vl ->
266
       if List.exists (fun eq -> List.exists (fun v -> List.mem v eq.eq_lhs) vl) accu
267
       then
268
	 (accu, node_eqs_remainder)
269
       else
270
	 let eq_v, remainder = find_eq vl node_eqs_remainder in
271
	 eq_v::accu, remainder
272
      )
273
      ([], split_eqs)
274
      sch
275
  in
276
  begin
277
    let eqs = List.rev eqs_rev in 
278
    let unused =
279
      if List.length remainder > 0 then (
280
        Log.report ~level:3 (fun fmt -> Format.fprintf fmt
281
                                       "[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "
282
		                       Printers.pp_node_eqs remainder
283
      		                     Printers.pp_node_eqs eqs
284
          );
285
        let vars = List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder in
286
        Log.report ~level:1 (fun fmt -> Format.fprintf fmt
287
                                      "[Warning] Unused variables: %a@ "
288
                                      (fprintf_list ~sep:", " Format.pp_print_string)
289
                                  vars
290
          );
291
        vars
292
      )
293
      else
294
        []
295
    in
296
    eqs, unused
297
  end
298

    
299
(* Local Variables: *)
300
(* compile-command:"make -C .." *)
301
(* End: *)
(56-56/67)