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 Causality

16

open Machine_code

17

open Dimension

18


19

let pp_elim fmt elim =

20

begin

21

Format.fprintf fmt "{ /* elim table: */@.";

22

IMap.iter (fun v expr > Format.fprintf fmt "%s > %a@." v pp_val expr) elim;

23

Format.fprintf fmt "}@.";

24

end

25


26

let rec eliminate elim instr =

27

let e_expr = eliminate_expr elim in

28

match instr with

29

 MLocalAssign (i,v) > MLocalAssign (i, e_expr v)

30

 MStateAssign (i,v) > MStateAssign (i, e_expr v)

31

 MReset i > instr

32

 MStep (il, i, vl) > MStep(il, i, List.map e_expr vl)

33

 MBranch (g,hl) >

34

MBranch

35

(e_expr g,

36

(List.map

37

(fun (l, il) > l, List.map (eliminate elim) il)

38

hl

39

)

40

)

41


42

and eliminate_expr elim expr =

43

match expr with

44

 StateVar v

45

 LocalVar v > (try IMap.find v.var_id elim with Not_found > expr)

46

 Fun (id, vl) > Fun (id, List.map (eliminate_expr elim) vl)

47

 Array(vl) > Array(List.map (eliminate_expr elim) vl)

48

 Access(v1, v2) > Access(eliminate_expr elim v1, eliminate_expr elim v2)

49

 Power(v1, v2) > Power(eliminate_expr elim v1, eliminate_expr elim v2)

50

 Cst _ > expr

51


52

let eliminate_dim elim dim =

53

Dimension.expr_replace_expr (fun v > try dimension_of_value (IMap.find v elim) with Not_found > mkdim_ident dim.dim_loc v) dim

54


55

let is_scalar_const c =

56

match c with

57

 Const_int _

58

 Const_real _

59

 Const_float _

60

 Const_tag _ > true

61

 _ > false

62


63

let basic_unfoldable_expr expr =

64

match expr with

65

 Cst c when is_scalar_const c > true

66

 LocalVar _

67

 StateVar _ > true

68

 _ > false

69


70

let unfoldable_assign fanin v expr =

71

try

72

let d = Hashtbl.find fanin v.var_id

73

in basic_unfoldable_expr expr 

74

match expr with

75

 Cst c when d < 2 > true

76

 Fun (id, _) when d < 2 && Basic_library.is_internal_fun id > true

77

 _ > false

78

with Not_found > false

79


80

let merge_elim elim1 elim2 =

81

let merge k e1 e2 =

82

match e1, e2 with

83

 Some e1, Some e2 > if e1 = e2 then Some e1 else None

84

 _ , Some e2 > Some e2

85

 Some e1, _ > Some e1

86

 _ > None

87

in IMap.merge merge elim1 elim2

88


89

(* see if elim has to take in account the provided instr:

90

if so, update elim and return the remove flag,

91

otherwise, the expression should be kept and elim is left untouched *)

92

let rec instrs_unfold fanin elim instrs =

93

let elim, rev_instrs =

94

List.fold_left (fun (elim, instrs) instr >

95

(* each subexpression in instr that could be rewritten by the elim set is

96

rewritten *)

97

let instr = eliminate elim instr in

98

(* if instr is a simple local assign, then (a) elim is simplified with it (b) it

99

is stored as the elim set *)

100

instr_unfold fanin instrs elim instr

101

) (elim, []) instrs

102

in elim, List.rev rev_instrs

103


104

and instr_unfold fanin instrs elim instr =

105

(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)

106

match instr with

107

(* Simple cases*)

108

 MStep([v], id, vl) when Basic_library.is_internal_fun id

109

> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl)))

110

 MLocalAssign(v, expr) when unfoldable_assign fanin v expr

111

> (IMap.add v.var_id expr elim, instrs)

112

 MBranch(g, hl) when false

113

> let elim_branches = List.map (fun (h, l) > (h, instrs_unfold fanin elim l)) hl in

114

let (elim, branches) =

115

List.fold_right

116

(fun (h, (e, l)) (elim, branches) > (merge_elim elim e, (h, l)::branches))

117

elim_branches (elim, [])

118

