## lustrec / src / optimize_machine.ml @ 55537f48

History | View | Annotate | Download (16 KB)

1 | a2d97a3e | ploc | (********************************************************************) |
---|---|---|---|

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 | d0b1ec56 | xthirioux | open Utils |

13 | cf78a589 | ploc | open LustreSpec |

14 | open Corelang |
||

15 | b1655a21 | xthirioux | open Causality |

16 | cf78a589 | ploc | open Machine_code |

17 | ec433d69 | xthirioux | open Dimension |

18 | cf78a589 | ploc | |

19 | 55537f48 | xthirioux | |

20 | d0b1ec56 | xthirioux | 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 | cf78a589 | ploc | let rec eliminate elim instr = |

28 | let e_expr = eliminate_expr elim in |
||

29 | match instr with |
||

30 | | MLocalAssign (i,v) -> MLocalAssign (i, e_expr v) |
||

31 | | MStateAssign (i,v) -> MStateAssign (i, e_expr v) |
||

32 | | MReset i -> instr |
||

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

34 | | MBranch (g,hl) -> |
||

35 | MBranch |
||

36 | (e_expr g, |
||

37 | (List.map |
||

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

39 | hl |
||

40 | ) |
||

41 | ) |
||

42 | |||

43 | and eliminate_expr elim expr = |
||

44 | match expr with |
||

45 | c287ba28 | xthirioux | | StateVar v |

46 | d0b1ec56 | xthirioux | | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr) |

47 | cf78a589 | ploc | | Fun (id, vl) -> Fun (id, List.map (eliminate_expr elim) vl) |

48 | | Array(vl) -> Array(List.map (eliminate_expr elim) vl) |
||

49 | | Access(v1, v2) -> Access(eliminate_expr elim v1, eliminate_expr elim v2) |
||

50 | d0b1ec56 | xthirioux | | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2) |

51 | c287ba28 | xthirioux | | Cst _ -> expr |

52 | cf78a589 | ploc | |

53 | ec433d69 | xthirioux | let eliminate_dim elim dim = |

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

55 | |||

56 | d0b1ec56 | xthirioux | let is_scalar_const c = |

57 | match c with |
||

58 | | Const_int _ |
||

59 | | Const_real _ |
||

60 | | Const_float _ |
||

61 | | Const_tag _ -> true |
||

62 | | _ -> false |
||

63 | |||

64 | c287ba28 | xthirioux | let basic_unfoldable_expr expr = |

65 | match expr with |
||

66 | | Cst c when is_scalar_const c -> true |
||

67 | | LocalVar _ |
||

68 | | StateVar _ -> true |
||

69 | | _ -> false |
||

70 | |||

71 | d0b1ec56 | xthirioux | let unfoldable_assign fanin v expr = |

72 | try |
||

73 | let d = Hashtbl.find fanin v.var_id |
||

74 | c287ba28 | xthirioux | in basic_unfoldable_expr expr || |

75 | match expr with |
||

76 | | Cst c when d < 2 -> true |
||

77 | d0b1ec56 | xthirioux | | Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true |

78 | | _ -> false |
||

79 | with Not_found -> false |
||

80 | |||

81 | let merge_elim elim1 elim2 = |
||

82 | let merge k e1 e2 = |
||

83 | match e1, e2 with |
||

84 | | Some e1, Some e2 -> if e1 = e2 then Some e1 else None |
||

85 | | _ , Some e2 -> Some e2 |
||

86 | | Some e1, _ -> Some e1 |
||

87 | | _ -> None |
||

88 | in IMap.merge merge elim1 elim2 |
||

89 | |||

90 | cf78a589 | ploc | (* see if elim has to take in account the provided instr: |

91 | 54d032f5 | xthirioux | if so, update elim and return the remove flag, |

92 | cf78a589 | ploc | otherwise, the expression should be kept and elim is left untouched *) |

93 | d0b1ec56 | xthirioux | let rec instrs_unfold fanin elim instrs = |

94 | let elim, rev_instrs = |
||

95 | List.fold_left (fun (elim, instrs) instr -> |
||

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

97 | rewritten *) |
||

