Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / scheduling.ml @ b38ffff3

History | View | Annotate | Download (7.04 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 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
   In the following functions:
34
   - [eq_equiv] is the equivalence relation between vars of the same equation lhs
35
   - [g] the (imperative) graph to be topologically sorted
36
   - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var
37
   - [frontier] is the set of unsorted root variables so far, not belonging in [pending]
38
   - [sort] is the resulting topological order
39
*)
40

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

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

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

    
95

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

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

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

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

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

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

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

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

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

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

    
218
(* Local Variables: *)
219
(* compile-command:"make -C .." *)
220
(* End: *)