in elim, (MBranch (g, branches) :: instrs)

119

 _

120

> (elim, instr :: instrs)

121

(* default case, we keep the instruction and do not modify elim *)

122


123


124

(** We iterate in the order, recording simple local assigns in an accumulator

125

1. each expression is rewritten according to the accumulator

126

2. local assigns then rewrite occurrences of the lhs in the computed accumulator

127

*)

128


129

let static_call_unfold elim (inst, (n, args)) =

130

let replace v =

131

try

132

Machine_code.dimension_of_value (IMap.find v elim)

133

with Not_found > Dimension.mkdim_ident Location.dummy_loc v

134

in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))

135


136

(** Perform optimization on machine code:

137

 iterate through step instructions and remove simple local assigns

138


139

*)

140

let machine_unfold fanin elim machine =

141

(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)

142

let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in

143

let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in

144

let locals = List.filter (fun v > not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in

145

let minstances = List.map (static_call_unfold elim_consts) machine.minstances in

146

let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls

147

in

148

{

149

machine with

150

mstep = {

151

machine.mstep with

152

step_locals = locals;

153

step_instrs = instrs

154

};

155

mconst = mconst;

156

minstances = minstances;

157

mcalls = mcalls;

158

}

159


160

let instr_of_const top_const =

161

let const = const_of_top top_const in

162

let vdecl = mkvar_decl Location.dummy_loc (const.const_id, mktyp Location.dummy_loc Tydec_any, mkclock Location.dummy_loc Ckdec_any, true, None) in

163

let vdecl = { vdecl with var_type = const.const_type }

164

in MLocalAssign (vdecl, Cst const.const_value)

165


166

let machines_unfold consts node_schs machines =

167

List.map

168

(fun m >

169

let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in

170

let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts)

171

in machine_unfold fanin elim_consts m)

172

machines

173


174

let get_assign_lhs instr =

175

match instr with

176

 MLocalAssign(v, _) > LocalVar v

177

 MStateAssign(v, _) > StateVar v

178

 _ > assert false

179


180

let get_assign_rhs instr =

181

match instr with

182

 MLocalAssign(_, e)

183

 MStateAssign(_, e) > e

184

 _ > assert false

185


186

let is_assign instr =

187

match instr with

188

 MLocalAssign _

189

 MStateAssign _ > true

190

 _ > false

191


192

let mk_assign v e =

193

match v with

194

 LocalVar v > MLocalAssign(v, e)

195

 StateVar v > MStateAssign(v, e)

196

 _ > assert false

197


198

let rec assigns_instr instr assign =

199

match instr with

200

 MLocalAssign (i,_)

201

 MStateAssign (i,_) > ISet.add i assign

202

 MStep (ol, _, _) > List.fold_right ISet.add ol assign

203

 MBranch (_,hl) > List.fold_right (fun (_, il) > assigns_instrs il) hl assign

204

 _ > assign

205


206

and assigns_instrs instrs assign =

207

List.fold_left (fun assign instr > assigns_instr instr assign) assign instrs

208


209

(*

210

and substitute_expr subst expr =

211

match expr with

212

 StateVar v

213

 LocalVar v > (try IMap.find expr subst with Not_found > expr)

214

 Fun (id, vl) > Fun (id, List.map (substitute_expr subst) vl)

215

 Array(vl) > Array(List.map (substitute_expr subst) vl)

216

 Access(v1, v2) > Access(substitute_expr subst v1, substitute_expr subst v2)

217

 Power(v1, v2) > Power(substitute_expr subst v1, substitute_expr subst v2)

218

 Cst _ > expr

219

*)

220

(** Finds a substitute for [instr] in [instrs],

221

i.e. another instr' with the same rhs expression.

222

Then substitute this expression with the first assigned var

223

*)

224

let subst_instr subst instrs instr =

225

(*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*)

226

let instr = eliminate subst instr in

227

let v = get_assign_lhs instr in

228

let e = get_assign_rhs instr in

229

try

230

let instr' = List.find (fun instr' > is_assign instr' && get_assign_rhs instr' = e) instrs in

231

match v with

232

 LocalVar v >

233

