Project

General

Profile

Download (7.19 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 LustreSpec
14
open Corelang
15
open Graph
16
open Causality
17

    
18
type schedule_report =
19
{
20
  (* a schedule computed wrt the dependency graph *)
21
  schedule : ident list list;
22
  (* the set of unused variables (no output or mem depends on them) *)
23
  unused_vars : ISet.t;
24
  (* the table mapping each local var to its in-degree *)
25
  fanin_table : (ident, int) Hashtbl.t;
26
  (* the table mapping each assignment to a reusable variable *)
27
  reuse_table : (ident, var_decl) Hashtbl.t
28
}
29

    
30
(* Topological sort with a priority for variables belonging in the same equation lhs.
31
   For variables still unrelated, standard compare is used to choose the minimal element.
32
   This priority is used since it helps a lot in factorizing generated code.
33
   Moreover, the dependency graph is browsed in a depth-first manner whenever possible,
34
   to improve the behavior of optimization algorithms applied in forthcoming compilation steps. 
35
   In the following functions:
36
   - [eq_equiv] is the equivalence relation between vars of the same equation lhs
37
   - [g] the (imperative) graph to be topologically sorted
38
   - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var
39
   - [frontier] is the set of unsorted root variables so far, not belonging in [pending]
40
   - [sort] is the resulting topological order
41
*)
42

    
43
(* Checks whether the currently scheduled variable [choice]
44
   is an output of a call, possibly among others *)
45
let is_call_output choice g =
46
 List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)
47

    
48
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv],
49
   then removes [v] from [g] 
50
*)
51
let add_successors eq_equiv g v pending frontier =
52
  let succs_v = IdentDepGraph.succ g v in
53
  begin
54
    IdentDepGraph.remove_vertex g v;
55
    List.iter 
56
      (fun v' -> 
57
	if is_graph_root v' g then 
58
	  (if eq_equiv v v' then 
59
	      pending := ISet.add v' !pending 
60
	   else
61
	      frontier := ISet.add v' !frontier)
62
      ) succs_v;
63
  end
64

    
65
(* Chooses the next var to be sorted, taking priority into account.
66
   Modifies [pending] and [frontier] accordingly.
67
*)
68
let next_element eq_equiv g sort call pending frontier =
69
  begin
70
    if ISet.is_empty !pending
71
    then
72
      begin
73
	let choice = ISet.min_elt !frontier in
74
      (*Format.eprintf "-1-> %s@." choice;*)
75
	frontier := ISet.remove choice !frontier;
76
	let (p, f) = ISet.partition (eq_equiv choice) !frontier in
77
	pending := p;
78
	frontier := f;
79
	call := is_call_output choice g;
80
	add_successors eq_equiv g choice pending frontier;
81
	if not (ExprDep.is_ghost_var choice)
82
	then sort := [choice] :: !sort
83
      end
84
    else
85
      begin
86
	let choice = ISet.min_elt !pending in
87
      (*Format.eprintf "-2-> %s@." choice;*)
88
	pending := ISet.remove choice !pending;
89
	add_successors eq_equiv g choice pending frontier;
90
	if not (ExprDep.is_ghost_var choice)
91
	then sort := (if !call
92
		      then (choice :: List.hd !sort) :: List.tl !sort
93
		      else [choice] :: !sort)
94
      end
95
  end
96

    
97

    
98
(* Topological sort of dependency graph [g], with priority.
99
 *)
100
let topological_sort eq_equiv g =
101
  let roots = graph_roots g in
102
  assert (roots <> []);
103
  let call = ref false in
104
  let frontier = ref (List.fold_right ISet.add roots ISet.empty) in
105
  let pending = ref ISet.empty in
106
  let sorted = ref [] in
107
  begin
108
    while not (ISet.is_empty !frontier && ISet.is_empty !pending)
109
    do
110
      (*Format.eprintf "frontier = {%a}, pending = {%a}@."
111
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier
112
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*)
113
      next_element eq_equiv g sorted call pending frontier;
114
    done;
115
    IdentDepGraph.clear g;
116
    !sorted
117
  end
118

    
119
let schedule_node n =
120
  try
121
    let eq_equiv = ExprDep.node_eq_equiv n in
122
    let eq_equiv v1 v2 =
123
      try
124
	Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2
125
      with Not_found -> false in
126

    
127
    let n', g = global_dependency n in
128
    Log.report ~level:5 
129
      (fun fmt -> 
130
	Format.fprintf fmt
131
	  "dependency graph for node %s: %a" 
132
	  n'.node_id
133
	  pp_dep_graph g
134
      );
135
    
136
    (* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs
137
     compute: coi predecessors of outputs
138
     warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)
139
       DONE !
140
     *)
141

    
142
    let gg = IdentDepGraph.copy g in
143
    let sort = topological_sort eq_equiv g in
144
    let unused = Liveness.compute_unused_variables n gg in
145
    let fanin = Liveness.compute_fanin n gg in
146

    
147
    let disjoint = Disjunction.clock_disjoint_map (get_node_vars n) in
148
    
149
    Log.report ~level:2 
150
      (fun fmt -> 
151
	Format.fprintf fmt
152
	  "clock disjoint map for node %s: %a" 
153
	  n'.node_id
154
	  Disjunction.pp_disjoint_map disjoint
155
      );
156

    
157
    let reuse = Liveness.compute_reuse_policy n sort disjoint gg in
158
    Log.report ~level:2 
159
      (fun fmt -> 
160
	Format.fprintf fmt
161
	  "reuse policy for node %s: %a" 
162
	  n'.node_id
163
	  Liveness.pp_reuse_policy reuse
164
      );
165
 
166
    n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse }
167
  with (Causality.Cycle v) as exc ->
168
    pp_error Format.err_formatter v;
169
    raise exc
170

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

    
184
let pp_eq_schedule fmt vl =
185
  match vl with
186
  | []  -> assert false
187
  | [v] -> Format.fprintf fmt "%s" v
188
  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
189
 
190
let pp_schedule fmt node_schs =
191
 IMap.iter
192
   (fun nd report ->
193
     Format.fprintf fmt "%s schedule: %a@."
194
       nd
195
       (fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)
196
   node_schs
197

    
198
let pp_fanin_table fmt node_schs =
199
  IMap.iter
200
    (fun nd report ->
201
      Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table)
202
    node_schs
203

    
204
let pp_warning_unused fmt node_schs =
205
 IMap.iter
206
   (fun nd report ->
207
     let unused = report.unused_vars in
208
     if not (ISet.is_empty unused)
209
     then
210
       let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in
211
       ISet.iter
212
	 (fun u -> 
213
	   Format.fprintf fmt "Warning: variable '%s' seems unused@.%a@."
214
	     u
215
	     Location.pp_loc (get_node_var u nd).var_loc)
216
	 unused
217
   )
218
   node_schs
219

    
220
(* Local Variables: *)
221
(* compile-command:"make -C .." *)
222
(* End: *)
(38-38/45)