Project

General

Profile

Download (10.5 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
  Log.report ~level:5 (fun fmt -> Format.fprintf fmt "scheduling node %s@ " n.node_id);
124
  let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in
125

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

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

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

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

    
174

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

    
188

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

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

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

    
210
let pp_eq_schedule fmt vl =
211
  match vl with
212
  | []  -> assert false
213
  | [v] -> Format.fprintf fmt "%s" v
214
  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
215
 
216
let pp_schedule fmt node_schs =
217
 IMap.iter
218
   (fun nd report ->
219
     Format.(fprintf fmt "%s schedule: %a@ "
220
       nd
221
       (pp_print_list ~pp_sep:pp_print_semicolon pp_eq_schedule)
222
       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
  Log.report ~level:10 (fun fmt ->
260
      Format.fprintf fmt "schedule: %a@ "
261
        (Format.pp_print_list
262
           ~pp_sep:Format.pp_print_semicolon pp_eq_schedule) sch);
263
  let split_eqs = Splitting.tuple_split_eq_list eqs in
264
  (* Flatten schedule *)
265
   let sch = List.fold_right (fun vl res -> (List.map (fun v -> [v]) vl)@res) sch [] in 
266
  let eqs_rev, remainder =
267
    List.fold_left
268
      (fun (accu, node_eqs_remainder) vl ->
269
        (* For each variable in vl, there should exists the equations in accu *)
270
       if List.for_all (fun v -> List.exists (fun eq -> List.mem v eq.eq_lhs) accu) vl
271
       then
272
	 (accu, node_eqs_remainder)
273
       else
274
	 let eq_v, remainder = find_eq vl node_eqs_remainder in
275
	 eq_v::accu, remainder
276
      )
277
      ([], split_eqs)
278
      sch
279
  in
280
  begin
281
    let eqs = List.rev eqs_rev in 
282
    let unused =
283
      if List.length remainder > 0 then (
284
        Log.report ~level:3 (fun fmt -> Format.fprintf fmt
285
                                       "[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "
286
		                       Printers.pp_node_eqs remainder
287
      		                     Printers.pp_node_eqs eqs
288
          );
289
        let vars = List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder in
290
        Log.report ~level:1 (fun fmt -> Format.fprintf fmt
291
                                      "[Warning] Unused variables: %a@ "
292
                                      (fprintf_list ~sep:", " Format.pp_print_string)
293
                                  vars
294
          );
295
        vars
296
      )
297
      else
298
        []
299
    in
300
    eqs, unused
301
  end
302

    
303
(* Local Variables: *)
304
(* compile-command:"make -C .." *)
305
(* End: *)
(53-53/66)