98 | let instr = eliminate elim instr in |
||

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

100 | is stored as the elim set *) |
||

101 | instr_unfold fanin instrs elim instr |
||

102 | ) (elim, []) instrs |
||

103 | in elim, List.rev rev_instrs |
||

104 | |||

105 | and instr_unfold fanin instrs elim instr = |
||

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

107 | cf78a589 | ploc | match instr with |

108 | (* Simple cases*) |
||

109 | d0b1ec56 | xthirioux | | MStep([v], id, vl) when Basic_library.is_internal_fun id |

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

111 | | MLocalAssign(v, expr) when unfoldable_assign fanin v expr |
||

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

113 | | MBranch(g, hl) when false |
||

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

115 | let (elim, branches) = |
||

116 | List.fold_right |
||

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

118 | elim_branches (elim, []) |
||

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

120 | | _ |
||

121 | -> (elim, instr :: instrs) |
||

122 | cf78a589 | ploc | (* default case, we keep the instruction and do not modify elim *) |

123 | |||

124 | |||

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

126 | 1. each expression is rewritten according to the accumulator |
||

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

128 | *) |
||

129 | |||

130 | ec433d69 | xthirioux | let static_call_unfold elim (inst, (n, args)) = |

131 | let replace v = |
||

132 | try |
||

133 | Machine_code.dimension_of_value (IMap.find v elim) |
||

134 | with Not_found -> Dimension.mkdim_ident Location.dummy_loc v |
||

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

136 | |||

137 | cf78a589 | ploc | (** Perform optimization on machine code: |

138 | - iterate through step instructions and remove simple local assigns |
||

139 | |||

140 | *) |
||

141 | d0b1ec56 | xthirioux | let machine_unfold fanin elim machine = |

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

143 | ec433d69 | xthirioux | let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in |

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

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

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

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

148 | cf78a589 | ploc | in |

149 | { |
||

150 | machine with |
||

151 | mstep = { |
||

152 | machine.mstep with |
||

153 | ec433d69 | xthirioux | step_locals = locals; |

154 | step_instrs = instrs |
||

155 | }; |
||

156 | mconst = mconst; |
||

157 | minstances = minstances; |
||

158 | mcalls = mcalls; |
||

159 | cf78a589 | ploc | } |

160 | |||

161 | d0b1ec56 | xthirioux | let instr_of_const top_const = |

162 | let const = const_of_top top_const in |
||

163 | ec433d69 | xthirioux | 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 |

164 | d0b1ec56 | xthirioux | let vdecl = { vdecl with var_type = const.const_type } |

165 | in MLocalAssign (vdecl, Cst const.const_value) |
||

166 | cf78a589 | ploc | |

167 | d0b1ec56 | xthirioux | let machines_unfold consts node_schs machines = |

168 | List.map |
||

169 | (fun m -> |
||

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

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

172 | in machine_unfold fanin elim_consts m) |
||

173 | machines |
||

174 | cf78a589 | ploc | |

175 | c287ba28 | xthirioux | let get_assign_lhs instr = |

176 | match instr with |
||

177 | | MLocalAssign(v, _) -> LocalVar v |
||

178 | | MStateAssign(v, _) -> StateVar v |
||

179 | | _ -> assert false |
||

180 | |||

181 | let get_assign_rhs instr = |
||

182 | match instr with |
||

183 | | MLocalAssign(_, e) |
||

184 | | MStateAssign(_, e) -> e |
||

185 | | _ -> assert false |
||

186 | |||

187 | let is_assign instr = |
||

188 | match instr with |
||

189 | | MLocalAssign _ |
||

190 | | MStateAssign _ -> true |
||

191 | | _ -> false |
||

192 | |||

193 | let mk_assign v e = |
||

194 | match v with |
||

195 | | LocalVar v -> MLocalAssign(v, e) |
||

196 | | StateVar v -> MStateAssign(v, e) |
||

197 | | _ -> assert false |
||

198 | |||

199 | let rec assigns_instr instr assign = |
||

200 | match instr with |
||

201 | | MLocalAssign (i,_) |
||

202 | | MStateAssign (i,_) -> ISet.add i assign |
||

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

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

