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


20

let pp_elim fmt elim =

21

begin

22

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

23

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

24

Format.fprintf fmt "}@.";

25

end

26


27

let rec eliminate elim instr =

28

let e_expr = eliminate_expr elim in

29

match instr with

30

 MComment _ > instr

31

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

32

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

33

 MReset i > instr

34

 MNoReset i > instr

35

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

36

 MBranch (g,hl) >

37

MBranch

38

(e_expr g,

39

(List.map

40

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

41

hl

42

)

43

)

44


45

and eliminate_expr elim expr =

46

match expr.value_desc with

47

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

48

 Fun (id, vl) > {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)}

49

 Array(vl) > {expr with value_desc = Array(List.map (eliminate_expr elim) vl)}

50

 Access(v1, v2) > { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)}

51

 Power(v1, v2) > { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)}

52

 Cst _  StateVar _ > expr

53


54

let eliminate_dim elim dim =

55

Dimension.expr_replace_expr

56

(fun v > try

57

dimension_of_value (IMap.find v elim)

58

with Not_found > mkdim_ident dim.dim_loc v)

59

dim

60


61

let unfold_expr_offset m offset expr =

62

List.fold_left

63

(fun res > (function  Index i > mk_val (Access (res, value_of_dimension m i))

64

(Types.array_element_type res.value_type)

65

 Field f > Format.eprintf "internal error: not yet implemented !"; assert false))

66

expr offset

67


68

let rec simplify_cst_expr m offset typ cst =

69

match offset, cst with

70

 [] , _

71

> mk_val (Cst cst) typ

72

 Index i :: q, Const_array cl when Dimension.is_dimension_const i

73

> let elt_typ = Types.array_element_type typ in

74

simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const_dimension i))

75

 Index i :: q, Const_array cl

76

> let elt_typ = Types.array_element_type typ in

77

unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ)

78

 Field f :: q, Const_struct fl

79

> let fld_typ = Types.struct_field_type typ f in

80

simplify_cst_expr m q fld_typ (List.assoc f fl)

81

 _ > (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false)

82


83

let simplify_expr_offset m expr =

84

let rec simplify offset expr =

85

match offset, expr.value_desc with

86

 Field f ::q , _ > failwith "not yet implemented"

87

 _ , Fun (id, vl) when Basic_library.is_value_internal_fun expr

88

> mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type

89

 _ , Fun _

90

 _ , StateVar _

91

 _ , LocalVar _ > unfold_expr_offset m offset expr

92

 _ , Cst cst > simplify_cst_expr m offset expr.value_type cst

93

 _ , Access (expr, i) > simplify (Index (dimension_of_value i) :: offset) expr

94

 [] , _ > expr

95

 Index _ :: q, Power (expr, _) > simplify q expr

96

 Index i :: q, Array vl when Dimension.is_dimension_const i

97

> simplify q (List.nth vl (Dimension.size_const_dimension i))

98

 Index i :: q, Array vl > unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify q) vl)) expr.value_type)

99

(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res)

100

with e > (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*)

101

in simplify [] expr

102


103

let rec simplify_instr_offset m instr =

104

match instr with

105

 MLocalAssign (v, expr) > MLocalAssign (v, simplify_expr_offset m expr)

106

 MStateAssign (v, expr) > MStateAssign (v, simplify_expr_offset m expr)

107

 MReset id > instr

108

 MNoReset id > instr

109

 MStep (outputs, id, inputs) > MStep (outputs, id, List.map (simplify_expr_offset m) inputs)

110

 MBranch (cond, brl)

111

> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) > l, simplify_instrs_offset m il) brl)

112

 MComment _ > instr

113


114

and simplify_instrs_offset m instrs =

115

List.map (simplify_instr_offset m) instrs

116


117

let is_scalar_const c =

118

match c with

119

 Const_real _

120

 Const_int _

121

 Const_tag _ > true

122

 _ > false

123


124