IMap.add v.var_id (get_assign_lhs instr') subst, instrs

234

 StateVar v >

235

(match get_assign_lhs instr' with

236

 LocalVar v' >

237

let instr = eliminate subst (mk_assign (StateVar v) (LocalVar v')) in

238

subst, instr :: instrs

239

 StateVar v' >

240

let subst_v' = IMap.add v'.var_id (StateVar v) IMap.empty in

241

let instrs' = snd (List.fold_right (fun instr (ok, instrs) > (ok  instr = instr', if ok then instr :: instrs else if instr = instr' then instrs else eliminate subst_v' instr :: instrs)) instrs (false, [])) in

242

IMap.add v'.var_id (StateVar v) subst, instr :: instrs'

243

 _ > assert false)

244

 _ > assert false

245

with Not_found > subst, instr :: instrs

246


247

(** Common subexpression elimination for machine instructions *)

248

(*  [subst] : hashtable from ident to (simple) definition

249

it is an equivalence table

250

 [elim] : set of eliminated variables

251

 [instrs] : previous instructions, which [instr] is compared against

252

 [instr] : current instruction, normalized by [subst]

253

*)

254

let rec instr_cse (subst, instrs) instr =

255

match instr with

256

(* Simple cases*)

257

 MStep([v], id, vl) when Basic_library.is_internal_fun id

258

> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl)))

259

 MLocalAssign(v, expr) when basic_unfoldable_expr expr

260

> (IMap.add v.var_id expr subst, instr :: instrs)

261

 _ when is_assign instr

262

> subst_instr subst instrs instr

263

 _ > (subst, instr :: instrs)

264


265

(** Apply common subexpression elimination to a sequence of instrs

266

*)

267

let rec instrs_cse subst instrs =

268

let subst, rev_instrs =

269

List.fold_left instr_cse (subst, []) instrs

270

in subst, List.rev rev_instrs

271


272

(** Apply common subexpression elimination to a machine

273

 iterate through step instructions and remove simple local assigns

274

*)

275

let machine_cse subst machine =

276

(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)

277

let subst, instrs = instrs_cse subst machine.mstep.step_instrs in

278

let assigned = assigns_instrs instrs ISet.empty

279

in

280

{

281

machine with

282

mmemory = List.filter (fun vdecl > ISet.mem vdecl assigned) machine.mmemory;

283

mstep = {

284

machine.mstep with

285

step_locals = List.filter (fun vdecl > ISet.mem vdecl assigned) machine.mstep.step_locals;

286

step_instrs = instrs

287

}

288

}

289


290

let machines_cse machines =

291

List.map

292

(machine_cse IMap.empty)

293

machines

294


295

(* variable substitution for optimizing purposes *)

296


297

(* checks whether an [instr] is skip and can be removed from program *)

298

let rec instr_is_skip instr =

299

match instr with

300

 MLocalAssign (i, LocalVar v) when i = v > true

301

 MStateAssign (i, StateVar v) when i = v > true

302

 MBranch (g, hl) > List.for_all (fun (_, il) > instrs_are_skip il) hl

303

 _ > false

304

and instrs_are_skip instrs =

305

List.for_all instr_is_skip instrs

306


307

let instr_cons instr cont =

308

if instr_is_skip instr then cont else instr::cont

309


310

let rec instr_remove_skip instr cont =

311

match instr with

312

 MLocalAssign (i, LocalVar v) when i = v > cont

313

 MStateAssign (i, StateVar v) when i = v > cont

314

 MBranch (g, hl) > MBranch (g, List.map (fun (h, il) > (h, instrs_remove_skip il [])) hl) :: cont

315

 _ > instr::cont

316


317

and instrs_remove_skip instrs cont =

318

List.fold_right instr_remove_skip instrs cont

319


320

let rec value_replace_var fvar value =

321

match value with

322

 Cst c > value

323

 LocalVar v > LocalVar (fvar v)

324

 StateVar v > value

325

 Fun (id, args) > Fun (id, List.map (value_replace_var fvar) args)

326

 Array vl > Array (List.map (value_replace_var fvar) vl)

327

 Access (t, i) > Access(value_replace_var fvar t, i)

328

 Power (v, n) > Power(value_replace_var fvar v, n)

329


330

