Project

General

Profile

Download (10.3 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
19
   lhs. For variables still unrelated, standard compare is used to choose the
20
   minimal element. This priority is used since it helps a lot in factorizing
21
   generated code. Moreover, the dependency graph is browsed in a depth-first
22
   manner whenever possible, to improve the behavior of optimization algorithms
23
   applied in forthcoming compilation steps. 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 - [pending] is the
26
   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
28
   [pending] - [sort] is the resulting topological order *)
29

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

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

    
47
(* Chooses the next var to be sorted, taking priority into account. Modifies
48
   [pending] and [frontier] accordingly. *)
49
let next_element eq_equiv g sort call pending frontier =
50
  if ISet.is_empty !pending then (
51
    let choice = ISet.min_elt !frontier in
52
    (*Format.eprintf "-1-> %s@." choice;*)
53
    frontier := ISet.remove choice !frontier;
54
    let p, f = ISet.partition (eq_equiv choice) !frontier in
55
    pending := p;
56
    frontier := f;
57
    call := is_call_output choice g;
58
    add_successors eq_equiv g choice pending frontier;
59
    if not (ExprDep.is_ghost_var choice) then sort := [ choice ] :: !sort)
60
  else
61
    let choice = ISet.min_elt !pending in
62
    (*Format.eprintf "-2-> %s@." choice;*)
63
    pending := ISet.remove choice !pending;
64
    add_successors eq_equiv g choice pending frontier;
65
    if not (ExprDep.is_ghost_var choice) then
66
      sort :=
67
        if !call then (choice :: List.hd !sort) :: List.tl !sort
68
        else [ choice ] :: !sort
69

    
70
(* Topological sort of dependency graph [g], with priority. *)
71
let topological_sort eq_equiv g =
72
  let roots = graph_roots g in
73
  assert (roots <> []);
74
  let call = ref false in
75
  let frontier = ref (List.fold_right ISet.add roots ISet.empty) in
76
  let pending = ref ISet.empty in
77
  let sorted = ref [] in
78
  while not (ISet.is_empty !frontier && ISet.is_empty !pending) do
79
    (*Format.eprintf "frontier = {%a}, pending = {%a}@." (fun fmt -> ISet.iter
80
      (fun e -> Format.pp_print_string fmt e)) !frontier (fun fmt -> ISet.iter
81
      (fun e -> Format.pp_print_string fmt e)) !pending;*)
82
    next_element eq_equiv g sorted call pending frontier
83
  done;
84
  IdentDepGraph.clear g;
85
  !sorted
86

    
87
(* Filters out normalization variables and renames instance variables to keep
88
   things readable, in a case of a dependency error *)
89
let filter_original n vl =
90
  List.fold_right
91
    (fun v res ->
92
      if ExprDep.is_instance_var v then
93
        Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res
94
      else
95
        let vdecl = get_node_var v n in
96
        if vdecl.var_orig then v :: res else res)
97
    vl []
98

    
99
let eq_equiv eq_equiv_hash v1 v2 =
100
  try Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2
101
  with Not_found -> false
102

    
103
let schedule_node n =
104
  (* let node_vars = get_node_vars n in *)
105
  Log.report ~level:5 (fun fmt ->
106
      Format.fprintf fmt "scheduling node %s@ " n.node_id);
107
  let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in
108

    
109
  let node, g = global_dependency n in
110

    
111
  (* TODO X: extend the graph with inputs (adapt the causality analysis to deal
112
     with inputs compute: coi predecessors of outputs warning (no modification)
113
     when memories are non used (do not impact output) or when inputs are not
114
     used (do not impact output) DONE ! *)
115
  let dep_graph = IdentDepGraph.copy g in
116
  let schedule = topological_sort eq_equiv g in
117
  let unused_vars = Liveness.compute_unused_variables n dep_graph in
118
  let fanin_table = Liveness.compute_fanin n dep_graph in
119
  { node; schedule; unused_vars; fanin_table; dep_graph }
120

    
121
(* let schedule_eqs eqs =
122
 *   let eq_equiv = eq_equiv (ExprDep.eqs_eq_equiv eqs) in
123
 *   assert false (\* TODO: continue to implement scheduling of eqs for spec *\) *)
124

    
125
let compute_node_reuse_table report =
126
  let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in
127
  let reuse =
128
    Liveness.compute_reuse_policy report.node report.schedule disjoint
129
      report.dep_graph
130
  in
131
  (* if !Options.print_reuse then begin Log.report ~level:0 (fun fmt ->
132
     Format.fprintf fmt "OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 =
133
     v2.var_id then raise Not_found) reuse; false) with Not_found -> true) );