205 | | _ -> assign |
||

206 | |||

207 | and assigns_instrs instrs assign = |
||

208 | List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs |
||

209 | |||

210 | (* |
||

211 | and substitute_expr subst expr = |
||

212 | match expr with |
||

213 | | StateVar v |
||

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

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

216 | | Array(vl) -> Array(List.map (substitute_expr subst) vl) |
||

217 | | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2) |
||

218 | | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2) |
||

219 | | Cst _ -> expr |
||

220 | *) |
||

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

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

223 | Then substitute this expression with the first assigned var |
||

224 | *) |
||

225 | let subst_instr subst instrs instr = |
||

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

227 | let instr = eliminate subst instr in |
||

228 | let v = get_assign_lhs instr in |
||

229 | let e = get_assign_rhs instr in |
||

230 | try |
||

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

232 | match v with |
||

233 | | LocalVar v -> |
||

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

235 | | StateVar v -> |
||

236 | (match get_assign_lhs instr' with |
||

237 | | LocalVar v' -> |
||

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

239 | subst, instr :: instrs |
||

240 | | StateVar v' -> |
||

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

242 | 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 |
||

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

244 | | _ -> assert false) |
||

245 | | _ -> assert false |
||

246 | with Not_found -> subst, instr :: instrs |
||

247 | |||

248 | (** Common sub-expression elimination for machine instructions *) |
||

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

250 | it is an equivalence table |
||

251 | - [elim] : set of eliminated variables |
||

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

253 | - [instr] : current instruction, normalized by [subst] |
||

254 | *) |
||

255 | let rec instr_cse (subst, instrs) instr = |
||

256 | match instr with |
||

257 | (* Simple cases*) |
||

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

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

260 | | MLocalAssign(v, expr) when basic_unfoldable_expr expr |
||

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

262 | | _ when is_assign instr |
||

263 | -> subst_instr subst instrs instr |
||

264 | | _ -> (subst, instr :: instrs) |
||

265 | |||

266 | (** Apply common sub-expression elimination to a sequence of instrs |
||

267 | *) |
||

268 | let rec instrs_cse subst instrs = |
||

269 | let subst, rev_instrs = |
||

270 | List.fold_left instr_cse (subst, []) instrs |
||

271 | in subst, List.rev rev_instrs |
||

272 | |||

273 | (** Apply common sub-expression elimination to a machine |
||

274 | - iterate through step instructions and remove simple local assigns |
||

275 | *) |
||

276 | let machine_cse subst machine = |
||

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

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

279 | let assigned = assigns_instrs instrs ISet.empty |
||

280 | in |
||

281 | { |
||

282 | machine with |
||

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

284 | mstep = { |
||

285 | machine.mstep with |
||

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

287 | step_instrs = instrs |
||

288 | } |
||

289 | } |
||

290 | |||

291 | let machines_cse machines = |
||

292 | List.map |
||

293 | (machine_cse IMap.empty) |
||

294 | machines |
||

295 | |||

296 | 45c13277 | xthirioux | (* variable substitution for optimizing purposes *) |

297 | |||

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

299 | let rec instr_is_skip instr = |
||

300 | match instr with |
||

301 | | MLocalAssign (i, LocalVar v) when i = v -> true |
||

302 | | MStateAssign (i, StateVar v) when i = v -> true |
||

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

304 | | _ -> false |
||

305 | and instrs_are_skip instrs = |
||

306 | List.for_all instr_is_skip instrs |
||

307 | |||

308 | let instr_cons instr cont = |
||

309 | if instr_is_skip instr then cont else instr::cont |
||

310 | |||

311 | let rec instr_remove_skip instr cont = |
||

312 | match instr with |
||

313 | | MLocalAssign (i, LocalVar v) when i = v -> cont |
||

314 | | MStateAssign (i, StateVar v) when i = v -> cont |
||

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

316 | | _ -> instr::cont |
||

317 | |||

318 | and instrs_remove_skip instrs cont = |
||

319 | List.fold_right instr_remove_skip instrs cont |
||

320 | |||

321 | let rec value_replace_var fvar value = |
||