(* An instruction v = expr may (and will) be unfolded iff:

125

 either expr is atomic

126

(no complex expressions, only const, vars and array/struct accesses)

127

 or v has a fanin <= 1 (used at most once)

128

*)

129

let is_unfoldable_expr fanin expr =

130

let rec unfold_const offset cst =

131

match offset, cst with

132

 _ , Const_int _

133

 _ , Const_real _

134

 _ , Const_tag _ > true

135

 Field f :: q, Const_struct fl > unfold_const q (List.assoc f fl)

136

 [] , Const_struct _ > false

137

 Index i :: q, Const_array cl when Dimension.is_dimension_const i

138

> unfold_const q (List.nth cl (Dimension.size_const_dimension i))

139

 _ , Const_array _ > false

140

 _ > assert false in

141

let rec unfold offset expr =

142

match offset, expr.value_desc with

143

 _ , Cst cst > unfold_const offset cst

144

 _ , LocalVar _

145

 _ , StateVar _ > true

146

 [] , Power _

147

 [] , Array _ > false

148

 Index i :: q, Power (v, _) > unfold q v

149

 Index i :: q, Array vl when Dimension.is_dimension_const i

150

> unfold q (List.nth vl (Dimension.size_const_dimension i))

151

 _ , Array _ > false

152

 _ , Access (v, i) > unfold (Index (dimension_of_value i) :: offset) v

153

 _ , Fun (id, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr

154

> List.for_all (unfold offset) vl

155

 _ , Fun _ > false

156

 _ > assert false

157

in unfold [] expr

158


159

let basic_unfoldable_assign fanin v expr =

160

try

161

let d = Hashtbl.find fanin v.var_id

162

in is_unfoldable_expr d expr

163

with Not_found > false

164


165

let unfoldable_assign fanin v expr =

166

(if !Options.mpfr then Mpfr.unfoldable_value expr else true)

167

&& basic_unfoldable_assign fanin v expr

168


169

let merge_elim elim1 elim2 =

170

let merge k e1 e2 =

171

match e1, e2 with

172

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

173

 _ , Some e2 > Some e2

174

 Some e1, _ > Some e1

175

 _ > None

176

in IMap.merge merge elim1 elim2

177


178

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

179

if so, update elim and return the remove flag,

180

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

181

let rec instrs_unfold fanin elim instrs =

182

let elim, rev_instrs =

183

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

184

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

185

rewritten *)

186

let instr = eliminate elim instr in

187

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

188

is stored as the elim set *)

189

instr_unfold fanin instrs elim instr

190

) (elim, []) instrs

191

in elim, List.rev rev_instrs

192


193

and instr_unfold fanin instrs elim instr =

194

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

195

match instr with

196

(* Simple cases*)

197

 MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)

198

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

199

 MLocalAssign(v, expr) when unfoldable_assign fanin v expr

200

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

201

 MBranch(g, hl) when false

202

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

203

let (elim, branches) =

204

List.fold_right

205

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

206

elim_branches (elim, [])

207

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

208

 _

209

> (elim, instr :: instrs)

210

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

211


212


213

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

214

1. each expression is rewritten according to the accumulator

215

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

216

*)

217


218

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

219

let replace v =

220

try

221

Machine_code.dimension_of_value (IMap.find v elim)

222

with Not_found > Dimension.mkdim_ident Location.dummy_loc v

223

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

224


225

(** Perform optimization on machine code:

226

 iterate through step instructions and remove simple local assigns

227


228

*)

229

let machine_unfold fanin elim machine =

230

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

231

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

232

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

233

let instrs = simplify_instrs_offset machine instrs in

234

let checks = List.map (fun (loc, check) > loc, eliminate_expr elim_vars check) machine.mstep.step_checks in

235

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

236

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

237

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

238

in

239

{

240

machine with

241

mstep = {

242

machine.mstep with

243

step_locals = locals;

244

step_instrs = instrs;

245

step_checks = checks

246

};

247

mconst = mconst;

248

minstances = minstances;

249

mcalls = mcalls;

250

},