let rec instr_replace_var fvar instr cont =

331

match instr with

332

 MLocalAssign (i, v) > instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont

333

 MStateAssign (i, v) > instr_cons (MStateAssign (i, value_replace_var fvar v)) cont

334

 MReset i > instr_cons instr cont

335

 MStep (il, i, vl) > instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont

336

 MBranch (g, hl) > instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) > (h, instrs_replace_var fvar il [])) hl)) cont

337


338

and instrs_replace_var fvar instrs cont =

339

List.fold_right (instr_replace_var fvar) instrs cont

340


341

let step_replace_var fvar step =

342

(* Some outputs may have been replaced by locals.

343

We then need to rename those outputs

344

without changing their clocks, etc *)

345

let outputs' =

346

List.map (fun o > { o with var_id = (fvar o).var_id }) step.step_outputs in

347

let locals' =

348

List.fold_left (fun res l >

349

let l' = fvar l in

350

if List.exists (fun o > o.var_id = l'.var_id) outputs'

351

then res

352

else Utils.add_cons l' res)

353

[] step.step_locals in

354

{ step with

355

step_checks = List.map (fun (l, v) > (l, value_replace_var fvar v)) step.step_checks;

356

step_outputs = outputs';

357

step_locals = locals';

358

step_instrs = instrs_replace_var fvar step.step_instrs [];

359

}

360


361

let rec machine_replace_variables fvar m =

362

{ m with

363

mstep = step_replace_var fvar m.mstep

364

}

365


366

let machine_reuse_variables m reuse =

367

let fvar v =

368

try

369

Hashtbl.find reuse v.var_id

370

with Not_found > v in

371

machine_replace_variables fvar m

372


373

let machines_reuse_variables prog node_schs =

374

List.map

375

(fun m >

376

machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table

377

) prog

378


379

let rec instr_assign res instr =

380

match instr with

381

 MLocalAssign (i, _) > Disjunction.CISet.add i res

382

 MStateAssign (i, _) > Disjunction.CISet.add i res

383

 MBranch (g, hl) > List.fold_left (fun res (h, b) > instrs_assign res b) res hl

384

 MStep (il, _, _) > List.fold_right Disjunction.CISet.add il res

385

 _ > res

386


387

and instrs_assign res instrs =

388

List.fold_left instr_assign res instrs

389


390

let rec instr_constant_assign var instr =

391

match instr with

392

 MLocalAssign (i, Cst (Const_tag _))

393

 MStateAssign (i, Cst (Const_tag _)) > i = var

394

 MBranch (g, hl) > List.for_all (fun (h, b) > instrs_constant_assign var b) hl

395

 _ > false

396


397

and instrs_constant_assign var instrs =

398

List.fold_left (fun res i > if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then instr_constant_assign var i else res) false instrs

399


400

let rec instr_reduce branches instr1 cont =

401

match instr1 with

402

 MLocalAssign (_, Cst (Const_tag c)) > instr1 :: (List.assoc c branches @ cont)

403

 MStateAssign (_, Cst (Const_tag c)) > instr1 :: (List.assoc c branches @ cont)

404

 MBranch (g, hl) > MBranch (g, List.map (fun (h, b) > (h, instrs_reduce branches b [])) hl) :: cont

405

 _ > instr1 :: cont

406


407

and instrs_reduce branches instrs cont =

408

match instrs with

409

 [] > cont

410

 [i] > instr_reduce branches i cont

411

 i1::i2::q > i1 :: instrs_reduce branches (i2::q) cont

412


413

let rec instrs_fusion instrs =

414

match instrs with

415

 []

416

 [_] >

417

instrs

418

 i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 >

419

instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q)

420

 i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 >

421

instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q)

422

 i1::i2::q >

423

i1 :: instrs_fusion (i2::q)

424


425

let step_fusion step =

426

{ step with

427

step_instrs = instrs_fusion step.step_instrs;

428

}

429


430

let rec machine_fusion m =

431

{ m with

432

mstep = step_fusion m.mstep

433

}

434


435

let machines_fusion prog =

436

List.map machine_fusion prog

437


438

(* Local Variables: *)

439

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

440

(* End: *)
