Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / scheduling.ml @ a38c681e

History | View | Annotate | Download (7.47 KB)

1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 * Copyright (C) 2012-2013, INPT, Toulouse, FRANCE
5
 *
6
 * This file is part of Prelude
7
 *
8
 * Prelude is free software; you can redistribute it and/or
9
 * modify it under the terms of the GNU Lesser General Public License
10
 * as published by the Free Software Foundation ; either version 2 of
11
 * the License, or (at your option) any later version.
12
 *
13
 * Prelude is distributed in the hope that it will be useful, but
14
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
15
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16
 * Lesser General Public License for more details.
17
 *
18
 * You should have received a copy of the GNU Lesser General Public
19
 * License along with this program ; if not, write to the Free Software
20
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
21
 * USA
22
 *---------------------------------------------------------------------------- *)
23

    
24
(* This module is used for the lustre to C compiler *)
25

    
26
open Utils
27
open LustreSpec
28
open Corelang
29
open Graph
30
open Causality
31

    
32
type schedule_report =
33
{
34
  (* a schedule computed wrt the dependency graph *)
35
  schedule : ident list list;
36
  (* the set of unused variables (no output or mem depends on them) *)
37
  unused_vars : ISet.t;
38
  (* the table mapping each local var to its in-degree *)
39
  fanin_table : (ident, int) Hashtbl.t;
40
  (* the table mapping each assignment to a reusable variable *)
41
  reuse_table : (ident, var_decl) Hashtbl.t
42
}
43

    
44
(* Topological sort with a priority for variables belonging in the same equation lhs.
45
   For variables still unrelated, standard compare is used to choose the minimal element.
46
   This priority is used since it helps a lot in factorizing generated code.
47
   In the following functions:
48
   - [eq_equiv] is the equivalence relation between vars of the same equation lhs
49
   - [g] the (imperative) graph to be topologically sorted
50
   - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var
51
   - [frontier] is the set of unsorted root variables so far, not belonging in [pending]
52
   - [sort] is the resulting topological order
53
*)
54

    
55
(* Checks whether the currently scheduled variable [choice]
56
   is an output of a call, possibly among others *)
57
let is_call_output choice g =
58
  List.for_all ExprDep.is_instance_var (IdentDepGraph.succ g choice)
59

    
60
(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv],
61
   then removes [v] from [g] 
62
*)
63
let add_successors eq_equiv g v pending frontier =
64
  let succs_v = IdentDepGraph.succ g v in
65
  begin
66
    IdentDepGraph.remove_vertex g v;
67
    List.iter 
68
      (fun v' -> 
69
	if is_graph_root v' g then 
70
	  (if eq_equiv v v' then 
71
	      pending := ISet.add v' !pending 
72
	   else
73
	      frontier := ISet.add v' !frontier)
74
      ) succs_v;
75
  end
76

    
77
(* Chooses the next var to be sorted, taking priority into account.
78
   Modifies [pending] and [frontier] accordingly.
79
*)
80
let next_element eq_equiv g sort call pending frontier =
81
  begin
82
    if ISet.is_empty !pending
83
    then
84
      begin
85
	let choice = ISet.min_elt !frontier in
86
      (*Format.eprintf "-1-> %s@." choice;*)
87
	frontier := ISet.remove choice !frontier;
88
	let (p, f) = ISet.partition (eq_equiv choice) !frontier in
89
	pending := p;
90
	frontier := f;
91
	call := is_call_output choice g;
92
	add_successors eq_equiv g choice pending frontier;
93
	if not (ExprDep.is_ghost_var choice)
94
	then sort := [choice] :: !sort
95
      end
96
    else
97
      begin
98
	let choice = ISet.min_elt !pending in
99
      (*Format.eprintf "-2-> %s@." choice;*)
100
	pending := ISet.remove choice !pending;
101
	add_successors eq_equiv g choice pending frontier;
102
	if not (ExprDep.is_ghost_var choice)
103
	then sort := (if !call
104
		      then (choice :: List.hd !sort) :: List.tl !sort
105
		      else [choice] :: !sort)
106
      end
107
  end
108

    
109

    
110
(* Topological sort of dependency graph [g], with priority.
111
 *)
112
let topological_sort eq_equiv g =
113
  let roots = graph_roots g in
114
  assert (roots <> []);
115
  let call = ref false in
116
  let frontier = ref (List.fold_right ISet.add roots ISet.empty) in
117
  let pending = ref ISet.empty in
118
  let sorted = ref [] in
119
  begin
120
    while not (ISet.is_empty !frontier && ISet.is_empty !pending)
121
    do
122
      (*Format.eprintf "frontier = {%a}, pending = {%a}@."
123
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier
124
	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*)
125
      next_element eq_equiv g sorted call pending frontier;
126
    done;
127
    IdentDepGraph.clear g;
128
    !sorted
129
  end
130

    
131
let schedule_node n =
132
  try
133
    let eq_equiv = ExprDep.node_eq_equiv n in
134
    let eq_equiv v1 v2 =
135
      try
136
	Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2
137
      with Not_found -> false in
138

    
139
    let n', g = global_dependency n in
140
    Log.report ~level:5 
141
      (fun fmt -> 
142
	Format.fprintf fmt
143
	  "dependency graph for node %s: %a" 
144
	  n'.node_id
145
	  pp_dep_graph g
146
      );
147
    
148
    (* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs
149
     compute: coi predecessors of outputs
150
     warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)
151
       DONE !
152
     *)
