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

(* the scheduled node *)

21

node : node_desc;

22

(* a schedule computed wrt the dependency graph *)

23

schedule : ident list list;

24

(* the set of unused variables (no output or mem depends on them) *)

25

unused_vars : ISet.t;

26

(* the table mapping each local var to its indegree *)

27

fanin_table : (ident, int) Hashtbl.t;

28

(* the dependency graph *)

29

dep_graph : IdentDepGraph.t;

30

(* the table mapping each assignment to a reusable variable *)

31

(*reuse_table : (ident, var_decl) Hashtbl.t*)

32

}

33


34

(* Topological sort with a priority for variables belonging in the same equation lhs.

35

For variables still unrelated, standard compare is used to choose the minimal element.

36

This priority is used since it helps a lot in factorizing generated code.

37

Moreover, the dependency graph is browsed in a depthfirst manner whenever possible,

38

to improve the behavior of optimization algorithms applied in forthcoming compilation steps.

39

In the following functions:

40

 [eq_equiv] is the equivalence relation between vars of the same equation lhs

41

 [g] the (imperative) graph to be topologically sorted

42

 [pending] is the set of unsorted root variables so far, equivalent to the last sorted var

43

 [frontier] is the set of unsorted root variables so far, not belonging in [pending]

44

 [sort] is the resulting topological order

45

*)

46


47

(* Checks whether the currently scheduled variable [choice]

48

is an output of a call, possibly among others *)

49

let is_call_output choice g =

50

List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)

51


52

(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv],

53

then removes [v] from [g]

54

*)

55

let add_successors eq_equiv g v pending frontier =

56

let succs_v = IdentDepGraph.succ g v in

57

begin

58

IdentDepGraph.remove_vertex g v;

59

List.iter

60

(fun v' >

61

if is_graph_root v' g then

62

(if eq_equiv v v' then

63

pending := ISet.add v' !pending

64

else

65

frontier := ISet.add v' !frontier)

66

) succs_v;

67

end

68


69

(* Chooses the next var to be sorted, taking priority into account.

70

Modifies [pending] and [frontier] accordingly.

71

*)

72

let next_element eq_equiv g sort call pending frontier =

73

begin

74

if ISet.is_empty !pending

75

then

76

begin

77

let choice = ISet.min_elt !frontier in

78

(*Format.eprintf "1> %s@." choice;*)

79

frontier := ISet.remove choice !frontier;

80

let (p, f) = ISet.partition (eq_equiv choice) !frontier in

81

pending := p;

82

frontier := f;

83

call := is_call_output choice g;

84

add_successors eq_equiv g choice pending frontier;

85

if not (ExprDep.is_ghost_var choice)

86

then sort := [choice] :: !sort

87

end

88

else

89

begin

90

let choice = ISet.min_elt !pending in

91

(*Format.eprintf "2> %s@." choice;*)

92

pending := ISet.remove choice !pending;

93

add_successors eq_equiv g choice pending frontier;

94

if not (ExprDep.is_ghost_var choice)

95

then sort := (if !call

96

then (choice :: List.hd !sort) :: List.tl !sort

97

else [choice] :: !sort)

98

end

99

end

100


101


102

(* Topological sort of dependency graph [g], with priority.

103

*)

104

let topological_sort eq_equiv g =

105

let roots = graph_roots g in

106

assert (roots <> []);

107

let call = ref false in

108

let frontier = ref (List.fold_right ISet.add roots ISet.empty) in

109

let pending = ref ISet.empty in

110

let sorted = ref [] in

111

begin

112

while not (ISet.is_empty !frontier && ISet.is_empty !pending)

113

do

114

(*Format.eprintf "frontier = {%a}, pending = {%a}@."

115

(fun fmt > ISet.iter (fun e > Format.pp_print_string fmt e)) !frontier

116

(fun fmt > ISet.iter (fun e > Format.pp_print_string fmt e)) !pending;*)

117

next_element eq_equiv g sorted call pending frontier;

118

done;

119

IdentDepGraph.clear g;

120

!sorted

121

end

122


123

(* Filters out normalization variables and renames instance variables to keep things readable,

124

in a case of a dependency error *)

125

let filter_original n vl =

126

List.fold_right (fun v res >

127

if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else

128

let vdecl = get_node_var v n in

129

if vdecl.var_orig then v :: res else res) vl []

130


131

let schedule_node n =

132

(* let node_vars = get_node_vars n in *)

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


141

(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs

142

compute: coi predecessors of outputs

143

warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)

144

DONE !

145

*)

