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

try

134

let eq_equiv = ExprDep.node_eq_equiv n in

135

let eq_equiv v1 v2 =

136

try

137

Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2

138

with Not_found > false in

139


140

let n', g = global_dependency n in

141


142

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

143

compute: coi predecessors of outputs

144

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

145

DONE !

146

*)

147


148

let gg = IdentDepGraph.copy g in

149

let sort = topological_sort eq_equiv g in

150

let unused = Liveness.compute_unused_variables n gg in

151

let fanin = Liveness.compute_fanin n gg in

152

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

153


154

with (Causality.Error err) as exc >

155

match err with

156

 DataCycle vl >

157

let _ (*vl*) = filter_original n vl in

158

Causality.pp_error Format.err_formatter err;

159

raise exc

160

 _ > raise exc

161


162

let compute_node_reuse_table report =

163

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

164

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

165

(*

166

if !Options.print_reuse

167

then

168

begin

169

Log.report ~level:0

170

(fun fmt >

171

Format.fprintf fmt

172

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

173

);

174

Log.report ~level:0

175

(fun fmt >

176

Format.fprintf fmt

177

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

178

n'.node_id

179

Disjunction.pp_disjoint_map disjoint

180

);

181

Log.report ~level:0

182

(fun fmt >

183

Format.fprintf fmt

184

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

185

n'.node_id

186

Liveness.pp_reuse_policy reuse

187

);

188

end;

189

*)

190

reuse

191


192


193

let schedule_prog prog =

194

List.fold_right (

195

fun top_decl (accu_prog, sch_map) >

196

match top_decl.top_decl_desc with

197

 Node nd >

198

let report = schedule_node nd in

199

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

200

IMap.add nd.node_id report sch_map

201

 _ > top_decl::accu_prog, sch_map

202

)

203

prog

204

([],IMap.empty)

205


206


207

let compute_prog_reuse_table report =

208

IMap.map compute_node_reuse_table report

209


210

(* removes inlined local variables from schedule report,

211

which are now useless *)

212

let remove_node_inlined_locals locals report =

213

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

214

let schedule' =

215

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

216

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

217

report.schedule [] in

218

begin

219

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

220

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

221

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

222

{ report with schedule = schedule' }

223

end

224


225

let remove_prog_inlined_locals removed reuse =

226

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

227


228

let pp_eq_schedule fmt vl =

229

match vl with

230

 [] > assert false

231

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

232

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

233


234

let pp_schedule fmt node_schs =

235

IMap.iter

236

(fun nd report >

237

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

238

nd

239

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

240

node_schs

241


242

let pp_fanin_table fmt node_schs =

243

IMap.iter

244

(fun nd report >

245

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

246

node_schs

247


248

let pp_dep_graph fmt node_schs =

249

IMap.iter

250

(fun nd report >

251

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

252

node_schs

253


254

let pp_warning_unused fmt node_schs =

255

IMap.iter

256

(fun nd report >

257

let unused = report.unused_vars in

258

if not (ISet.is_empty unused)

259

then

260

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

261

ISet.iter

262

(fun u >

263

let vu = get_node_var u nd in

264

if vu.var_orig

265

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

266

unused

267

)

268

node_schs

269


270


271

(* Local Variables: *)

272

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

273

(* End: *)