153

    
154
    let gg = IdentDepGraph.copy g in
155
    let sort = topological_sort eq_equiv g in
156
    let unused = Liveness.compute_unused_variables n gg in
157
    let fanin = Liveness.compute_fanin n gg in
158

    
159
    let disjoint = Disjunction.clock_disjoint_map (get_node_vars n) in
160
    
161
    Log.report ~level:2 
162
      (fun fmt -> 
163
	Format.fprintf fmt
164
	  "clock disjoint map for node %s: %a" 
165
	  n'.node_id
166
	  Disjunction.pp_disjoint_map disjoint
167
      );
168

    
169
    let reuse = Hashtbl.create 23 (*Liveness.compute_reuse_policy n sort disjoint gg*) in
170
    Log.report ~level:2 
171
      (fun fmt -> 
172
	Format.fprintf fmt
173
	  "reuse policy for node %s: %a" 
174
	  n'.node_id
175
	  Liveness.pp_reuse_policy reuse
176
      );
177
 
178
    n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse }
179
  with (Causality.Cycle v) as exc ->
180
    pp_error Format.err_formatter v;
181
    raise exc
182

    
183
let schedule_prog prog =
184
  List.fold_right (
185
    fun top_decl (accu_prog, sch_map)  ->
186
      match top_decl.top_decl_desc with
187
	| Node nd -> 
188
	  let nd', report = schedule_node nd in
189
	  {top_decl with top_decl_desc = Node nd'}::accu_prog, 
190
	  IMap.add nd.node_id report sch_map
191
	| _ -> top_decl::accu_prog, sch_map
192
    ) 
193
    prog
194
    ([],IMap.empty)
195

    
196
let pp_eq_schedule fmt vl =
197
  match vl with
198
  | []  -> assert false
199
  | [v] -> Format.fprintf fmt "%s" v
200
  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
201
 
202
let pp_schedule fmt node_schs =
203
 IMap.iter
204
   (fun nd report ->
205
     Format.fprintf fmt "%s schedule: %a@."
206
       nd
207
       (fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)
208
   node_schs
209

    
210
let pp_fanin_table fmt node_schs =
211
  IMap.iter
212
    (fun nd report ->
213
      Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table)
214
    node_schs
215

    
216
let pp_warning_unused fmt node_schs =
217
 IMap.iter
218
   (fun nd report ->
219
     let unused = report.unused_vars in
220
     if not (ISet.is_empty unused)
221
     then
222
       let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in
223
       ISet.iter
224
	 (fun u -> 
225
	   Format.fprintf fmt "Warning: variable '%s' seems unused@.%a@."
226
	     u
227
	     Location.pp_loc (get_node_var u nd).var_loc)
228
	 unused
229
   )
230
   node_schs
231

    
232
(* Local Variables: *)
233
(* compile-command:"make -C .." *)
234
(* End: *)