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 Causality
16
open Scheduling_type
17

    
18
(* Topological sort with a priority for variables belonging in the same equation lhs.
19
   For variables still unrelated, standard compare is used to choose the minimal element.
20
   This priority is used since it helps a lot in factorizing generated code.
21
   Moreover, the dependency graph is browsed in a depth-first manner whenever possible,
22
   to improve the behavior of optimization algorithms applied in forthcoming compilation steps. 
23
   In the following functions:
24
   - [eq_equiv] is the equivalence relation between vars of the same equation lhs
25
   - [g] the (imperative) graph to be topologically sorted
26
   - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var
27
   - [frontier] is the set of unsorted root variables so far, not belonging in [pending]
28
   - [sort] is the resulting topological order
29
*)
30

    
31
(* Checks whether the currently scheduled variable [choice]
32
   is an output of a call, possibly among others *)
33
let is_call_output choice g =
34
 List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)
35

    
36
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv],
37
   then removes [v] from [g] 
38
*)
39
let add_successors eq_equiv g v pending frontier =
40
  let succs_v = IdentDepGraph.succ g v in
41
  begin
42
    IdentDepGraph.remove_vertex g v;
43
    List.iter 
44
      (fun v' -> 
45
	if is_graph_root v' g then 
46
	  (if eq_equiv v v' then 
47
	      pending := ISet.add v' !pending 
48
	   else
49
	      frontier := ISet.add v' !frontier)
50
      ) succs_v;
51
  end
52

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

    
85

    
86
(* Topological sort of dependency graph [g], with priority.
87
 *)
88
let topological_sort eq_equiv g =
89
  let roots = graph_roots g in
90
  assert (roots <> []);
91
  let call = ref false in
92
  let frontier = ref (List.fold_right ISet.add roots ISet.empty) in
93
  let pending = ref ISet.empty in
94
  let sorted = ref [] in
95
  begin
96
    while not (ISet.is_empty !frontier && ISet.is_empty !pending)
97
    do
98
      (*Format.eprintf "frontier = {%a}, pending = {%a}@."
99
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier
100
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*)
101
      next_element eq_equiv g sorted call pending frontier;
102
    done;
103
    IdentDepGraph.clear g;
104
    !sorted
105
  end
106

    
107
(* Filters out normalization variables and renames instance variables to keep things readable,
108
   in a case of a dependency error *)
109
let filter_original n vl =
110
 List.fold_right (fun v res ->
111
   if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else
112
   let vdecl = get_node_var v n in
113
   if vdecl.var_orig then v :: res else res) vl []
114

    
115
let eq_equiv eq_equiv_hash =
116
  fun v1 v2 ->
117
  try
118
    Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2
119
  with Not_found -> false
120

    
121
let schedule_node n =
122
  (* let node_vars = get_node_vars n in *)
123
  let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in
124

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

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

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

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

    
173

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

    
188
let compute_prog_reuse_table report =
189
  IMap.map compute_node_reuse_table report
190

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

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

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

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

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

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

    
251

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

    
300
(* Local Variables: *)
301
(* compile-command:"make -C .." *)
302
(* End: *)
(52-52/63)