146


147

let gg = IdentDepGraph.copy g in

148

let sort = topological_sort eq_equiv g in

149

let unused = Liveness.compute_unused_variables n gg in

150

let fanin = Liveness.compute_fanin n gg in

151

{ node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; }

152


153


154

let compute_node_reuse_table report =

155

let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in

156

let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in

157

(*

158

if !Options.print_reuse

159

then

160

begin

161

Log.report ~level:0

162

(fun fmt >

163

Format.fprintf fmt

164

"OPT:%B@." (try (Hashtbl.iter (fun s1 v2 > if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found > true)

165

);

166

Log.report ~level:0

167

(fun fmt >

168

Format.fprintf fmt

169

"OPT:clock disjoint map for node %s: %a"

170

n'.node_id

171

Disjunction.pp_disjoint_map disjoint

172

);

173

Log.report ~level:0

174

(fun fmt >

175

Format.fprintf fmt

176

"OPT:reuse policy for node %s: %a"

177

n'.node_id

178

Liveness.pp_reuse_policy reuse

179

);

180

end;

181

*)

182

reuse

183


184


185

let schedule_prog prog =

186

List.fold_right (

187

fun top_decl (accu_prog, sch_map) >

188

match top_decl.top_decl_desc with

189

 Node nd >

190

let report = schedule_node nd in

191

{top_decl with top_decl_desc = Node report.node}::accu_prog,

192

IMap.add nd.node_id report sch_map

193

 _ > top_decl::accu_prog, sch_map

194

)

195

prog

196

([],IMap.empty)

197


198


199

let compute_prog_reuse_table report =

200

IMap.map compute_node_reuse_table report

201


202

(* removes inlined local variables from schedule report,

203

which are now useless *)

204

let remove_node_inlined_locals locals report =

205

let is_inlined v = IMap.exists (fun l _ > v = l) locals in

206

let schedule' =

207

List.fold_right (fun heads q > let heads' = List.filter (fun v > not (is_inlined v)) heads

208

in if heads' = [] then q else heads'::q)

209

report.schedule [] in

210

begin

211

IMap.iter (fun v _ > Hashtbl.remove report.fanin_table v) locals;

212

IMap.iter (fun v _ > let iv = ExprDep.mk_instance_var v

213

in Liveness.replace_in_dep_graph v iv report.dep_graph) locals;

214

{ report with schedule = schedule' }

215

end

216


217

let remove_prog_inlined_locals removed reuse =

218

IMap.mapi (fun id > remove_node_inlined_locals (IMap.find id removed)) reuse

219


220

let pp_eq_schedule fmt vl =

221

match vl with

222

 [] > assert false

223

 [v] > Format.fprintf fmt "%s" v

224

 _ > Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v > Format.fprintf fmt "%s" v)) vl

225


226

let pp_schedule fmt node_schs =

227

IMap.iter

228

(fun nd report >

229

Format.fprintf fmt "%s schedule: %a@."

230

nd

231

(fprintf_list ~sep:" ; " pp_eq_schedule) report.schedule)

232

node_schs

233


234

let pp_fanin_table fmt node_schs =

235

IMap.iter

236

(fun nd report >

237

Format.fprintf fmt "%s: %a" nd Liveness.pp_fanin report.fanin_table)

238

node_schs

239


240

let pp_dep_graph fmt node_schs =

241

IMap.iter

242

(fun nd report >

243

Format.fprintf fmt "%s dependency graph: %a" nd pp_dep_graph report.dep_graph)

244

node_schs

245


246

let pp_warning_unused fmt node_schs =

247

IMap.iter

248

(fun nd report >

249

let unused = report.unused_vars in

250

if not (ISet.is_empty unused)

251

then

252

let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd > nd  _ > assert false in

253

ISet.iter

254

(fun u >

255

let vu = get_node_var u nd in

256

if vu.var_orig

257

then Format.fprintf fmt " Warning: variable '%s' seems unused@, %a@,@," u Location.pp_loc vu.var_loc)

258

unused

259

)

260

node_schs

261


262


263

(* Local Variables: *)

264

(* compilecommand:"make C .." *)

265

(* End: *)
