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 Graph

16

open Causality

17

open Scheduling_type

18


19

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

20

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

21

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

22

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

23

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

24

In the following functions:

25

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

26

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

27

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

28

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

29

 [sort] is the resulting topological order

30

*)

31


32

(* Checks whether the currently scheduled variable [choice]

33

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

34

let is_call_output choice g =

35

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

36


37

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

38

then removes [v] from [g]

39

*)

40

let add_successors eq_equiv g v pending frontier =

41

let succs_v = IdentDepGraph.succ g v in

42

begin

43

IdentDepGraph.remove_vertex g v;

44

List.iter

45

(fun v' >

46

if is_graph_root v' g then

47

(if eq_equiv v v' then

48

pending := ISet.add v' !pending

49

else

50

frontier := ISet.add v' !frontier)

51

) succs_v;

52

end

53


54

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

55

Modifies [pending] and [frontier] accordingly.

56

*)

57

let next_element eq_equiv g sort call pending frontier =

58

begin

59

if ISet.is_empty !pending

60

then

61

begin

62

let choice = ISet.min_elt !frontier in

63

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

64

frontier := ISet.remove choice !frontier;

65

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

66

pending := p;

67

frontier := f;

68

call := is_call_output choice g;

69

add_successors eq_equiv g choice pending frontier;

70

if not (ExprDep.is_ghost_var choice)

71

then sort := [choice] :: !sort

72

end

73

else

74

begin

75

let choice = ISet.min_elt !pending in

76

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

77

pending := ISet.remove choice !pending;

78

add_successors eq_equiv g choice pending frontier;

79

if not (ExprDep.is_ghost_var choice)

80

then sort := (if !call

81

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

82

else [choice] :: !sort)

83

end

84

end

85


86


87

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

88

*)

89

let topological_sort eq_equiv g =

90

let roots = graph_roots g in

91

assert (roots <> []);

92

let call = ref false in

93

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

94

let pending = ref ISet.empty in

95

let sorted = ref [] in

96

begin

97

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

98

do

99

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

100

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

101

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

102

next_element eq_equiv g sorted call pending frontier;

103

done;

104

IdentDepGraph.clear g;

105

!sorted

106

end

107


108

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

109

in a case of a dependency error *)

110

let filter_original n vl =

111

List.fold_right (fun v res >

112

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

113

let vdecl = get_node_var v n in

114

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

115


116

let eq_equiv eq_equiv_hash =

117

fun v1 v2 >

118

try

119

Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2

120

with Not_found > false

121


122

let schedule_node n =

123

(* let node_vars = get_node_vars n in *)

124

let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in

125


126

let n', g = global_dependency n in

127


128

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

129

compute: coi predecessors of outputs

130

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

131

DONE !

132

*)

133


134

let gg = IdentDepGraph.copy g in

135

let sort = topological_sort eq_equiv g in

136

let unused = Liveness.compute_unused_variables n gg in

137

let fanin = Liveness.compute_fanin n gg in

138

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

139


140

(* let schedule_eqs eqs =

141

* let eq_equiv = eq_equiv (ExprDep.eqs_eq_equiv eqs) in

142

* assert false (\* TODO: continue to implement scheduling of eqs for spec *\) *)

143


144

let compute_node_reuse_table report =

145

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

146

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

147

(*

148

if !Options.print_reuse

149

then

150

begin

151

Log.report ~level:0

152

(fun fmt >

153

Format.fprintf fmt

154

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

155

);

156

Log.report ~level:0

157

(fun fmt >

158

Format.fprintf fmt

159

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

160

n'.node_id

161

Disjunction.pp_disjoint_map disjoint

162

);

163

Log.report ~level:0

164

(fun fmt >

165

Format.fprintf fmt

166

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

167

n'.node_id

168

Liveness.pp_reuse_policy reuse

169

);

170

end;

171

*)

172

reuse

173


174


175

let schedule_prog prog =

176

List.fold_right (

177

fun top_decl (accu_prog, sch_map) >

178

match top_decl.top_decl_desc with

179

 Node nd >

180

let report = schedule_node nd in

181

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

182

IMap.add nd.node_id report sch_map

183

 _ > top_decl::accu_prog, sch_map

184

)

185

prog

186

([],IMap.empty)

187


188


189

let compute_prog_reuse_table report =

190

IMap.map compute_node_reuse_table report

191


192

(* removes inlined local variables from schedule report,

193

which are now useless *)

194

let remove_node_inlined_locals locals report =

195

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

196

let schedule' =

197

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

198

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

199

report.schedule [] in

200

begin

201

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

202

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

203

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

204

{ report with schedule = schedule' }

205

end

206


207

let remove_prog_inlined_locals removed reuse =

208

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

209


210

let pp_eq_schedule fmt vl =

211

match vl with

212

 [] > assert false

213

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

214

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

215


216

let pp_schedule fmt node_schs =

217

IMap.iter

218

(fun nd report >

219

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

220

nd

221

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

222

node_schs

223


224

let pp_fanin_table fmt node_schs =

225

IMap.iter

226

(fun nd report >

227

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

228

node_schs

229


230

let pp_dep_graph fmt node_schs =

231

IMap.iter

232

(fun nd report >

233

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

234

node_schs

235


236

let pp_warning_unused fmt node_schs =

237

IMap.iter

238

(fun nd report >

239

let unused = report.unused_vars in

240

if not (ISet.is_empty unused)

241

then

242

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

243

ISet.iter

244

(fun u >

245

let vu = get_node_var u nd in

246

if vu.var_orig

247

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

248

unused

249

)

250

node_schs

251


252


253

(* Sort eqs according to schedule *)

254

(* Sort the set of equations of node [nd] according

255

to the computed schedule [sch]

256

*)

257

let sort_equations_from_schedule eqs sch =

258

Log.report ~level:10 (fun fmt >

259

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

260

(Utils.fprintf_list ~sep:" ; " pp_eq_schedule) sch);

261

let split_eqs = Splitting.tuple_split_eq_list eqs in

262

(* Flatten schedule *)

263

let sch = List.fold_right (fun vl res > (List.map (fun v > [v]) vl)@res) sch [] in

264

let eqs_rev, remainder =

265

List.fold_left

266

(fun (accu, node_eqs_remainder) vl >

267

(* For each variable in vl, there should exists the equations in accu *)

268

if List.for_all (fun v > List.exists (fun eq > List.mem v eq.eq_lhs) accu) vl

269

then

270

(accu, node_eqs_remainder)

271

else

272

let eq_v, remainder = find_eq vl node_eqs_remainder in

273

eq_v::accu, remainder

274

)

275

([], split_eqs)

276

sch

277

in

278

begin

279

let eqs = List.rev eqs_rev in

280

let unused =

281

if List.length remainder > 0 then (

282

Log.report ~level:3 (fun fmt > Format.fprintf fmt

283

"[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "

284

Printers.pp_node_eqs remainder

285

Printers.pp_node_eqs eqs

286

);

287

let vars = List.fold_left (fun accu eq > eq.eq_lhs @ accu) [] remainder in

288

Log.report ~level:1 (fun fmt > Format.fprintf fmt

289

"[Warning] Unused variables: %a@ "

290

(fprintf_list ~sep:", " Format.pp_print_string)

291

vars

292

);

293

vars

294

)

295

else

296

[]

297

in

298

eqs, unused

299

end

300


301

(* Local Variables: *)

302

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

303

(* End: *)
