# Ticket #3193: ZDF5ex.hs

File ZDF5ex.hs, 56.4 KB (added by nr, 7 years ago) |
---|

Line | |
---|---|

1 | {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, KindSignatures, FlexibleContexts, GADTs #-} |

2 | |

3 | module ZDF5ex |

4 | ( DebugNodes(), RewritingDepth(..), LastOutFacts(..) |

5 | , zdfSolveFrom, zdfRewriteFrom |

6 | , ForwardTransfers(..), BackwardTransfers(..) |

7 | , ForwardRewrites(..), BackwardRewrites(..) |

8 | , ForwardFixedPoint, BackwardFixedPoint |

9 | , zdfFpFacts |

10 | , zdfFpOutputFact |

11 | , zdfGraphChanged |

12 | , zdfDecoratedGraph -- not yet implemented |

13 | , zdfFpContents |

14 | , zdfFpLastOuts |

15 | , FuelMonad, liftUniq -- re-export from OptimizationFuel |

16 | , DataflowPass(..) |

17 | ) |

18 | where |

19 | |

20 | #include "HsVersions.h" |

21 | |

22 | import BlockId |

23 | import CmmTx |

24 | import DFLattice |

25 | import DFMonad2 |

26 | import OptimizationFuel as F |

27 | import ZipGFex |

28 | |

29 | import UniqSupply -- temporary |

30 | |

31 | import Outputable |

32 | import Panic |

33 | |

34 | import Control.Monad |

35 | import Maybe |

36 | |

37 | {- |

38 | |

39 | This module implements two useful tools: |

40 | |

41 | 1. An iterative solver for dataflow problems |

42 | |

43 | 2. The combined dataflow-analysis-and-transformation framework |

44 | described by Lerner, Grove, and Chambers in their excellent |

45 | 2002 POPL paper (http://tinyurl.com/3zycbr or |

46 | http://tinyurl.com/3pnscd). |

47 | |

48 | Each tool comes in two flavors: one for forward dataflow problems |

49 | and one for backward dataflow problems. |

50 | |

51 | We quote the paper above: |

52 | |

53 | Dataflow analyses can have mutually beneficial interactions. |

54 | Previous efforts to exploit these interactions have either |

55 | (1) iteratively performed each individual analysis until no |

56 | further improvements are discovered or (2) developed "super- |

57 | analyses" that manually combine conceptually separate anal- |

58 | yses. We have devised a new approach that allows anal- |

59 | yses to be defined independently while still enabling them |

60 | to be combined automatically and profitably. Our approach |

61 | avoids the loss of precision associated with iterating indi- |

62 | vidual analyses and the implementation difficulties of man- |

63 | ually writing a super-analysis. |

64 | |

65 | The key idea is to provide at each CFG node not only a dataflow |

66 | transfer function but also a rewriting function that has the option to |

67 | replace the node with a new (possibly empty) graph. The rewriting |

68 | function takes a dataflow fact as input, and the fact is used to |

69 | justify any rewriting. For example, in a backward problem, the fact |

70 | that variable x is dead can be used to justify rewriting node |

71 | x := e |

72 | to the empty graph. In a forward problem, the fact that x == 7 can |

73 | be used to justify rewriting node |

74 | y := x + 1 |

75 | to |

76 | y := 8 |

77 | which in turn will be analyzed and produce a new fact: |

78 | x == 7 and y == 8. |

79 | |

80 | In its most general form, this module takes as input graph, transfer |

81 | equations, rewrites, and an initial set of dataflow facts, and |

82 | iteratively computes a new graph and a new set of dataflow facts such |

83 | that |

84 | * The set of facts is a fixed point of the transfer equations |

85 | * The graph has been rewritten as much as is consistent with |

86 | the given facts and requested rewriting depth (see below) |

87 | N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'. |

88 | |

89 | The types of transfer equations, rewrites, and fixed points are |

90 | different for forward and backward problems. To avoid cluttering the |

91 | name space with two versions of every names, other names such as |

92 | zdfSolveFrom are overloaded to work in both forward or backward |

93 | directions. This design decision is based on experience with the |

94 | predecessor module, now called ZipDataflow0 and destined for the bit bucket. |

95 | |

96 | |

97 | This module is deliberately very abstract. It is a completely general |

98 | framework and well-nigh impossible to understand in isolation. The |

99 | cautious reader will begin with some concrete examples in the form of |

100 | clients. NR recommends |

101 | |

102 | CmmLiveZ A simple liveness analysis |

103 | |

104 | CmmSpillReload.removeDeadAssignmentsAndReloads |

105 | A piece of spaghetti to pull on, which leads to |

106 | - a two-part liveness analysis that tracks |

107 | variables live in registers and live on the stack |

108 | - elimination of assignments to dead variables |

109 | - elimination of redundant reloads |

110 | |

111 | Even hearty souls should avoid the CmmProcPointZ client, at least for |

112 | the time being. |

113 | |

114 | -} |

115 | |

116 | |

117 | {- ============ TRANSFER FUNCTIONS AND REWRITES =========== -} |

118 | |

119 | -- | For a backward transfer, you're given the fact on a node's |

120 | -- outedge and you compute the fact on the inedge. Facts have type 'a'. |

121 | -- A last node may have multiple outedges, each pointing to a labelled |

122 | -- block, so instead of a fact it is given a mapping from BlockId to fact. |

123 | |

124 | data BackwardTransfers middle last a = BackwardTransfers |

125 | { bt_first_in :: BlockId -> a -> a |

126 | , bt_middle_in :: middle -> a -> a |

127 | , bt_last_in :: last -> (BlockId -> a) -> a |

128 | } |

129 | |

130 | -- | For a forward transfer, you're given the fact on a node's |

131 | -- inedge and you compute the fact on the outedge. Because a last node |

132 | -- may have multiple outedges, each pointing to a labelled |

133 | -- block, so instead of a fact it produces a list of (BlockId, fact) pairs. |

134 | |

135 | data ForwardTransfers middle last a = ForwardTransfers |

136 | { ft_first_out :: BlockId -> a -> a |

137 | , ft_middle_out :: middle -> a -> a |

138 | , ft_last_outs :: last -> a -> LastOutFacts a |

139 | } |

140 | |

141 | newtype LastOutFacts a = LastOutFacts [(BlockId, a)] |

142 | -- ^ These are facts flowing out of a last node to the node's successors. |

143 | -- They are either to be set (if they pertain to the graph currently |

144 | -- under analysis) or propagated out of a sub-analysis |

145 | |

146 | |

147 | -- | A backward rewrite takes the same inputs as a backward transfer, |

148 | -- but instead of producing a fact, it produces a replacement graph or Nothing. |

149 | |

150 | type O = ZOpen |

151 | type C = ZClosed |

152 | |

153 | data BackwardRewrites middle last a = BackwardRewrites |

154 | { br_first :: BlockId -> a -> Maybe (ZipGF' middle last C O) |

155 | , br_middle :: middle -> a -> Maybe (ZipGF' middle last O O) |

156 | , br_last :: last -> (BlockId -> a) -> Maybe (ZipGF' middle last O C) |

157 | , br_entry :: Maybe (ZipGF' middle last O O) |

158 | } |

159 | |

160 | -- | A forward rewrite takes the same inputs as a forward transfer, |

161 | -- but instead of producing a fact, it produces a replacement graph or Nothing. |

162 | |

163 | data ForwardRewrites middle last a = ForwardRewrites |

164 | { fr_first :: BlockId -> a -> Maybe (ZipGF' middle last C O) |

165 | , fr_middle :: middle -> a -> Maybe (ZipGF' middle last O O) |

166 | , fr_last :: last -> a -> Maybe (ZipGF' middle last O C) |

167 | , fr_exit :: a -> Maybe (ZipGF' middle last O O) |

168 | } |

169 | |

170 | type ZipGF' m l e x = UniqSM (ZipGF m l e x) -- simulate monadic goo for now |

171 | |

172 | |

173 | {- ===================== A DATAFLOW PASS =================== -} |

174 | |

175 | data DataflowPass transfers rewrites m l a |

176 | = DataflowPass { dfp_lattice :: DataflowLattice a |

177 | , dfp_transfers :: transfers m l a |

178 | , dfp_rewrites :: rewrites m l a |

179 | } |

180 | |

181 | |

182 | {- ===================== FIXED POINTS =================== -} |

183 | |

184 | -- | The result of combined analysis and transformation is a |

185 | -- solution to the set of dataflow equations together with a 'contained value'. |

186 | -- This solution is a member of type class 'FixedPoint', which is parameterized by |

187 | -- * middle and last nodes 'm' and 'l' |

188 | -- * data flow fact 'fact' |

189 | -- * the type 'a' of the contained value |

190 | -- |

191 | -- In practice, the contained value 'zdfFpContents' is either a |

192 | -- rewritten graph, when rewriting, or (), when solving without |

193 | -- rewriting. A function 'zdfFpMap' allows a client to change |

194 | -- the contents without changing other values. |

195 | -- |

196 | -- To save space, we provide the solution 'zdfFpFacts' as a mapping |

197 | -- from BlockId to fact; if necessary, facts on edges can be |

198 | -- reconstructed using the transfer functions; this functionality is |

199 | -- intended to be included as the 'zdfDecoratedGraph', but the code |

200 | -- has not yet been implemented. |

201 | -- |

202 | -- The solution may also includes a fact 'zdfFpOuputFact', which is |

203 | -- not associated with any label: |

204 | -- * for a backward problem, this is the fact at entry |

205 | -- * for a forward problem, this is the fact at the distinguished exit node, |

206 | -- if such a node is present |

207 | -- |

208 | -- For a forward problem only, the solution includes 'zdfFpLastOuts', |

209 | -- which is the set of facts on edges leaving the graph. |

210 | -- |

211 | -- The flag 'zdfGraphChanged' tells whether the engine did any rewriting. |

212 | |

213 | class FixedPoint fp where |

214 | zdfFpContents :: fp m l e x fact a -> a |

215 | zdfFpFacts :: fp m l e x fact a -> BlockEnv fact |

216 | zdfFpOutputFact :: fp m l e x fact a -> fact -- entry for backward; exit for forward |

217 | zdfDecoratedGraph :: fp m l e x fact a -> ZipGF (fact, m) (fact, l) e x |

218 | zdfGraphChanged :: fp m l e x fact a -> ChangeFlag |

219 | zdfFpMap :: (a -> b) -> (fp m l e x fact a -> fp m l e x fact b) |

220 | |

221 | -- | The class 'FixedPoint' has two instances: one for forward problems and |

222 | -- one for backward problems. The 'CommonFixedPoint' defines all fields |

223 | -- common to both. (The instance declarations are uninteresting and appear below.) |

224 | |

225 | data CommonFixedPoint m l e x fact a = FP |

226 | { fp_facts :: BlockEnv fact |

227 | , fp_out :: fact -- entry for backward; exit for forward |

228 | , fp_changed :: ChangeFlag |

229 | , fp_dec_graph :: ZipGF (fact, m) (fact, l) e x |

230 | , fp_contents :: a |

231 | } |

232 | |

233 | -- | The common fixed point is sufficient for a backward problem. |

234 | type BackwardFixedPoint = CommonFixedPoint |

235 | |

236 | -- | A forward problem needs the common fields, plus the facts on the outedges. |

237 | data ForwardFixedPoint m l e x fact a = FFP |

238 | { ffp_common :: CommonFixedPoint m l e x fact a |

239 | , zdfFpLastOuts :: LastOutFacts fact |

240 | } |

241 | |

242 | |

243 | instance FixedPoint CommonFixedPoint where |

244 | zdfFpFacts = fp_facts |

245 | zdfFpOutputFact = fp_out |

246 | zdfGraphChanged = fp_changed |

247 | zdfDecoratedGraph = fp_dec_graph |

248 | zdfFpContents = fp_contents |

249 | zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a) |

250 | |

251 | instance FixedPoint ForwardFixedPoint where |

252 | zdfFpFacts = fp_facts . ffp_common |

253 | zdfFpOutputFact = fp_out . ffp_common |

254 | zdfGraphChanged = fp_changed . ffp_common |

255 | zdfDecoratedGraph = fp_dec_graph . ffp_common |

256 | zdfFpContents = fp_contents . ffp_common |

257 | zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los |

258 | |

259 | |

260 | |

261 | -- | Extraction of the common fixed point, given a function to get the |

262 | -- fact emerging from the graph |

263 | cfp :: (b -> a) -> c -> DFM a b -> DFM a (CommonFixedPoint m l e x a c) |

264 | cfp get_fact c solution = |

265 | do { b <- solution |

266 | ; let emerging = get_fact b |

267 | ; facts <- getAllFacts |

268 | ; return $ FP facts emerging NoChange (panic "decoration?!") c } |

269 | |

270 | -- | Extract a fixed point from a backward analysis |

271 | bfp :: b -> DFM a a -> DFM a (BackwardFixedPoint m l e x a b) |

272 | bfp = cfp id |

273 | |

274 | -- | Extract a fixed point from a forward analysis |

275 | ffp :: b -> DFM a (Maybe a) -> DFM a (ForwardFixedPoint m l e x a b) |

276 | ffp b exit = do { common <- cfp get_fact b exit |

277 | ; last_outs <- getLastOutFacts |

278 | ; return $ FFP common last_outs |

279 | } |

280 | where get_fact ma = fromMaybe (panic "exit of non-exitable graph") ma |

281 | |

282 | |

283 | |

284 | |

285 | {- ============== SOLVING AND REWRITING ============== -} |

286 | |

287 | type PassName = String |

288 | |

289 | -- | 'zdfSolveFrom' is an overloaded name that resolves to a pure |

290 | -- analysis with no rewriting. It has only two instances: forward and |

291 | -- backward. Since it needs no rewrites, the type parameters of the |

292 | -- class are transfer functions and the fixed point. |

293 | -- |

294 | -- |

295 | -- An iterative solver normally starts with the bottom fact at every |

296 | -- node, but it can be useful in other contexts as well. For this |

297 | -- reason the initial set of facts (at labelled blocks only) is a |

298 | -- parameter to the solver. |

299 | -- |

300 | -- The constraints on the type signature exist purely for debugging; |

301 | -- they make it possible to prettyprint nodes and facts. The parameter of |

302 | -- type 'PassName' is also used just for debugging. |

303 | -- |

304 | -- Note that the result is a fixed point with no contents, that is, |

305 | -- the contents have type (). |

306 | -- |

307 | -- The intent of the rest of the type signature should be obvious. |

308 | -- If not, place a skype call to norman-ramsey or complain bitterly |

309 | -- to <norman-ramsey@acm.org>. |

310 | |

311 | class DataflowSolverDirection transfers fixedpt where |

312 | zdfSolveFrom :: (DebugNodes m l e x, LastNode l, Outputable a) |

313 | => BlockEnv a -- ^ Initial facts (unbound == bottom) |

314 | -> PassName |

315 | -> DataflowLattice a -- ^ Lattice |

316 | -> transfers m l a -- ^ Dataflow transfer functions |

317 | -> a -- ^ Fact flowing in (at entry or exit) |

318 | -> ZipGF m l e x -- ^ Graph to be analyzed |

319 | -> fixedpt m l e x a () -- ^ Answers |

320 | |

321 | -- There are exactly two instances: forward and backward |

322 | instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint |

323 | where zdfSolveFrom = solve_f |

324 | |

325 | instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint |

326 | where zdfSolveFrom = solve_b |

327 | |

328 | solve_b, rewrite_b_agraph, forward_rew :: a |

329 | solve_b = undefined |

330 | rewrite_b_agraph = undefined |

331 | forward_rew = undefined |

332 | |

333 | -- | zdfRewriteFrom is an overloaded name that resolves to an |

334 | -- interleaved analysis and transformation. It too is instantiated in |

335 | -- forward and backward directions. |

336 | -- |

337 | -- The type parameters of the class include not only transfer |

338 | -- functions and the fixed point but also rewrites and the type |

339 | -- constructor (here called 'graph') for making rewritten graphs. As |

340 | -- above, in the definitoins of the rewrites, it might simplify |

341 | -- matters if 'graph' were replaced with 'ZipGF'. |

342 | -- |

343 | -- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom' |

344 | -- with additional parameters and a different result. Of course the |

345 | -- rewrites are an additional parameter. |

346 | -- The resulting fixed point containts a rewritten graph. |

347 | |

348 | class DataflowSolverDirection transfers fixedpt => |

349 | DataflowDirection transfers fixedpt rewrites where |

350 | zdfRewriteFrom :: (DebugNodes m l e x, Outputable a, LastNode l) |

351 | => RewritingDepth -- whether to rewrite a rewritten graph |

352 | -> BlockEnv a -- initial facts (unbound == botton) |

353 | -> PassName |

354 | -> DataflowLattice a |

355 | -> transfers m l a |

356 | -> rewrites m l a |

357 | -> a -- fact flowing in (at entry or exit) |

358 | -> ZipGF m l e x |

359 | -> FuelMonad (fixedpt m l e x a (ZipGF m l e x)) |

360 | |

361 | data RewritingDepth = RewriteShallow | RewriteDeep |

362 | -- When a transformation proposes to rewrite a node, |

363 | -- you can either ask the system to |

364 | -- * "shallow": accept the new graph, analyse it without further rewriting |

365 | -- * "deep": recursively analyse-and-rewrite the new graph |

366 | |

367 | |

368 | -- There are currently four instances, but there could be more |

369 | -- forward, backward (instantiates transfers, fixedpt, rewrites) |

370 | -- ZipGF, ZipGF (instantiates graph) |

371 | |

372 | instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites |

373 | where zdfRewriteFrom = rewrite_f_agraph |

374 | |

375 | instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites |

376 | where zdfRewriteFrom = rewrite_b_agraph |

377 | |

378 | |

379 | {- =================== IMPLEMENTATIONS ===================== -} |

380 | |

381 | |

382 | ----------------------------------------------------------- |

383 | -- solve_f: forward, pure |

384 | |

385 | solve_f :: (DebugNodes m l e x, LastNode l, Outputable a) |

386 | => BlockEnv a -- initial facts (unbound == bottom) |

387 | -> PassName |

388 | -> DataflowLattice a -- lattice |

389 | -> ForwardTransfers m l a -- dataflow transfer functions |

390 | -> a |

391 | -> ZipGF m l e x -- graph to be analyzed |

392 | -> ForwardFixedPoint m l e x a () -- answers |

393 | solve_f env name lattice transfers in_fact g = |

394 | runWithoutFuel $ runDFM lattice $ ffp () $ liftM undefined $ |

395 | fwd_pure_anal name env transfers (maybe_entry g in_fact) g |

396 | |

397 | maybe_entry :: ZipGF m l e x -> a -> ZMaybe e a |

398 | maybe_entry (GF (ZE_C _) _ _) _ = ZNothing |

399 | maybe_entry (GF (ZE_O _) _ _) a = ZJust a |

400 | maybe_entry (GM _) a = ZJust a |

401 | |

402 | rewrite_f_agraph :: (DebugNodes m l e x, LastNode l, Outputable a) |

403 | => RewritingDepth |

404 | -> BlockEnv a |

405 | -> PassName |

406 | -> DataflowLattice a |

407 | -> ForwardTransfers m l a |

408 | -> ForwardRewrites m l a |

409 | -> a -- fact flowing in (at entry or exit) |

410 | -> ZipGF m l e x |

411 | -> FuelMonad (ForwardFixedPoint m l e x a (ZipGF m l e x)) |

412 | rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g = |

413 | runDFM lattice $ |

414 | do fuel <- fuelRemaining |

415 | fp <- rewr_fp $ forward_rew maybeRewriteAndUseFuel depth start_facts name |

416 | transfers rewrites in_fact g |

417 | fuel' <- fuelRemaining |

418 | fuelDecrement name fuel fuel' |

419 | return fp |

420 | where rewr_fp ga = do { (g, a) <- ga ; ffp g $ return a } |

421 | |

422 | maybeRewriteAndUseFuel :: Maybe b -> DFM a (Maybe b) |

423 | maybeRewriteAndUseFuel Nothing = return Nothing |

424 | maybeRewriteAndUseFuel (Just b) = |

425 | do { done <- fuelExhausted |

426 | ; if done then return Nothing |

427 | else fuelDec1 >> (return $ Just b) } |

428 | |

429 | |

430 | -- convert graph from form produced by rewrite function to form used internally |

431 | importGraph :: ZipGF' m l e x -> DFM a (ZipGF m l e x) |

432 | importGraph g = liftToDFM $ liftUniq $ g |

433 | |

434 | class (Outputable m, Outputable l, HavingSuccessors l, Outputable (ZipGF m l e x)) => DebugNodes m l e x |

435 | |

436 | fwd_pure_anal :: (DebugNodes m l e x, LastNode l, Outputable a) |

437 | => PassName |

438 | -> BlockEnv a |

439 | -> ForwardTransfers m l a |

440 | -> ZMaybe e a |

441 | -> ZipGF m l e x |

442 | -> DFM a (ZMaybe x a) |

443 | |

444 | fwd_pure_anal name env transfers in_fact g = |

445 | anal_f name env transfers panic_rewrites in_fact g |

446 | where -- definitely a case of "I love lazy evaluation" |

447 | anal_f = forward_sol (\_ -> return Nothing) panic_depth |

448 | panic_rewrites = panic "pure analysis asked for a rewrite function" |

449 | panic_depth = panic "pure analysis asked for a rewrite depth" |

450 | |

451 | ----------------------------------------------------------------------- |

452 | -- |

453 | -- Here beginneth the super-general functions |

454 | -- |

455 | -- Think of them as (typechecked) macros |

456 | -- * They are not exported |

457 | -- |

458 | -- * They are called by the specialised wrappers |

459 | -- above, and always inlined into their callers |

460 | -- |

461 | -- There are four functions, one for each combination of: |

462 | -- Forward, Backward |

463 | -- Solver, Rewriter |

464 | -- |

465 | -- A "solver" produces a (DFM f (f, Fuel)), |

466 | -- where f is the fact at entry(Bwd)/exit(Fwd) |

467 | -- and from the DFM you can extract |

468 | -- the BlockId->f |

469 | -- the change-flag |

470 | -- and more besides |

471 | -- |

472 | -- A "rewriter" produces a rewritten *Graph* as well |

473 | -- |

474 | -- Both constrain their rewrites by |

475 | -- a) Fuel |

476 | -- b) RewritingDepth: shallow/deep |

477 | |

478 | ----------------------------------------------------------------------- |

479 | |

480 | data ZMaybe x a where |

481 | ZJust :: a -> ZMaybe O a |

482 | ZNothing :: ZMaybe C a |

483 | |

484 | unZMaybe :: ZMaybe x a -> Maybe a |

485 | unZMaybe (ZJust a) = Just a |

486 | unZMaybe (ZNothing) = Nothing |

487 | |

488 | fromZJust :: ZMaybe O a -> a |

489 | fromZJust (ZJust a) = a |

490 | |

491 | -- continuation types |

492 | type FactKont a b = a -> DFM a b |

493 | type LOFsKont a b = LastOutFacts a -> DFM a b |

494 | type Kont a b = DFM a b |

495 | type ZKont ex a b = ZMaybe ex a -> DFM a b |

496 | |

497 | -- solves a single-entry, at-most-one-exit, graph fragment given |

498 | -- an input fact a and input Fuel, producing a possible output fact |

499 | -- and remaining Fuel |

500 | |

501 | forward_sol |

502 | :: forall m l e x a . |

503 | (DebugNodes m l e x, LastNode l, Outputable a) |

504 | => (forall b . Maybe b -> DFM a (Maybe b)) |

505 | -- Squashes proposed rewrites if there is |

506 | -- no more fuel; OR if we are doing a pure |

507 | -- analysis, so totally ignore the rewrite |

508 | -- ie. For pure-analysis the fn is (\f _ -> (f, Nothing)). |

509 | -- Also accounts for fuel consumption. |

510 | -> RewritingDepth -- Shallow/deep |

511 | -> PassName |

512 | -> BlockEnv a -- Initial set of facts |

513 | -> ForwardTransfers m l a |

514 | -> ForwardRewrites m l a |

515 | -> ZMaybe e a -- Entry fact |

516 | -> ZipGF m l e x |

517 | -> DFM a (ZMaybe x a) |

518 | forward_sol with_fuel = forw -- see [Note inlining] below |

519 | where |

520 | forw :: RewritingDepth |

521 | -> PassName |

522 | -> BlockEnv a |

523 | -> ForwardTransfers m l a |

524 | -> ForwardRewrites m l a |

525 | -> ZMaybe e a |

526 | -> ZipGF m l e x |

527 | -> DFM a (ZMaybe x a) |

528 | forw depth name start_facts transfers rewrites = |

529 | \in_fact g -> do { setAllFacts start_facts ; solve_ex g in_fact } |

530 | where |

531 | -- the solver is executed mostly for side effect; |

532 | -- it may take an OO or OC graph. |

533 | solve_ex :: ZipGF m l e x -> ZKont e a (ZMaybe x a) |

534 | solve_ex (GM mids) (ZJust a) = solve_mids mids (return . ZJust) a |

535 | solve_ex (GM _) (ZNothing) = can't_match |

536 | solve_ex g@(GF entry blocks exit) in' = |

537 | do { set_locals blocks exit |

538 | ; solve_entry entry set_last in' |

539 | ; solve_blocks (postorder_dfs g) |

540 | ; solve_exit exit } |

541 | where set_locals :: BlockEnv (Block m l) -> ZExit m x -> DFM a () |

542 | set_locals blocks (ZX_O exit) = set_local_blocks_with_exit blocks exit |

543 | set_locals blocks ZX_C = set_local_blocks blocks |

544 | solve_entry :: ZEntry m l e -> LOFsKont a b -> ZKont e a b |

545 | solve_exit :: ZExit m x -> Kont a (ZMaybe x a) |

546 | solve_entry (ZE_O tail) k (ZJust a) = solve_tail tail k a |

547 | solve_entry (ZE_C _) k (ZNothing) = k $ LastOutFacts [] |

548 | solve_entry _ _ _ = can't_match |

549 | solve_exit (ZX_O head) = solve_head head (return . ZJust) |

550 | solve_exit (ZX_C) = return ZNothing |

551 | |

552 | -- From here out, we present myriad solver functions, starting with |

553 | -- individual nodes and working our way up to graphs |

554 | |

555 | |

556 | |

557 | -- not clear where to put this tidbit---it's the side-effecting action that |

558 | -- updates the internal state of the dataflow monad. Everything else boils |

559 | -- down to calling @set_last@ to do the deed... XXX |

560 | |

561 | set_last :: LOFsKont a () |

562 | set_last (LastOutFacts l) = mapM_ (uncurry setFact) l |

563 | |

564 | -- In order to compose continuations, the order of arguments no longer |

565 | -- reflects the flow of a fact through a node. Instead we want to |

566 | -- be able to partially apply a solver to a thing and take the |

567 | -- input fact and fuel as later arguments. |

568 | |

569 | -- XXX we would like to see if solve_first, solve_mid, and solve_last |

570 | -- can each be obtained as a partial application of a single higher-order |

571 | -- function. We just want to know if it can be done, even if we believe |

572 | -- the higher-order version may be harder to understand and therefore |

573 | -- not worthy to be deployed. |

574 | |

575 | ----------- SOLVER FUNCTIONS FOR NODES -------------- |

576 | |

577 | -- the types are all CPS-style types, but with three different |

578 | -- types of continuations which very by enterability and exitability |

579 | |

580 | solve_first :: BlockId -> FactKont a b -> Kont a b |

581 | solve_first id k = |

582 | do { idfact <- getFact id |

583 | ; (with_fuel $ fr_first rewrites id idfact) >>= \x -> case x of |

584 | Nothing -> k (ft_first_out transfers id idfact) |

585 | Just g -> |

586 | do { g <- importGraph g |

587 | ; a <- subAnalysis' $ |

588 | case depth of |

589 | RewriteDeep -> solve_CO' id g return |

590 | RewriteShallow -> anal_f_CO g |

591 | ; k a } } |

592 | |

593 | solve_mid :: m -> FactKont a b -> FactKont a b |

594 | solve_mid m k in' = |

595 | (with_fuel $ fr_middle rewrites m in') >>= \x -> case x of |

596 | Nothing -> k (ft_middle_out transfers m in') |

597 | Just g -> |

598 | do { g <- importGraph g |

599 | ; a <- subAnalysis' $ |

600 | case depth of |

601 | RewriteDeep -> solve_OO' g return in' |

602 | RewriteShallow -> anal_f_OO g in' |

603 | ; k a } |

604 | |

605 | solve_last :: l -> LOFsKont a b -> FactKont a b |

606 | solve_last l k in' = |

607 | (with_fuel $ fr_last rewrites l in') >>= \x -> case x of |

608 | Nothing -> k (ft_last_outs transfers l in') |

609 | Just g -> |

610 | do { g <- importGraph g |

611 | ; (last_outs :: LastOutFacts a) <- subAnalysis' $ |

612 | case depth of |

613 | RewriteDeep -> solve_OC' g return in' |

614 | RewriteShallow -> anal_f_OC g in' |

615 | ; k last_outs } |

616 | |

617 | ----------- SOLVER FUNCTIONS FOR SEQUENCES OF NODES ----------- |

618 | |

619 | solve_mids :: ZMids m -> FactKont a b -> FactKont a b |

620 | solve_mids (ZUnit) = id |

621 | solve_mids (ZMid m) = solve_mid m |

622 | solve_mids (ZCat m1 m2) = solve_mids m1 . solve_mids m2 |

623 | |

624 | solve_tail :: ZTail m l -> LOFsKont a b -> FactKont a b |

625 | solve_tail (ZTail m t) = solve_mid m . solve_tail t |

626 | solve_tail (ZLast l) = solve_last l |

627 | |

628 | solve_head :: ZHead m -> FactKont a b -> Kont a b |

629 | solve_head (ZHead h m) = solve_head h . solve_mid m |

630 | solve_head (ZFirst id) = solve_first id |

631 | |

632 | solve_block :: Block m l -> Kont a () |

633 | solve_block (Block id tail) = solve_first id $ solve_tail tail $ set_last |

634 | |

635 | ----------- SOLVER FUNCTIONS FOR GRAPHS -------------- |

636 | |

637 | solve_blocks :: [Block m l] -> Kont a () |

638 | solve_blocks = run "forward" name solve_block |

639 | --- the reason this falls out so nicely is that solve_block |

640 | --- is executed only for side effect (just like the old |

641 | --- 'set_successor_facts' |

642 | |

643 | -- primed functions perform dynamic checks; we may one day |

644 | -- want to refine types to eliminate the dynamic checks |

645 | solve_CO' :: BlockId -> ZipGF m l C O -> FactKont a b -> Kont a b |

646 | solve_OO' :: ZipGF m l O O -> FactKont a b -> FactKont a b |

647 | solve_OC' :: ZipGF m l O C -> LOFsKont a b -> FactKont a b |

648 | |

649 | solve_CO' id (GF (ZE_C id2) blocks (ZX_O exit)) = |

650 | ASSERT( id == id2 ) solve_CO id2 blocks exit |

651 | solve_CO' _ _ = can't_match |

652 | |

653 | solve_OO' (GM mids) = solve_mids mids |

654 | solve_OO' (GF (ZE_O entry) blocks (ZX_O exit)) = solve_OO entry blocks exit |

655 | solve_OO' _ = can't_match |

656 | |

657 | solve_OC' (GF (ZE_O entry) blocks ZX_C) = solve_OC entry blocks |

658 | solve_OC' _ = can't_match |

659 | |

660 | -- from here down, the dynamic checks have already been done |

661 | solve_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m |

662 | -> FactKont a b -> Kont a b |

663 | solve_OO :: ZTail m l -> BlockEnv (Block m l) -> ZHead m |

664 | -> FactKont a b -> FactKont a b |

665 | solve_OC :: ZTail m l -> BlockEnv (Block m l) |

666 | -> LOFsKont a b -> FactKont a b |

667 | |

668 | solve_OO entry blocks exit k in' = |

669 | do { set_local_blocks_with_exit blocks exit |

670 | ; solve_tail entry set_last in' |

671 | ; solve_blocks (postorder_dfs_from blocks entry) |

672 | ; solve_head exit k } |

673 | |

674 | solve_CO id blocks exit k = |

675 | do { set_local_blocks_with_exit blocks exit |

676 | ; solve_blocks (postorder_dfs_from blocks (BlockPtr id)) |

677 | ; solve_head exit k } |

678 | |

679 | solve_OC entry blocks k in' = |

680 | do { set_local_blocks blocks |

681 | ; solve_tail entry set_last in' |

682 | ; solve_blocks (postorder_dfs_from blocks entry) |

683 | ; facts <- getLastOutFacts |

684 | ; k facts } |

685 | |

686 | ----------- ANALYSIS FUNCTIONS FOR SHALLOW REWRITING -------- |

687 | |

688 | -- inputs of each analysis depend on whether entry is open; |

689 | -- outputs depend on whether exit is open: |

690 | anal_f_OO :: ZipGF m l O O -> a -> DFM a a |

691 | anal_f_OC :: ZipGF m l O C -> a -> DFM a (LastOutFacts a) |

692 | anal_f_CO :: ZipGF m l C O -> DFM a a |

693 | |

694 | -- we have only one top-level analysis, so we specialize anal_f |

695 | anal_f_OO g = anal_f g (return . fromZJust) . ZJust |

696 | anal_f_OC g = anal_f g (\ _ -> getLastOutFacts) . ZJust |

697 | anal_f_CO g = anal_f g (return . fromZJust) ZNothing |

698 | |

699 | anal_f :: ZipGF m l e x -> (ZKont x a b) -> ZKont e a b |

700 | anal_f g finish in' = getAllFacts >>= \env -> |

701 | fwd_pure_anal name env transfers in' g >>= finish |

702 | -- XXX is this correct or do we want the empty env? |

703 | |

704 | |

705 | newtype BlockPtr = BlockPtr BlockId -- pointer to a successor block |

706 | instance HavingSuccessors BlockPtr where |

707 | fold_succs add (BlockPtr id) z = add id z |

708 | |

709 | set_local_blocks :: (DataflowAnalysis df) => BlockEnv b -> df a () |

710 | set_local_blocks_with_exit :: (DataflowAnalysis df) => BlockEnv b -> ZHead m -> df a () |

711 | set_local_blocks blockenv = setInternalBlocks $ is_internal blockenv |

712 | set_local_blocks_with_exit blockenv exit = |

713 | setInternalBlocks $ is_internal blockenv `orp` (== label exit) |

714 | where label (ZFirst id) = id |

715 | label (ZHead h _) = label h |

716 | orp p q x = p x || q x |

717 | |

718 | is_internal :: BlockEnv a -> BlockId -> Bool |

719 | is_internal env = isJust . lookupBlockEnv env |

720 | |

721 | getLastOutFacts :: DFM f (LastOutFacts f) |

722 | getLastOutFacts = bareLastOutFacts >>= return . LastOutFacts |

723 | |

724 | |

725 | type GraphFactKont m l e x a b = ZipGF m l e x -> a -> DFM a b |

726 | type GraphKont m l e x a b = ZipGF m l e x -> DFM a b |

727 | |

728 | {- |

729 | forward_rew |

730 | :: forall m l e x a . |

731 | (DebugNodes m l e x, LastNode l, Outputable a) |

732 | => (forall b . Maybe b -> DFM a (Maybe b)) |

733 | -> RewritingDepth |

734 | -> BlockEnv a |

735 | -> PassName |

736 | -> ForwardTransfers m l a |

737 | -> ForwardRewrites m l a |

738 | -> a |

739 | -> ZipGF m l |

740 | -> DFM a (ZipGF m l, Maybe a) |

741 | forward_rew with_fuel = forw |

742 | where |

743 | forw :: RewritingDepth |

744 | -> BlockEnv a |

745 | -> PassName |

746 | -> ForwardTransfers m l a |

747 | -> ForwardRewrites m l a |

748 | -> a |

749 | -> ZipGF m l |

750 | -> DFM a (ZipGF m l, Maybe a) |

751 | forw depth start_facts name transfers rewrites in_fact g = |

752 | do setAllFacts start_facts |

753 | sar_Ox g (\ma g -> return (g, ma)) in_fact |

754 | where |

755 | ----------- REWRITE FUNCTIONS FOR NODES -------------- |

756 | rew_first :: BlockId -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

757 | rew_first id k head = |

758 | do a <- getFact id |

759 | (with_fuel $ fr_first rewrites id a) >>= \x -> case x of |

760 | Nothing -> k (head `appId` id) (ft_first_out transfers id a) |

761 | Just g -> |

762 | do { markGraphRewritten |

763 | ; g <- importGraph g |

764 | ; (g, a) <- subAnalysis' $ |

765 | case depth of |

766 | RewriteDeep -> sar_CO id g return2 |

767 | RewriteShallow -> do { a <- anal_f_CO id g; return (g, a) } |

768 | ; k (head <*> g) a } |

769 | |

770 | rew_mid :: m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

771 | rew_mid m k head in' = |

772 | my_trace "Rewriting middle node" (ppr m) $ |

773 | (with_fuel $ fr_middle rewrites m in') >>= \x -> case x of |

774 | Nothing -> k (head `appMid` m) (ft_middle_out transfers m in') |

775 | Just g -> |

776 | do { markGraphRewritten |

777 | ; g <- importGraph g |

778 | ; (g, a) <- subAnalysis' $ |

779 | case depth of |

780 | RewriteDeep -> sar_OO g return2 in' |

781 | RewriteShallow -> do { a <- anal_f_OO g in'; return (g, a) } |

782 | ; k (head <*> g) a } |

783 | |

784 | rew_last :: l -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

785 | rew_last l k head in' = |

786 | my_trace "Rewriting last node" (ppr l) $ |

787 | (with_fuel $ fr_last rewrites l in') >>= \x -> case x of |

788 | Nothing -> do check_facts in' l -- redundant error checking |

789 | k (head <=*> (ZLast l::ZTail m l)) |

790 | Just g -> |

791 | do { markGraphRewritten |

792 | ; g <- importGraph g |

793 | ; g <- subAnalysis' $ |

794 | case depth of |

795 | RewriteDeep -> sar_OC g return in' |

796 | RewriteShallow -> return g |

797 | ; k (head <*> g) } |

798 | |

799 | where check_facts in' l = |

800 | let LastOutFacts last_outs = ft_last_outs transfers l in' |

801 | in mapM (uncurry checkFactMatch) last_outs |

802 | |

803 | ----------- REWRITE FUNCTIONS FOR SEQUENCES OF NODES -------------- |

804 | rew_mids :: ZMids m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

805 | rew_mids (ZUnit) = id |

806 | rew_mids (ZMid m) = rew_mid m |

807 | rew_mids (ZCat m1 m2) = rew_mids m1 . rew_mids m2 |

808 | |

809 | rew_tail :: ZTail m l -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

810 | rew_tail (ZTail m t) = rew_mid m . rew_tail t |

811 | rew_tail (ZLast l) = rew_last l |

812 | |

813 | rew_head :: ZHead m -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

814 | rew_head (ZHead h m) = rew_head h . rew_mid m |

815 | rew_head (ZFirst id) = rew_first id |

816 | |

817 | rew_block :: Block m l -> GraphKont m l e x a b -> GraphKont m l e x a b |

818 | rew_block (Block id tail) = rew_first id . rew_tail tail |

819 | |

820 | rew_blocks :: [Block m l] -> GraphKont m l e x a b -> GraphKont m l e x a b |

821 | rew_blocks = flip (foldr rew_block) |

822 | -- 'foldl (flip rew_block)' might consume less stack than 'foldr rew_block'? |

823 | |

824 | -------- ANALYSIS FUNCTIONS FOR NON-REWRITTEN GRAPHS ----- |

825 | -- this code is almost exact duplicate of solver code |

826 | anal_f :: (Maybe a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b |

827 | anal_f finish g in' = subAnalysis $ |

828 | do { env <- getAllFacts ; fwd_pure_anal name env transfers in' g >>= finish } |

829 | |

830 | anal_f_OO :: ZipGF m l e x -> a -> DFM a a |

831 | anal_f_OO = anal_f (return . fromMaybe (panic "no exit fact?!")) |

832 | |

833 | anal_f_CO :: BlockId -> ZipGF m l e x -> DFM a a |

834 | anal_f_CO id g = botFact >>= anal_f_OO (mkLast (mkBranchNode id) <*> g) |

835 | -- exact duplicate ends |

836 | |

837 | solve :: GraphFactKont m l e x a (Maybe a) |

838 | solve g in' = |

839 | do { facts <- getAllFacts |

840 | ; forward_sol with_fuel depth name facts transfers rewrites in' g } |

841 | |

842 | |

843 | -------- SOLVE-AND-REWRITE COMBINATIONS FOR GRAPHS ---------- |

844 | -- sar_ex == solve-and-rewrite entry exit |

845 | |

846 | sar_Ox :: ZipGF m l e x -> (Maybe a -> GraphKont m l e x a b) -> FactKont a b |

847 | sar_Ox g@(GF _ _ Nothing) pre_k = sar_OC g (pre_k Nothing) |

848 | sar_Ox g pre_k = sar_OO g (\g a -> pre_k (Just a) g) |

849 | |

850 | sar_OO :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b |

851 | sar_CO :: BlockId -> ZipGF m l e x -> GraphFactKont m l e x a b -> Kont a b |

852 | sar_OC :: ZipGF m l e x -> GraphKont m l e x a b -> FactKont a b |

853 | |

854 | sar_OO g k in' = solve g in' >> rew_OO' g k emptyZipGF in' |

855 | sar_OC g k in' = solve g in' >> rew_OC' g k emptyZipGF in' |

856 | sar_CO id g k = |

857 | do { in' <- botFact; solve g' in' ; rew_CO' id g k emptyZipGF } |

858 | where g' = mkLast (mkBranchNode id) <*> g |

859 | |

860 | ----------------- REWRITE FUNCTIONS FOR GRAPHS --------------- |

861 | rew_OO' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

862 | rew_OC' :: ZipGF m l e x -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

863 | rew_CO' :: BlockId -> ZipGF m l e x -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

864 | |

865 | rew_OO' (GM mids) = rew_mids mids |

866 | rew_OO' (GF (Just entry) blockenv (Just exit)) = rew_OO entry blockenv exit |

867 | rew_OO' _ = panic "EX graph missing entry or exit" |

868 | |

869 | rew_OC' (GF (Just entry) blockenv Nothing) = rew_OC entry blockenv |

870 | rew_OC' _ = panic "EJ graph is exitable" |

871 | |

872 | rew_CO' id (GF Nothing blockenv (Just exit)) = rew_CO id blockenv exit |

873 | rew_CO' _ _ = panic "BX graph is enterable" |

874 | |

875 | rew_OO :: ZTail m l e x -> BlockEnv (Block m l) -> ZHead m |

876 | -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

877 | rew_OC :: ZTail m l e x -> BlockEnv (Block m l) |

878 | -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

879 | rew_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m |

880 | -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

881 | |

882 | rew_OO entry blockenv exit = |

883 | rew_tail entry . |

884 | rew_blocks (postorder_dfs_from blockenv entry) . |

885 | rew_head exit |

886 | |

887 | rew_OC entry blockenv = |

888 | rew_tail entry . |

889 | rew_blocks (postorder_dfs_from blockenv entry) |

890 | |

891 | rew_CO id blockenv exit = |

892 | rew_blocks (postorder_dfs_from blockenv (BlockPtr id)) . |

893 | rew_head exit |

894 | -} |

895 | |

896 | return2 :: Monad m => a -> b -> m (a, b) |

897 | return2 = curry return |

898 | |

899 | {- |

900 | {- ================== ONCE MORE, ONLY BACKWARD THIS TIME =========================== -} |

901 | |

902 | solve_b :: (DebugNodes m l e x, Outputable a) |

903 | => BlockEnv a -- initial facts (unbound == bottom) |

904 | -> PassName |

905 | -> DataflowLattice a -- lattice |

906 | -> BackwardTransfers m l a -- dataflow transfer functions |

907 | -> a -- exit fact |

908 | -> ZipGF m l e x -- graph to be analyzed |

909 | -> BackwardFixedPoint m l e x a () -- answers |

910 | solve_b env name lattice transfers exit_fact g = |

911 | runWithoutFuel $ runDFM lattice $ bfp () $ |

912 | bwd_pure_anal name env transfers g exit_fact |

913 | |

914 | |

915 | rewrite_b_agraph :: (DebugNodes m l e x, Outputable a) |

916 | => RewritingDepth |

917 | -> BlockEnv a |

918 | -> PassName |

919 | -> DataflowLattice a |

920 | -> BackwardTransfers m l a |

921 | -> BackwardRewrites m l a |

922 | -> a -- fact flowing in at exit |

923 | -> ZipGF m l |

924 | -> FuelMonad (BackwardFixedPoint m l e x a (ZipGF m l)) |

925 | rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g = |

926 | runDFM lattice $ |

927 | do fuel <- fuelRemaining |

928 | fp <- rewr_fp $ backward_rew maybeRewriteAndUseFuel depth start_facts name |

929 | transfers rewrites g exit_fact |

930 | fuel' <- fuelRemaining |

931 | fuelDecrement name fuel fuel' |

932 | return fp |

933 | where rewr_fp ga = do { (g, a) <- ga ; bfp g $ return a } |

934 | |

935 | |

936 | bwd_pure_anal :: (DebugNodes m l e x, HavingSuccessors l, Outputable a) |

937 | => PassName |

938 | -> BlockEnv a |

939 | -> BackwardTransfers m l a |

940 | -> ZipGF m l |

941 | -> a |

942 | -> DFM a a |

943 | |

944 | bwd_pure_anal name env transfers g exit_fact = |

945 | anal_b name env transfers panic_rewrites g exit_fact |

946 | where -- another case of "I love lazy evaluation" |

947 | anal_b = backward_sol (\ _ -> return Nothing) panic_depth |

948 | panic_rewrites = panic "pure analysis asked for a rewrite function" |

949 | panic_depth = panic "pure analysis asked for a rewrite depth" |

950 | |

951 | |

952 | |

953 | backward_sol :: forall m l e x a . |

954 | (DebugNodes m l e x, HavingSuccessors l, Outputable a) |

955 | => (forall b . Maybe b -> DFM a (Maybe b)) |

956 | -> RewritingDepth |

957 | -> PassName |

958 | -> BlockEnv a |

959 | -> BackwardTransfers m l a |

960 | -> BackwardRewrites m l a |

961 | -> ZipGF m l |

962 | -> a |

963 | -> DFM a a |

964 | backward_sol with_fuel = back -- see [Note inlining] below |

965 | where |

966 | back :: RewritingDepth |

967 | -> PassName |

968 | -> BlockEnv a |

969 | -> BackwardTransfers m l a |

970 | -> BackwardRewrites m l a |

971 | -> ZipGF m l |

972 | -> a |

973 | -> DFM a a |

974 | back depth name start_facts transfers rewrites = |

975 | \ g exit_fact -> do { setAllFacts start_facts; solve_Ox g exit_fact } |

976 | where |

977 | solve_Ox :: ZipGF m l e x -> FactKont a a |

978 | solve_Ox g@(GF Nothing _ _) = \_ -> solve_OC' g return |

979 | solve_Ox g = solve_OO' g return |

980 | |

981 | ----------- SOLVER FUNCTIONS FOR NODES -------------- |

982 | solve_first :: BlockId -> Kont a b -> FactKont a b |

983 | solve_first id k a = |

984 | (with_fuel $ br_first rewrites id a) >>= \x -> case x of |

985 | Nothing -> do { my_trace "solve_first" (ppr id <+> text "=" <+> |

986 | ppr (bt_first_in transfers id a)) $ |

987 | setFact id $ bt_first_in transfers id a |

988 | ; k } |

989 | Just g -> |

990 | do { g <- importGraph g |

991 | ; my_trace "analysis rewrites first node" (ppr id <+> ppr g) $ |

992 | subAnalysis' $ |

993 | case depth of |

994 | RewriteDeep -> solve_CO' id g (return ()) a |

995 | RewriteShallow -> anal_b_CO g a |

996 | ; k } |

997 | |

998 | solve_mid :: m -> FactKont a b -> FactKont a b |

999 | solve_mid m k a = |

1000 | (with_fuel $ br_middle rewrites m a) >>= \x -> case x of |

1001 | Nothing -> k (bt_middle_in transfers m a) |

1002 | Just g -> |

1003 | do { g <- importGraph g |

1004 | ; a <- |

1005 | my_trace "analysis rewrites middle node" (ppr m <+> ppr g) $ |

1006 | subAnalysis' $ |

1007 | case depth of |

1008 | RewriteDeep -> solve_OO' g return a |

1009 | RewriteShallow -> anal_b_OO g a |

1010 | ; k a } |

1011 | |

1012 | solve_last :: l -> FactKont a b -> Kont a b |

1013 | solve_last l k = |

1014 | do env <- factsEnv |

1015 | (with_fuel $ br_last rewrites l env) >>= \x -> case x of |

1016 | Nothing -> k (bt_last_in transfers l env) |

1017 | Just g -> |

1018 | do { g <- importGraph g |

1019 | ; a <- |

1020 | my_trace "analysis rewrites last node" (ppr l <+> ppr g) $ |

1021 | subAnalysis' $ |

1022 | case depth of |

1023 | RewriteDeep -> solve_OC' g return |

1024 | RewriteShallow -> anal_b_OC g |

1025 | ; k a } |

1026 | |

1027 | ----------- SOLVER FUNCTIONS FOR SEQUENCES OF NODES ----------- |

1028 | |

1029 | -- bodies and type signatures are dual to forward case |

1030 | -- (swap FactKont and Kont) |

1031 | solve_mids :: ZMids m -> FactKont a b -> FactKont a b |

1032 | solve_mids (ZUnit) = id |

1033 | solve_mids (ZMid m) = solve_mid m |

1034 | solve_mids (ZCat m1 m2) = solve_mids m2 . solve_mids m1 |

1035 | |

1036 | solve_tail :: ZTail m l -> FactKont a b -> Kont a b |

1037 | solve_tail (ZTail m t) = solve_tail t . solve_mid m |

1038 | solve_tail (ZLast l) = solve_last l |

1039 | |

1040 | solve_head :: ZHead m -> Kont a b -> FactKont a b |

1041 | solve_head (ZHead h m) = solve_mid m . solve_head h |

1042 | solve_head (ZFirst id) = solve_first id |

1043 | |

1044 | solve_block :: Block m l -> Kont a () |

1045 | solve_block (Block id tail) = solve_tail tail $ solve_first id $ return () |

1046 | |

1047 | ----------- SOLVER FUNCTIONS FOR GRAPHS -------------- |

1048 | |

1049 | solve_blocks :: [Block m l] -> Kont a () |

1050 | solve_blocks = run "backward" name solve_block |

1051 | |

1052 | -- primed functions perform dynamic checks; we may one day |

1053 | -- want to refine types to eliminate the dynamic checks |

1054 | solve_CO' :: BlockId -> ZipGF m l e x -> Kont a b -> FactKont a b |

1055 | solve_OO' :: ZipGF m l e x -> FactKont a b -> FactKont a b |

1056 | solve_OC' :: ZipGF m l e x -> FactKont a b -> Kont a b |

1057 | |

1058 | solve_CO' id (GF Nothing blocks (Just exit)) = solve_CO id blocks exit |

1059 | solve_CO' _ _ = panic "solve_CO given enterable or unexitable graph" |

1060 | |

1061 | solve_OO' (GM mids) = solve_mids mids |

1062 | solve_OO' (GF (Just entry) blocks (Just exit)) = solve_OO entry blocks exit |

1063 | solve_OO' _ = panic "solve_OO given unenterable or unexitable graph" |

1064 | |

1065 | solve_OC' (GF (Just entry) blocks Nothing) = solve_OC entry blocks |

1066 | solve_OC' _ = panic "solve_OC given unenterable or exitable graph" |

1067 | |

1068 | -- from here down, the dynamic checks have already been done |

1069 | solve_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m |

1070 | -> Kont a b -> FactKont a b |

1071 | solve_OO :: ZTail m l -> BlockEnv (Block m l) -> ZHead m |

1072 | -> FactKont a b -> FactKont a b |

1073 | solve_OC :: ZTail m l -> BlockEnv (Block m l) |

1074 | -> FactKont a b -> Kont a b |

1075 | |

1076 | solve_OO entry blocks exit k a = |

1077 | do { set_local_blocks_with_exit blocks exit |

1078 | ; solve_head exit (return ()) a |

1079 | ; solve_blocks (reverse $ postorder_dfs_from blocks entry) |

1080 | ; solve_tail entry k } |

1081 | |

1082 | solve_CO id blocks exit k a = |

1083 | do { set_local_blocks_with_exit blocks exit |

1084 | ; solve_head exit (return ()) a |

1085 | ; solve_blocks (reverse $ postorder_dfs_from blocks (BlockPtr id)) |

1086 | ; k } |

1087 | |

1088 | solve_OC entry blocks k = |

1089 | do { set_local_blocks blocks |

1090 | ; solve_blocks (reverse $ postorder_dfs_from blocks entry) |

1091 | ; solve_tail entry k } |

1092 | |

1093 | ----------- ANALYSIS FUNCTIONS FOR SHALLOW REWRITING -------- |

1094 | |

1095 | -- inputs of each analysis depend on whether exit is open; |

1096 | -- outputs depend on whether entry is open: |

1097 | anal_b_OO :: ZipGF m l e x -> a -> DFM a a |

1098 | anal_b_OC :: ZipGF m l e x -> DFM a a |

1099 | anal_b_CO :: ZipGF m l e x -> a -> DFM a () |

1100 | |

1101 | -- we have only one top-level analysis, so we specialize anal_b |

1102 | anal_b_OO = anal_b return |

1103 | anal_b_OC g = do a <- return $ panic "closed graph used exit fact" |

1104 | anal_b return g a |

1105 | anal_b_CO = anal_b (const $ return ()) |

1106 | |

1107 | anal_b :: (a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b |

1108 | anal_b finish g a = getAllFacts >>= \env -> |

1109 | bwd_pure_anal name env transfers g a >>= finish |

1110 | -- XXX is this correct or do we want the empty env? |

1111 | |

1112 | |

1113 | {- ================================================================ -} |

1114 | |

1115 | backward_rew |

1116 | :: forall m l e x a . |

1117 | (DebugNodes m l e x, HavingSuccessors l, Outputable a) |

1118 | => (forall b . Maybe b -> DFM a (Maybe b)) |

1119 | -> RewritingDepth |

1120 | -> BlockEnv a |

1121 | -> PassName |

1122 | -> BackwardTransfers m l a |

1123 | -> BackwardRewrites m l a |

1124 | -> ZipGF m l |

1125 | -> a |

1126 | -> DFM a (ZipGF m l, a) |

1127 | backward_rew with_fuel = back -- see [Note inline] |

1128 | where |

1129 | back :: RewritingDepth |

1130 | -> BlockEnv a |

1131 | -> PassName |

1132 | -> BackwardTransfers m l a |

1133 | -> BackwardRewrites m l a |

1134 | -> ZipGF m l |

1135 | -> a |

1136 | -> DFM a (ZipGF m l, a) |

1137 | back depth start_facts name transfers rewrites gx exit_fact = |

1138 | do { setAllFacts start_facts; sar_Ox gx return2 exit_fact } |

1139 | where |

1140 | ----------- REWRITE FUNCTIONS FOR NODES -------------- |

1141 | rew_first :: BlockId -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

1142 | rew_first id k tail a = |

1143 | (with_fuel $ br_first rewrites id a) >>= \x -> case x of |

1144 | Nothing -> check_k (mkLabel id <*> tail) (bt_first_in transfers id a) |

1145 | Just g -> |

1146 | do { markGraphRewritten |

1147 | ; g <- importGraph g |

1148 | ; my_trace "Rewrote first node" |

1149 | (f4sep [ppr id <> colon, text "to", ppr g]) $ return () |

1150 | ; g <- |

1151 | case depth of |

1152 | RewriteDeep -> sar_CO id g return a |

1153 | RewriteShallow -> do { anal_b_CO g a; return g } |

1154 | ; k (g <*> tail) } |

1155 | where check_k tail a = |

1156 | do { if check then checkFactMatch id a else return () |

1157 | ; k tail } |

1158 | |

1159 | rew_mid :: m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

1160 | rew_mid m k tail a = |

1161 | (with_fuel $ br_middle rewrites m a) >>= \x -> case x of |

1162 | Nothing -> k (m `preMid` tail) (bt_middle_in transfers m a) |

1163 | Just g -> |

1164 | do { markGraphRewritten |

1165 | ; g <- importGraph g |

1166 | ; my_trace "With Facts" (ppr a) $ return () |

1167 | ; my_trace " Rewrote middle node" |

1168 | (f4sep [ppr m, text "to", ppr g]) $ |

1169 | return () |

1170 | ; (g, a) <- |

1171 | case depth of |

1172 | RewriteDeep -> sar_OO g return2 a |

1173 | RewriteShallow -> do { a <- anal_b_OO g a; return (g, a) } |

1174 | ; k (g <*> tail) a } |

1175 | |

1176 | rew_last :: l -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

1177 | rew_last l k tail = |

1178 | do { env <- factsEnv |

1179 | ; (with_fuel $ br_last rewrites l env) >>= \x -> case x of |

1180 | Nothing -> |

1181 | k (mkLast l <*> tail) (bt_last_in transfers l env) |

1182 | Just g -> |

1183 | do { markGraphRewritten |

1184 | ; g <- importGraph g |

1185 | ; (g, a) <- |

1186 | case depth of |

1187 | RewriteDeep -> sar_OC g return2 |

1188 | RewriteShallow -> do { a <- anal_b_OC g; return (g, a) } |

1189 | ; k (g <*> tail) a } } |

1190 | |

1191 | ----------- REWRITE FUNCTIONS FOR SEQUENCES OF NODES -------------- |

1192 | rew_mids :: ZMids m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

1193 | rew_mids (ZUnit) = id |

1194 | rew_mids (ZMid m) = rew_mid m |

1195 | rew_mids (ZCat m1 m2) = rew_mids m2 . rew_mids m1 |

1196 | |

1197 | rew_tail :: ZTail m l -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

1198 | rew_tail (ZTail m t) = rew_tail t . rew_mid m |

1199 | rew_tail (ZLast l) = rew_last l |

1200 | |

1201 | rew_head :: ZHead m -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

1202 | rew_head (ZHead h m) = rew_mid m . rew_head h |

1203 | rew_head (ZFirst id) = rew_first id |

1204 | |

1205 | rew_block :: Block m l -> GraphKont m l e x a b -> GraphKont m l e x a b |

1206 | rew_block (Block id tail) = rew_tail tail . rew_first id |

1207 | |

1208 | rew_blocks :: [Block m l] -> GraphKont m l e x a b -> GraphKont m l e x a b |

1209 | rew_blocks = flip (foldr rew_block) |

1210 | -- 'foldl (flip rew_block)' might consume less stack than 'foldr rew_block'? |

1211 | |

1212 | |

1213 | -------- ANALYSIS FUNCTIONS FOR NON-REWRITTEN GRAPHS ----- |

1214 | -- this code is almost exact duplicate of solver code |

1215 | anal_b :: (a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b |

1216 | anal_b finish g a = subAnalysis $ |

1217 | do { env <- getAllFacts ; bwd_pure_anal name env transfers g a >>= finish } |

1218 | |

1219 | anal_b_OO :: ZipGF m l e x -> a -> DFM a a |

1220 | anal_b_OO = anal_b return |

1221 | |

1222 | anal_b_CO :: ZipGF m l e x -> a -> DFM a () |

1223 | anal_b_CO = anal_b (const $ return ()) |

1224 | |

1225 | anal_b_OC :: ZipGF m l e x -> DFM a a |

1226 | anal_b_OC = \g -> anal_b return g (panic "closed graph used exit fact") |

1227 | -- exact duplicate ends |

1228 | |

1229 | solve :: GraphFactKont m l e x a a |

1230 | solve g a = |

1231 | do { facts <- getAllFacts |

1232 | ; backward_sol with_fuel depth name facts transfers rewrites g a } |

1233 | |

1234 | -------- SOLVE-AND-REWRITE COMBINATIONS FOR GRAPHS ---------- |

1235 | -- sar_ex == solve-and-rewrite entry exit |

1236 | |

1237 | sar_Ox :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b |

1238 | sar_Ox g@(GF _ _ Nothing) = \ k _ -> sar_OC g k |

1239 | sar_Ox g = sar_OO g |

1240 | |

1241 | |

1242 | sar_OO :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b |

1243 | sar_CO :: BlockId -> ZipGF m l e x -> GraphKont m l e x a b -> FactKont a b |

1244 | sar_OC :: ZipGF m l e x -> GraphFactKont m l e x a b -> Kont a b |

1245 | |

1246 | |

1247 | sar_OO g k a = solve g a >> rew_OO' g k emptyZipGF a |

1248 | sar_OC g k = solve g nx >> rew_OC' g k emptyZipGF |

1249 | sar_CO id g k a = solve g a >> rew_CO' id g k emptyZipGF a |

1250 | |

1251 | nx = panic "non-exitable graph tried to use exit fact" |

1252 | |

1253 | ----------------- REWRITE FUNCTIONS FOR GRAPHS --------------- |

1254 | rew_OO' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

1255 | rew_OC' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

1256 | rew_CO' :: BlockId -> ZipGF m l e x -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

1257 | |

1258 | rew_OO' (GM mids) = rew_mids mids |

1259 | rew_OO' (GF (Just entry) blockenv (Just exit)) = rew_OO entry blockenv exit |

1260 | rew_OO' _ = panic "EX graph missing entry or exit" |

1261 | |

1262 | rew_OC' (GF (Just entry) blockenv Nothing) = rew_OC entry blockenv |

1263 | rew_OC' _ = panic "EJ graph is exitable" |

1264 | |

1265 | rew_CO' id (GF Nothing blockenv (Just exit)) = rew_CO id blockenv exit |

1266 | rew_CO' _ _ = panic "BX graph is enterable" |

1267 | |

1268 | rew_OO :: ZTail m l e x -> BlockEnv (Block m l) -> ZHead m |

1269 | -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b |

1270 | rew_OC :: ZTail m l -> BlockEnv (Block m l) |

1271 | -> GraphFactKont m l e x a b -> GraphKont m l e x a b |

1272 | rew_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m |

1273 | -> GraphKont m l e x a b -> GraphFactKont m l e x a b |

1274 | |

1275 | rew_OO entry blockenv exit = |

1276 | rew_head exit . |

1277 | rew_blocks (reverse $ postorder_dfs_from blockenv entry) . |

1278 | rew_tail entry |

1279 | |

1280 | rew_OC entry blockenv = |

1281 | rew_blocks (reverse $ postorder_dfs_from blockenv entry) . |

1282 | rew_tail entry |

1283 | |

1284 | rew_CO id blockenv exit = |

1285 | rew_head exit . |

1286 | rew_blocks (postorder_dfs_from blockenv (BlockPtr id)) |

1287 | |

1288 | -} |

1289 | |

1290 | check :: Bool -- whether to do extra checking during execution |

1291 | check = True |

1292 | |

1293 | {- ================================================================ -} |

1294 | |

1295 | |

1296 | dump_things :: Bool |

1297 | dump_things = False |

1298 | |

1299 | my_trace :: String -> SDoc -> a -> a |

1300 | my_trace = if dump_things then pprTrace else \_ _ a -> a |

1301 | |

1302 | |

1303 | -- | Here's a function to run an action on blocks until we reach a fixed point. |

1304 | -- It changes facts but leaves the fuel supply untouched. |

1305 | run :: (Outputable a, Outputable m, Outputable l) => |

1306 | String -> String -> (Block m l -> DFM a ()) -> [Block m l] -> DFM a () |

1307 | run dir name do_block blocks = |

1308 | do { show_blocks $ iterate (1::Int) } |

1309 | where |

1310 | -- N.B. Each iteration starts and finished with the same fuel supply; |

1311 | -- only rewrites in a rewriting function actually count |

1312 | trace_block cnt block = |

1313 | do my_trace "about to do" (text name <+> text "on" <+> |

1314 | ppr (blockId block) <+> ppr cnt) $ |

1315 | do_block block |

1316 | return (cnt + 1) |

1317 | iterate n = |

1318 | do { markFactsUnchanged |

1319 | ; my_trace "block count:" (ppr (length blocks)) $ |

1320 | withDuplicateFuel $ foldM trace_block (0 :: Int) blocks |

1321 | ; changed <- factsStatus |

1322 | ; facts <- getAllFacts |

1323 | ; let depth = 0 -- was nesting depth |

1324 | ; ppIter depth n $ |

1325 | case changed of |

1326 | NoChange -> unchanged depth $ return () |

1327 | SomeChange -> |

1328 | pprFacts depth n facts $ |

1329 | if n < 1000 then iterate (n+1) |

1330 | else panic $ msg n |

1331 | } |

1332 | msg n = concat [name, " didn't converge in ", show n, " " , dir, " iterations"] |

1333 | my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc |

1334 | ppIter depth n = |

1335 | my_nest depth (empty $$ text "*************** iteration" <+> pp_i n) |

1336 | pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId |

1337 | unchanged depth = |

1338 | my_nest depth (text "facts for" <+> graphId <+> text "are unchanged") |

1339 | |

1340 | graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" } |

1341 | show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) |

1342 | pprBlock (Block id t) = nest 2 (pprFact (id, t)) |

1343 | pprFacts depth n env = |

1344 | my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$ |

1345 | (nest 2 $ vcat $ map pprFact $ blockEnvToList env)) |

1346 | pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) |

1347 | |

1348 | |

1349 | f4sep :: [SDoc] -> SDoc |

1350 | f4sep [] = fsep [] |

1351 | f4sep (d:ds) = fsep (d : map (nest 4) ds) |

1352 | |

1353 | |

1354 | subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => m f a -> m f a |

1355 | subAnalysis' m = |

1356 | do { a <- subAnalysis $ |

1357 | do { a <- m; -- facts <- getAllFacts |

1358 | ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $ |

1359 | return a } |

1360 | -- ; facts <- getAllFacts |

1361 | ; -- my_trace "in parent analysis facts are" (pprFacts facts) $ |

1362 | return a } |

1363 | -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env |

1364 | -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) |

1365 | |

1366 | |

1367 | {- |

1368 | |

1369 | [Note inlining] |

1370 | ~~~~~~~~~~~~~~~ |

1371 | The definitions of 'forward_sol' and 'backward_sol' are curried in a funny |

1372 | way because we badly want GHC to inline and specialize the partial application |

1373 | |

1374 | forward_sol (\_ _ -> Nothing) |

1375 | |

1376 | NR checked on this property ages ago (summer 2007), but it needs to be checked |

1377 | again once things will have stabilized in mid-2009. |

1378 | |

1379 | -} |

1380 | |

1381 | {- ================= EXTRA UTILITY SPLICING FUNCTIONS ================ -} |

1382 | |

1383 | |

1384 | appId :: ZipGF m l e C -> BlockId -> ZipGF m l e O -- splice new label onto closed graph |

1385 | appId (GF entry blocks ZX_C) id = GF entry blocks (ZX_O $ ZFirst id) |

1386 | appId _ _ = can't_match |

1387 | |

1388 | |

1389 | |

1390 | -- based on no measurement whatever, NR felt this special case was |

1391 | -- worth optimizing (avoids allocating 'ZMid m' in the 'GF' case): |

1392 | -- appMid g m = g <=*> ZMid m |

1393 | appMid :: ZipGF m l e O -> m -> ZipGF m l e O |

1394 | appMid (GM ms) m = GM $ ZCat ms (ZMid m) |

1395 | appMid (GF entry blocks (ZX_O h)) m = GF entry blocks (ZX_O $ ZHead h m) |

1396 | --appMid (GF _ _ ZX_C) _ = can't_match |

1397 | |

1398 | preMid :: m -> ZipGF m l O x -> ZipGF m l O x |

1399 | preMid m (GM ms) = GM $ ZCat (ZMid m) ms |

1400 | preMid m (GF (ZE_O t) blocks exit) = GF (ZX_O $ ZTail m t) blocks exit |

1401 | --preMid _ (GF (ZE_C _) _ _) = can't_match |

1402 | |

1403 | can't_match :: a |

1404 | can't_match = panic "GADT pattern matcher is too stupid to live" |