251

elim_vars

252


253

let instr_of_const top_const =

254

let const = const_of_top top_const in

255

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

256

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

257

in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type)

258


259

let machines_unfold consts node_schs machines =

260

List.fold_right (fun m (machines, removed) >

261

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

262

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

263

let (m, removed_m) = machine_unfold fanin elim_consts m in

264

(m::machines, IMap.add m.mname.node_id removed_m removed)

265

)

266

machines

267

([], IMap.empty)

268


269

let get_assign_lhs instr =

270

match instr with

271

 MLocalAssign(v, e) > mk_val (LocalVar v) e.value_type

272

 MStateAssign(v, e) > mk_val (StateVar v) e.value_type

273

 _ > assert false

274


275

let get_assign_rhs instr =

276

match instr with

277

 MLocalAssign(_, e)

278

 MStateAssign(_, e) > e

279

 _ > assert false

280


281

let is_assign instr =

282

match instr with

283

 MLocalAssign _

284

 MStateAssign _ > true

285

 _ > false

286


287

let mk_assign v e =

288

match v.value_desc with

289

 LocalVar v > MLocalAssign(v, e)

290

 StateVar v > MStateAssign(v, e)

291

 _ > assert false

292


293

let rec assigns_instr instr assign =

294

match instr with

295

 MLocalAssign (i,_)

296

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

297

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

298

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

299

 _ > assign

300


301

and assigns_instrs instrs assign =

302

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

303


304

(*

305

and substitute_expr subst expr =

306

match expr with

307

 StateVar v

308

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

309

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

310

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

311

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

312

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

313

 Cst _ > expr

314

*)

315

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

316

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

317

Then substitute this expression with the first assigned var

318

*)

319

let subst_instr subst instrs instr =

320

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

321

let instr = eliminate subst instr in

322

let v = get_assign_lhs instr in

323

let e = get_assign_rhs instr in

324

try

325

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

326

match v.value_desc with

327

 LocalVar v >

328

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

329

 StateVar stv >

330

let lhs = get_assign_lhs instr' in

331

(match lhs.value_desc with

332

 LocalVar v' >

333

let instr = eliminate subst (mk_assign v lhs) in

334

subst, instr :: instrs

335

 StateVar stv' >

336

let subst_v' = IMap.add stv'.var_id v IMap.empty in

337

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

338

IMap.add stv'.var_id v subst, instr :: instrs'

339

 _ > assert false)

340

 _ > assert false

341

with Not_found > subst, instr :: instrs

342


343

(** Common subexpression elimination for machine instructions *)

344

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

345

it is an equivalence table

346

 [elim] : set of eliminated variables

347

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

348

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

349

*)

350

let rec instr_cse (subst, instrs) instr =

351

match instr with

352

(* Simple cases*)

353

 MStep([v], id, vl) when Basic_library.is_internal_fun id (List.map (fun v > v.value_type) vl)

354

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

355

 MLocalAssign(v, expr) when is_unfoldable_expr 2 expr

356

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

357

 _ when is_assign instr

358

> subst_instr subst instrs instr

359

 _ > (subst, instr :: instrs)

360


361

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

362

*)

363

let rec instrs_cse subst instrs =

364

let subst, rev_instrs =

365

List.fold_left instr_cse (subst, []) instrs

366

in subst, List.rev rev_instrs

367


368

(** Apply common subexpression elimination to a machine

369

 iterate through step instructions and remove simple local assigns

370

*)

371

let machine_cse subst machine =

372

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

373

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

374

let assigned = assigns_instrs instrs ISet.empty

375

in

376

{

377

machine with

378

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

379

mstep = {

380

machine.mstep with

381

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

382

step_instrs = instrs

383

}

384

}

385


386

let machines_cse machines =

387

List.map

388

(machine_cse IMap.empty)

389

machines

390


391

(* variable substitution for optimizing purposes *)

392


393

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

394

let rec instr_is_skip instr =

395

match instr with