134
     Log.report ~level:0 (fun fmt -> Format.fprintf fmt "OPT:clock disjoint map
135
     for node %s: %a" n'.node_id Disjunction.pp_disjoint_map disjoint );
136
     Log.report ~level:0 (fun fmt -> Format.fprintf fmt "OPT:reuse policy for
137
     node %s: %a" n'.node_id Liveness.pp_reuse_policy reuse ); end; *)
138
  reuse
139

    
140
let schedule_prog prog =
141
  List.fold_right
142
    (fun top_decl (accu_prog, sch_map) ->
143
      match top_decl.top_decl_desc with
144
      | Node nd ->
145
        let report = schedule_node nd in
146
        ( { top_decl with top_decl_desc = Node report.node } :: accu_prog,
147
          IMap.add nd.node_id report sch_map )
148
      | _ ->
149
        top_decl :: accu_prog, sch_map)
150
    prog ([], IMap.empty)
151

    
152
let compute_prog_reuse_table report = IMap.map compute_node_reuse_table report
153

    
154
(* removes inlined local variables from schedule report, which are now useless *)
155
let remove_node_inlined_locals locals report =
156
  let is_inlined v = IMap.exists (fun l _ -> v = l) locals in
157
  let schedule' =
158
    List.fold_right
159
      (fun heads q ->
160
        let heads' = List.filter (fun v -> not (is_inlined v)) heads in
161
        if heads' = [] then q else heads' :: q)
162
      report.schedule []
163
  in
164
  IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;
165
  IMap.iter
166
    (fun v _ ->
167
      let iv = ExprDep.mk_instance_var v in
168
      Liveness.replace_in_dep_graph v iv report.dep_graph)
169
    locals;
170
  { report with schedule = schedule' }
171

    
172
let remove_prog_inlined_locals removed reuse =
173
  IMap.mapi (fun id -> remove_node_inlined_locals (IMap.find id removed)) reuse
174

    
175
let pp_eq_schedule fmt vl =
176
  match vl with
177
  | [] ->
178
    assert false
179
  | [ v ] ->
180
    Format.fprintf fmt "%s" v
181
  | _ ->
182
    Format.fprintf fmt "(%a)"
183
      (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v))
184
      vl
185

    
186
let pp_schedule fmt node_schs =
187
  IMap.iter
188
    (fun nd report ->
189
      Format.(
190
        fprintf fmt "%s schedule: %a@ " nd
191
          (pp_print_list ~pp_sep:pp_print_semicolon pp_eq_schedule)
192
          report.schedule))
193
    node_schs
194

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

    
201
let pp_dep_graph fmt node_schs =
202
  IMap.iter
203
    (fun nd report ->
204
      Format.fprintf fmt "%s dependency graph: %a@ " nd pp_dep_graph
205
        report.dep_graph)
206
    node_schs
207

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

    
230
(* Sort eqs according to schedule *)
231
(* Sort the set of equations of node [nd] according to the computed schedule
232
   [sch] *)
233
let sort_equations_from_schedule eqs sch =
234
  Log.report ~level:10 (fun fmt ->
235
      Format.fprintf fmt "schedule: %a@ "
236
        (Format.pp_print_list ~pp_sep:Format.pp_print_semicolon pp_eq_schedule)
237
        sch);
238
  let split_eqs = Splitting.tuple_split_eq_list eqs in
239
  (* Flatten schedule *)
240
  let sch =
241
    List.fold_right (fun vl res -> List.map (fun v -> [ v ]) vl @ res) sch []
242
  in
243
  let eqs_rev, remainder =
244
    List.fold_left
245
      (fun (accu, node_eqs_remainder) vl ->
246
        (* For each variable in vl, there should exists the equations in accu *)
247
        if
248
          List.for_all
249
            (fun v -> List.exists (fun eq -> List.mem v eq.eq_lhs) accu)
250
            vl
251
        then accu, node_eqs_remainder
252
        else
253
          let eq_v, remainder = find_eq vl node_eqs_remainder in
254
          eq_v :: accu, remainder)
255
      ([], split_eqs) sch
256
  in
257
  let eqs = List.rev eqs_rev in
258
  let unused =
259
    if List.length remainder > 0 then (
260
      Log.report ~level:3 (fun fmt ->
261
          Format.fprintf fmt
262
            "[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "
263
            Printers.pp_node_eqs remainder Printers.pp_node_eqs eqs);
264
      let vars =
265
        List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder
266
      in
267
      Log.report ~level:1 (fun fmt ->
268
          Format.fprintf fmt "[Warning] Unused variables: %a@ "
269
            (fprintf_list ~sep:", " Format.pp_print_string)
270
            vars);
271
      vars)
272
    else []
273
  in
274
  eqs, unused
275

    
276
(* Local Variables: *)
277
(* compile-command:"make -C .." *)
278
(* End: *)
(53-53/66)