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 lhs.

19

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

20

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

21

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

22

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

23

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

26

 [pending] is the 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 [pending]

28

 [sort] is the resulting topological order

29

*)

30


31

(* Checks whether the currently scheduled variable [choice]

32

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

33

let is_call_output choice g =

34

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

35


36

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

37

then removes [v] from [g]

38

*)

39

let add_successors eq_equiv g v pending frontier =

40

let succs_v = IdentDepGraph.succ g v in

41

begin

42

IdentDepGraph.remove_vertex g v;

43

List.iter

44

(fun v' >

45

if is_graph_root v' g then

46

(if eq_equiv v v' then

47

pending := ISet.add v' !pending

48

else

49

frontier := ISet.add v' !frontier)

50

) succs_v;

51

end

52


53

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

54

Modifies [pending] and [frontier] accordingly.

55

*)

56

let next_element eq_equiv g sort call pending frontier =

57

begin

58

if ISet.is_empty !pending

59

then

60

begin

61

let choice = ISet.min_elt !frontier in

62

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

63

frontier := ISet.remove choice !frontier;

64

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

65

pending := p;

66

frontier := f;

67

call := is_call_output choice g;

68

add_successors eq_equiv g choice pending frontier;

69

if not (ExprDep.is_ghost_var choice)

70

then sort := [choice] :: !sort

71

end

72

else

73

begin

74

let choice = ISet.min_elt !pending in

75

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

76

pending := ISet.remove choice !pending;

77

add_successors eq_equiv g choice pending frontier;

78

if not (ExprDep.is_ghost_var choice)

79

then sort := (if !call

80

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

81

else [choice] :: !sort)

82

end

83

end

84


85


86

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

87

*)

88

let topological_sort eq_equiv g =

89

let roots = graph_roots g in

90

assert (roots <> []);

91

let call = ref false in

92

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

93

let pending = ref ISet.empty in

94

let sorted = ref [] in

95

begin

96

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

97

do

98

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

99

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

100

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

101

next_element eq_equiv g sorted call pending frontier;

102

done;

103

IdentDepGraph.clear g;

104

!sorted

105

end

106


107

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

108

in a case of a dependency error *)

109

let filter_original n vl =

110

List.fold_right (fun v res >

111

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

112

let vdecl = get_node_var v n in

113

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

114


115

let eq_equiv eq_equiv_hash =

116

fun v1 v2 >

117

try

118

Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2

119

with Not_found > false

120


121

let schedule_node n =

122

(* let node_vars = get_node_vars n in *)

123

Log.report ~level:5 (fun fmt > Format.fprintf fmt "scheduling node %s@ " n.node_id);

124

let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in

125


126

let node, 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 dep_graph = IdentDepGraph.copy g in

135

let schedule = topological_sort eq_equiv g in

136

let unused_vars = Liveness.compute_unused_variables n dep_graph in

137

let fanin_table = Liveness.compute_fanin n dep_graph in

138

{ node; schedule; unused_vars; fanin_table; dep_graph }

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

(pp_print_list ~pp_sep:pp_print_semicolon pp_eq_schedule)

222

report.schedule))

223

node_schs

224


225

let pp_fanin_table fmt node_schs =

226

IMap.iter

227

(fun nd report >

228

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

229

node_schs

230


231

let pp_dep_graph fmt node_schs =

232

IMap.iter

233

(fun nd report >

234

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

235

node_schs

236


237

let pp_warning_unused fmt node_schs =

238

IMap.iter

239

(fun nd report >

240

let unused = report.unused_vars in

241

if not (ISet.is_empty unused)

242

then

243

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

244

ISet.iter

245

(fun u >

246

let vu = get_node_var u nd in

247

if vu.var_orig

248

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

249

unused

250

)

251

node_schs

252


253


254

(* Sort eqs according to schedule *)

255

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

256

to the computed schedule [sch]

257

*)

258

let sort_equations_from_schedule eqs sch =

259

Log.report ~level:10 (fun fmt >

260

Format.fprintf fmt "schedule: %a@ "

261

(Format.pp_print_list

262

~pp_sep:Format.pp_print_semicolon pp_eq_schedule) sch);

263

let split_eqs = Splitting.tuple_split_eq_list eqs in

264

(* Flatten schedule *)

265

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

266

let eqs_rev, remainder =

267

List.fold_left

268

(fun (accu, node_eqs_remainder) vl >

269

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

270

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

271

then

272

(accu, node_eqs_remainder)

273

else

274

let eq_v, remainder = find_eq vl node_eqs_remainder in

275

eq_v::accu, remainder

276

)

277

([], split_eqs)

278

sch

279

in

280

begin

281

let eqs = List.rev eqs_rev in

282

let unused =

283

if List.length remainder > 0 then (

284

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

285

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

286

Printers.pp_node_eqs remainder

287

Printers.pp_node_eqs eqs

288

);

289

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

290

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

291

"[Warning] Unused variables: %a@ "

292

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

293

vars

294

);

295

vars

296

)

297

else

298

[]

299

in

300

eqs, unused

301

end

302


303

(* Local Variables: *)

304

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

305

(* End: *)
