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

(* a schedule computed wrt the dependency graph *)

21

schedule : ident list list;

22

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

23

unused_vars : ISet.t;

24

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

25

fanin_table : (ident, int) Hashtbl.t;

26

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

27

reuse_table : (ident, var_decl) Hashtbl.t

28

}

29


30

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

31

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

32

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

33

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

34

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

35

In the following functions:

36

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

37

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

38

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

39

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

40

 [sort] is the resulting topological order

41

*)

42


43

(* Checks whether the currently scheduled variable [choice]

44

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

45

let is_call_output choice g =

46

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

47


48

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

49

then removes [v] from [g]

50

*)

51

let add_successors eq_equiv g v pending frontier =

52

let succs_v = IdentDepGraph.succ g v in

53

begin

54

IdentDepGraph.remove_vertex g v;

55

List.iter

56

(fun v' >

57

if is_graph_root v' g then

58

(if eq_equiv v v' then

59

pending := ISet.add v' !pending

60

else

61

frontier := ISet.add v' !frontier)

62

) succs_v;

63

end

64


65

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

66

Modifies [pending] and [frontier] accordingly.

67

*)

68

let next_element eq_equiv g sort call pending frontier =

69

begin

70

if ISet.is_empty !pending

71

then

72

begin

73

let choice = ISet.min_elt !frontier in

74

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

75

frontier := ISet.remove choice !frontier;

76

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

77

pending := p;

78

frontier := f;

79

call := is_call_output choice g;

80

add_successors eq_equiv g choice pending frontier;

81

if not (ExprDep.is_ghost_var choice)

82

then sort := [choice] :: !sort

83

end

84

else

85

begin

86

let choice = ISet.min_elt !pending in

87

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

88

pending := ISet.remove choice !pending;

89

add_successors eq_equiv g choice pending frontier;

90

if not (ExprDep.is_ghost_var choice)

91

then sort := (if !call

92

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

93

else [choice] :: !sort)

94

end

95

end

96


97


98

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

99

*)

100

let topological_sort eq_equiv g =

101

let roots = graph_roots g in

102

assert (roots <> []);

103

let call = ref false in

104

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

105

let pending = ref ISet.empty in

106

let sorted = ref [] in

107

begin

108

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

109

do

110

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

111

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

112

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

113

next_element eq_equiv g sorted call pending frontier;

114

done;

115

IdentDepGraph.clear g;

116

!sorted

117

end

118


119

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

120

in a case of a dependency error *)

121

let filter_original n vl =

122

List.fold_right (fun v res >

123

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

124

let vdecl = get_node_var v n in

125

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

126


127

let schedule_node n =

128

let node_vars = get_node_vars n in

129

try

130

let eq_equiv = ExprDep.node_eq_equiv n in

131

let eq_equiv v1 v2 =

132

try

133

Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2

134

with Not_found > false in

135


136

let n', g = global_dependency n in

137

Log.report ~level:5

138

(fun fmt >

139

Format.fprintf fmt

140

"dependency graph for node %s: %a"

141

n'.node_id

142

pp_dep_graph g

143

);

144


145

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

146

compute: coi predecessors of outputs

147

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

148

DONE !

149

*)

150


151

let gg = IdentDepGraph.copy g in

152

let sort = topological_sort eq_equiv g in

153

let unused = Liveness.compute_unused_variables n gg in

154

let fanin = Liveness.compute_fanin n gg in

155


156

let (disjoint, reuse) =

157

if !Options.optimization >= 3

158

then

159

let disjoint = Disjunction.clock_disjoint_map node_vars in

160

(disjoint,

161

Liveness.compute_reuse_policy n sort disjoint gg)

162

else

163

(Hashtbl.create 1,

164

Hashtbl.create 1) 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

n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse }

190

with (Causality.Cycle vl) as exc >

191

let vl = filter_original n vl in

192

pp_error Format.err_formatter vl;

193

raise exc

194


195

let schedule_prog prog =

196

List.fold_right (

197

fun top_decl (accu_prog, sch_map) >

198

match top_decl.top_decl_desc with

199

 Node nd >

200

let nd', report = schedule_node nd in

201

{top_decl with top_decl_desc = Node nd'}::accu_prog,

202

IMap.add nd.node_id report sch_map

203

 _ > top_decl::accu_prog, sch_map

204

)

205

prog

206

([],IMap.empty)

207


208

let pp_eq_schedule fmt vl =

209

match vl with

210

 [] > assert false

211

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

212

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

213


214

let pp_schedule fmt node_schs =

215

IMap.iter

216

(fun nd report >

217

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

218

nd

219

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

220

node_schs

221


222

let pp_fanin_table fmt node_schs =

223

IMap.iter

224

(fun nd report >

225

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

226

node_schs

227


228

let pp_warning_unused fmt node_schs =

229

IMap.iter

230

(fun nd report >

231

let unused = report.unused_vars in

232

if not (ISet.is_empty unused)

233

then

234

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

235

ISet.iter

236

(fun u >

237

let vu = get_node_var u nd in

238

if vu.var_orig

239

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

240

unused

241

)

242

node_schs

243


244

(* Local Variables: *)

245

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

246

(* End: *)