322 | match value with |
||

323 | | Cst c -> value |
||

324 | | LocalVar v -> LocalVar (fvar v) |
||

325 | | StateVar v -> value |
||

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

327 | | Array vl -> Array (List.map (value_replace_var fvar) vl) |
||

328 | | Access (t, i) -> Access(value_replace_var fvar t, i) |
||

329 | | Power (v, n) -> Power(value_replace_var fvar v, n) |
||

330 | |||

331 | let rec instr_replace_var fvar instr cont = |
||

332 | match instr with |
||

333 | | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont |
||

334 | | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont |
||

335 | | MReset i -> instr_cons instr cont |
||

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

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

338 | |||

339 | and instrs_replace_var fvar instrs cont = |
||

340 | List.fold_right (instr_replace_var fvar) instrs cont |
||

341 | |||

342 | let step_replace_var fvar step = |
||

343 | (* Some outputs may have been replaced by locals. |
||

344 | We then need to rename those outputs |
||

345 | without changing their clocks, etc *) |
||

346 | let outputs' = |
||

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

348 | let locals' = |
||

349 | List.fold_left (fun res l -> |
||

350 | let l' = fvar l in |
||

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

352 | then res |
||

353 | else Utils.add_cons l' res) |
||

354 | [] step.step_locals in |
||

355 | { step with |
||

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

357 | step_outputs = outputs'; |
||

358 | step_locals = locals'; |
||

359 | step_instrs = instrs_replace_var fvar step.step_instrs []; |
||

360 | } |
||

361 | |||

362 | let rec machine_replace_variables fvar m = |
||

363 | { m with |
||

364 | mstep = step_replace_var fvar m.mstep |
||

365 | } |
||

366 | |||

367 | let machine_reuse_variables m reuse = |
||

368 | let fvar v = |
||

369 | try |
||

370 | Hashtbl.find reuse v.var_id |
||

371 | with Not_found -> v in |
||

372 | machine_replace_variables fvar m |
||

373 | |||

374 | let machines_reuse_variables prog node_schs = |
||

375 | List.map |
||

376 | (fun m -> |
||

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

378 | ) prog |
||

379 | |||

380 | b1655a21 | xthirioux | let rec instr_assign res instr = |

381 | match instr with |
||

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

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

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

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

386 | | _ -> res |
||

387 | |||

388 | and instrs_assign res instrs = |
||

389 | List.fold_left instr_assign res instrs |
||

390 | |||

391 | let rec instr_constant_assign var instr = |
||

392 | match instr with |
||

393 | | MLocalAssign (i, Cst (Const_tag _)) |
||

394 | | MStateAssign (i, Cst (Const_tag _)) -> i = var |
||

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

396 | | _ -> false |
||

397 | |||

398 | and instrs_constant_assign var instrs = |
||

399 | 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 |
||

400 | |||

401 | let rec instr_reduce branches instr1 cont = |
||

402 | match instr1 with |
||

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

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

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

406 | | _ -> instr1 :: cont |
||

407 | |||

408 | and instrs_reduce branches instrs cont = |
||

409 | match instrs with |
||

410 | | [] -> cont |
||

411 | | [i] -> instr_reduce branches i cont |
||

412 | | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont |
||

413 | |||

414 | let rec instrs_fusion instrs = |
||

415 | match instrs with |
||

416 | | [] |
||

417 | | [_] -> |
||

418 | instrs |
||

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

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

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

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

423 | | i1::i2::q -> |
||

424 | i1 :: instrs_fusion (i2::q) |
||

425 | |||

426 | let step_fusion step = |
||

427 | { step with |
||

428 | step_instrs = instrs_fusion step.step_instrs; |
||

429 | } |
||

430 | |||

431 | let rec machine_fusion m = |
||

432 | { m with |
||

433 | mstep = step_fusion m.mstep |
||

434 | } |
||

435 | |||

436 | let machines_fusion prog = |
||

437 | List.map machine_fusion prog |
||

438 | cf78a589 | ploc | |

439 | (* Local Variables: *) |
||

440 | (* compile-command:"make -C .." *) |
||

441 | (* End: *) |