396

 MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v > true

397

 MStateAssign (i, { value_desc = StateVar v; _}) when i = v > true

398

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

399

 _ > false

400

and instrs_are_skip instrs =

401

List.for_all instr_is_skip instrs

402


403

let instr_cons instr cont =

404

if instr_is_skip instr then cont else instr::cont

405


406

let rec instr_remove_skip instr cont =

407

match instr with

408

 MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v > cont

409

 MStateAssign (i, { value_desc = StateVar v; _ }) when i = v > cont

410

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

411

 _ > instr::cont

412


413

and instrs_remove_skip instrs cont =

414

List.fold_right instr_remove_skip instrs cont

415


416

let rec value_replace_var fvar value =

417

match value.value_desc with

418

 Cst c > value

419

 LocalVar v > { value with value_desc = LocalVar (fvar v) }

420

 StateVar v > value

421

 Fun (id, args) > { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }

422

 Array vl > { value with value_desc = Array (List.map (value_replace_var fvar) vl)}

423

 Access (t, i) > { value with value_desc = Access(value_replace_var fvar t, i)}

424

 Power (v, n) > { value with value_desc = Power(value_replace_var fvar v, n)}

425


426

let rec instr_replace_var fvar instr cont =

427

match instr with

428

 MComment _ > instr_cons instr cont

429

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

430

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

431

 MReset i > instr_cons instr cont

432

 MNoReset i > instr_cons instr cont

433

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

434

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

435


436

and instrs_replace_var fvar instrs cont =

437

List.fold_right (instr_replace_var fvar) instrs cont

438


439

let step_replace_var fvar step =

440

(* Some outputs may have been replaced by locals.

441

We then need to rename those outputs

442

without changing their clocks, etc *)

443

let outputs' =

444

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

445

let locals' =

446

List.fold_left (fun res l >

447

let l' = fvar l in

448

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

449

then res

450

else Utils.add_cons l' res)

451

[] step.step_locals in

452

{ step with

453

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

454

step_outputs = outputs';

455

step_locals = locals';

456

step_instrs = instrs_replace_var fvar step.step_instrs [];

457

}

458


459

let rec machine_replace_variables fvar m =

460

{ m with

461

mstep = step_replace_var fvar m.mstep

462

}

463


464

let machine_reuse_variables m reuse =

465

let fvar v =

466

try

467

Hashtbl.find reuse v.var_id

468

with Not_found > v in

469

machine_replace_variables fvar m

470


471

let machines_reuse_variables prog reuse_tables =

472

List.map

473

(fun m >

474

machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)

475

) prog

476


477

let rec instr_assign res instr =

478

match instr with

479

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

480

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

481

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

482

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

483

 _ > res

484


485

and instrs_assign res instrs =

486

List.fold_left instr_assign res instrs

487


488

let rec instr_constant_assign var instr =

489

match instr with

490

 MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })

491

 MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) > i = var

492

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

493

 _ > false

494


495

and instrs_constant_assign var instrs =

496

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

497


498

let rec instr_reduce branches instr1 cont =

499

match instr1 with

500

 MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont)

501

 MStateAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont)

502

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

503

 _ > instr1 :: cont

504


505

and instrs_reduce branches instrs cont =

506

match instrs with

507

 [] > cont

508

 [i] > instr_reduce branches i cont

509

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

510


511

let rec instrs_fusion instrs =

512

match instrs with

513

 []

514

 [_] >

515

instrs

516

 i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 >

517

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

518

 i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 >

519

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

520

 i1::i2::q >

521

i1 :: instrs_fusion (i2::q)

522


523

let step_fusion step =

524

{ step with

525

step_instrs = instrs_fusion step.step_instrs;

526

}

527


528

let rec machine_fusion m =

529

{ m with

530

mstep = step_fusion m.mstep

531

}

532


533

let machines_fusion prog =

534

List.map machine_fusion prog

535


536

(* Local Variables: *)

537

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

538

(* End: *)
