ALWAYS warn of incomplete pattern matches.
[packages/hoopl.git] / src / Compiler / Hoopl / Dataflow.hs
1 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}
2
3 {- Notes about the genesis of Hoopl7
4 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5 Hoopl7 has the following major chages
6
7 a) GMany has symmetric entry and exit
8 b) GMany closed-entry does not record a BlockId
9 c) GMany open-exit does not record a BlockId
10 d) The body of a GMany is called Body
11 e) A Body is just a list of blocks, not a map. I've argued
12 elsewhere that this is consistent with (c)
13
14 A consequence is that Graph is no longer an instance of Edges,
15 but nevertheless I managed to keep the ARF and ARB signatures
16 nice and uniform.
17
18 This was made possible by
19
20 * FwdTransfer looks like this:
21 type FwdTransfer n f
22 = forall e x. n e x -> Fact e f -> Fact x f
23 type family Fact x f :: *
24 type instance Fact C f = FactBase f
25 type instance Fact O f = f
26
27 Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).
28 It's up to the *transfer function* to look up the appropriate fact
29 in the FactBase for a closed-entry node. Example:
30 constProp (Label l) fb = lookupFact fb l
31 That is how Hoopl can avoid having to know the block-id for the
32 first node: it defers to the client.
33
34 [Side note: that means the client must know about
35 bottom, in case the looupFact returns Nothing]
36
37 * Note also that FwdTransfer *returns* a Fact too;
38 that is, the types in both directions are symmetrical.
39 Previously we returned a [(BlockId,f)] but I could not see
40 how to make everything line up if we do this.
41
42 Indeed, the main shortcoming of Hoopl7 is that we are more
43 or less forced into this uniform representation of the facts
44 flowing into or out of a closed node/block/graph, whereas
45 previously we had more flexibility.
46
47 In exchange the code is neater, with fewer distinct types.
48 And morally a FactBase is equivalent to [(BlockId,f)] and
49 nearly equivalent to (BlockId -> f).
50
51 * I've realised that forwardBlockList and backwardBlockList
52 both need (Edges n), and that goes everywhere.
53
54 * I renamed BlockId to Label
55 -}
56
57 module Compiler.Hoopl.Dataflow
58 ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact
59 , ChangeFlag(..), changeIf
60 , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer', getFTransfers
61 , FwdRes(..), FwdRewrite, mkFRewrite, mkFRewrite', getFRewrites
62 , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer', getBTransfers
63 , BwdRes(..), BwdRewrite, mkBRewrite, mkBRewrite', getBRewrites
64 , analyzeAndRewriteFwd, analyzeAndRewriteBwd
65 )
66 where
67
68 import Data.Maybe
69
70 import Compiler.Hoopl.Fuel
71 import Compiler.Hoopl.Graph
72 import Compiler.Hoopl.MkGraph
73 import qualified Compiler.Hoopl.GraphUtil as U
74 import Compiler.Hoopl.Label
75 import Compiler.Hoopl.Util
76
77 -----------------------------------------------------------------------------
78 -- DataflowLattice
79 -----------------------------------------------------------------------------
80
81 data DataflowLattice a = DataflowLattice
82 { fact_name :: String -- Documentation
83 , fact_bot :: a -- Lattice bottom element
84 , fact_extend :: JoinFun a -- Lattice join plus change flag
85 -- (changes iff result > old fact)
86 , fact_do_logging :: Bool -- log changes
87 }
88 -- ^ A transfer function might want to use the logging flag
89 -- to control debugging, as in for example, it updates just one element
90 -- in a big finite map. We don't want Hoopl to show the whole fact,
91 -- and only the transfer function knows exactly what changed.
92
93 type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a)
94 -- the label argument is for debugging purposes only
95 newtype OldFact a = OldFact a
96 newtype NewFact a = NewFact a
97
98 data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord)
99 changeIf :: Bool -> ChangeFlag
100 changeIf changed = if changed then SomeChange else NoChange
101
102
103 -----------------------------------------------------------------------------
104 -- Analyze and rewrite forward: the interface
105 -----------------------------------------------------------------------------
106
107 data FwdPass m n f
108 = FwdPass { fp_lattice :: DataflowLattice f
109 , fp_transfer :: FwdTransfer n f
110 , fp_rewrite :: FwdRewrite m n f }
111
112 newtype FwdTransfer n f
113 = FwdTransfers { getFTransfers ::
114 ( n C O -> f -> f
115 , n O O -> f -> f
116 , n O C -> f -> FactBase f
117 ) }
118
119 newtype FwdRewrite m n f
120 = FwdRewrites { getFRewrites ::
121 ( n C O -> f -> Maybe (FwdRes m n f C O)
122 , n O O -> f -> Maybe (FwdRes m n f O O)
123 , n O C -> f -> Maybe (FwdRes m n f O C)
124 ) }
125 data FwdRes m n f e x = FwdRes (AGraph m n e x) (FwdRewrite m n f)
126 -- result of a rewrite is a new graph and a (possibly) new rewrite function
127
128 mkFTransfer :: (n C O -> f -> f)
129 -> (n O O -> f -> f)
130 -> (n O C -> f -> FactBase f)
131 -> FwdTransfer n f
132 mkFTransfer f m l = FwdTransfers (f, m, l)
133
134 mkFTransfer' :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f
135 mkFTransfer' f = FwdTransfers (f, f, f)
136
137 mkFRewrite :: (n C O -> f -> Maybe (FwdRes m n f C O))
138 -> (n O O -> f -> Maybe (FwdRes m n f O O))
139 -> (n O C -> f -> Maybe (FwdRes m n f O C))
140 -> FwdRewrite m n f
141 mkFRewrite f m l = FwdRewrites (f, m, l)
142
143 mkFRewrite' :: (forall e x . n e x -> f -> Maybe (FwdRes m n f e x)) -> FwdRewrite m n f
144 mkFRewrite' f = FwdRewrites (f, f, f)
145
146
147 type family Fact x f :: *
148 type instance Fact C f = FactBase f
149 type instance Fact O f = f
150
151 -- | if the graph being analyzed is open at the entry, there must
152 -- be no other entry point, or all goes horribly wrong...
153 analyzeAndRewriteFwd
154 :: forall m n f e x entries. (FuelMonad m, Edges n, LabelsPtr entries)
155 => FwdPass m n f
156 -> MaybeC e entries
157 -> Graph n e x -> Fact e f
158 -> m (Graph n e x, FactBase f, MaybeO x f)
159 analyzeAndRewriteFwd pass entries g f =
160 do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f
161 let (g', fb) = normalizeGraph rg
162 return (g', fb, distinguishedExitFact g' fout)
163
164 distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f
165 distinguishedExitFact g f = maybe g
166 where maybe :: Graph n e x -> MaybeO x f
167 maybe GNil = JustO f
168 maybe (GUnit {}) = JustO f
169 maybe (GMany _ _ x) = case x of NothingO -> NothingO
170 JustO _ -> JustO f
171
172 ----------------------------------------------------------------
173 -- Forward Implementation
174 ----------------------------------------------------------------
175
176 type Entries e = MaybeC e [Label]
177
178 arfGraph :: forall m n f e x .
179 (Edges n, FuelMonad m) => FwdPass m n f ->
180 Entries e -> Graph n e x -> Fact e f -> m (RG f n e x, Fact x f)
181 arfGraph pass entries = graph
182 where
183 {- nested type synonyms would be so lovely here
184 type ARF thing = forall e x . thing e x -> f -> m (RG f n e x, Fact x f)
185 type ARFX thing = forall e x . thing e x -> Fact e f -> m (RG f n e x, Fact x f)
186 -}
187 graph :: Graph n e x -> Fact e f -> m (RG f n e x, Fact x f)
188 block :: forall e x . Block n e x -> f -> m (RG f n e x, Fact x f)
189 node :: forall e x . (ShapeLifter e x)
190 => n e x -> f -> m (RG f n e x, Fact x f)
191 body :: [Label] -> Body n -> Fact C f -> m (RG f n C C, Fact C f)
192 -- Outgoing factbase is restricted to Labels *not* in
193 -- in the Body; the facts for Labels *in*
194 -- the Body are in the 'RG f n C C'
195 cat :: forall m e a x info info' info''. Monad m =>
196 (info -> m (RG f n e a, info'))
197 -> (info' -> m (RG f n a x, info''))
198 -> (info -> m (RG f n e x, info''))
199
200 graph GNil = \f -> return (rgnil, f)
201 graph (GUnit blk) = block blk
202 graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x
203 where
204 ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> m (RG f n e C, Fact C f)
205 exit :: MaybeO x (Block n C O) -> Fact C f -> m (RG f n C x, Fact x f)
206 exit (JustO blk) = arfx block blk
207 exit NothingO = \fb -> return (rgnilC, fb)
208 ebcat entry bdy = c entries entry
209 where c :: MaybeC e [Label] -> MaybeO e (Block n O C)
210 -> Fact e f -> m (RG f n e C, Fact C f)
211 c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy
212 c (JustC entries) NothingO = body entries bdy
213 c _ _ = error "bogus GADT pattern match failure"
214
215 -- Lift from nodes to blocks
216 block (BFirst n) = node n
217 block (BMiddle n) = node n
218 block (BLast n) = node n
219 block (BCat b1 b2) = block b1 `cat` block b2
220 block (BHead h n) = block h `cat` node n
221 block (BTail n t) = node n `cat` block t
222 block (BClosed h t)= block h `cat` block t
223
224 node thenode f
225 = do { mb_g <- withFuel (frewrite pass thenode f)
226 ; case mb_g of
227 Nothing -> return (rgunit f (unit thenode),
228 ftransfer pass thenode f)
229 Just (FwdRes ag rw) ->
230 do { g <- graphOfAGraph ag
231 ; let pass' = pass { fp_rewrite = rw }
232 ; arfGraph pass' (entry thenode) g (elift thenode f) } }
233
234 -- | Compose fact transformers and concatenate the resulting
235 -- rewritten graphs.
236 {-# INLINE cat #-}
237 cat ft1 ft2 f = do { (g1,f1) <- ft1 f
238 ; (g2,f2) <- ft2 f1
239 ; return (g1 `rgCat` g2, f2) }
240
241 arfx :: forall thing x .
242 Edges thing
243 => (thing C x -> f -> m (RG f n C x, Fact x f))
244 -> (thing C x -> Fact C f -> m (RG f n C x, Fact x f))
245 arfx arf thing fb =
246 arf thing $ fromJust $ lookupFact (joinInFacts lattice fb) $ entryLabel thing
247 where lattice = fp_lattice pass
248 -- joinInFacts adds debugging information
249
250
251 -- Outgoing factbase is restricted to Labels *not* in
252 -- in the Body; the facts for Labels *in*
253 -- the Body are in the 'RG f n C C'
254 body entries blocks init_fbase
255 = fixpoint True (fp_lattice pass) do_block init_fbase $
256 forwardBlockList entries blocks
257 where
258 do_block b f = do (g, fb) <- block b $ lookupF pass (entryLabel b) f
259 return (g, factBaseList fb)
260
261
262
263 -- Join all the incoming facts with bottom.
264 -- We know the results _shouldn't change_, but the transfer
265 -- functions might, for example, generate some debugging traces.
266 joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f
267 joinInFacts (DataflowLattice {fact_bot = bot, fact_extend = fe}) fb =
268 mkFactBase $ map botJoin $ factBaseList fb
269 where botJoin (l, f) = (l, snd $ fe l (OldFact bot) (NewFact f))
270
271 forwardBlockList :: (Edges n, LabelsPtr entry)
272 => entry -> Body n -> [Block n C C]
273 -- This produces a list of blocks in order suitable for forward analysis,
274 -- along with the list of Labels it may depend on for facts.
275 forwardBlockList entries (Body blks) = postorder_dfs_from blks entries
276
277 -----------------------------------------------------------------------------
278 -- Backward analysis and rewriting: the interface
279 -----------------------------------------------------------------------------
280
281 data BwdPass m n f
282 = BwdPass { bp_lattice :: DataflowLattice f
283 , bp_transfer :: BwdTransfer n f
284 , bp_rewrite :: BwdRewrite m n f }
285
286 newtype BwdTransfer n f
287 = BwdTransfers { getBTransfers ::
288 ( n C O -> f -> f
289 , n O O -> f -> f
290 , n O C -> FactBase f -> f
291 ) }
292 newtype BwdRewrite m n f
293 = BwdRewrites { getBRewrites ::
294 ( n C O -> f -> Maybe (BwdRes m n f C O)
295 , n O O -> f -> Maybe (BwdRes m n f O O)
296 , n O C -> FactBase f -> Maybe (BwdRes m n f O C)
297 ) }
298 data BwdRes m n f e x = BwdRes (AGraph m n e x) (BwdRewrite m n f)
299
300 mkBTransfer :: (n C O -> f -> f) -> (n O O -> f -> f) ->
301 (n O C -> FactBase f -> f) -> BwdTransfer n f
302 mkBTransfer f m l = BwdTransfers (f, m, l)
303
304 mkBTransfer' :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f
305 mkBTransfer' f = BwdTransfers (f, f, f)
306
307 mkBRewrite :: (n C O -> f -> Maybe (BwdRes m n f C O))
308 -> (n O O -> f -> Maybe (BwdRes m n f O O))
309 -> (n O C -> FactBase f -> Maybe (BwdRes m n f O C))
310 -> BwdRewrite m n f
311 mkBRewrite f m l = BwdRewrites (f, m, l)
312
313 mkBRewrite' :: (forall e x . n e x -> Fact x f -> Maybe (BwdRes m n f e x))
314 -> BwdRewrite m n f
315 mkBRewrite' f = BwdRewrites (f, f, f)
316
317
318 -----------------------------------------------------------------------------
319 -- Backward implementation
320 -----------------------------------------------------------------------------
321
322 arbGraph :: forall m n f e x .
323 (Edges n, FuelMonad m) => BwdPass m n f ->
324 Entries e -> Graph n e x -> Fact x f -> m (RG f n e x, Fact e f)
325 arbGraph pass entries = graph
326 where
327 {- nested type synonyms would be so lovely here
328 type ARB thing = forall e x . thing e x -> Fact x f -> m (RG f n e x, f)
329 type ARBX thing = forall e x . thing e x -> Fact x f -> m (RG f n e x, Fact e f)
330 -}
331 graph :: Graph n e x -> Fact x f -> m (RG f n e x, Fact e f)
332 block :: forall e x . Block n e x -> Fact x f -> m (RG f n e x, f)
333 node :: forall e x . (ShapeLifter e x)
334 => n e x -> Fact x f -> m (RG f n e x, f)
335 body :: [Label] -> Body n -> Fact C f -> m (RG f n C C, Fact C f)
336 cat :: forall e a x info info' info''.
337 (info' -> m (RG f n e a, info''))
338 -> (info -> m (RG f n a x, info'))
339 -> (info -> m (RG f n e x, info''))
340
341 graph GNil = \f -> return (rgnil, f)
342 graph (GUnit blk) = block blk
343 graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x
344 where
345 ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> m (RG f n e C, Fact e f)
346 exit :: MaybeO x (Block n C O) -> Fact x f -> m (RG f n C x, Fact C f)
347 exit (JustO blk) = arbx block blk
348 exit NothingO = \fb -> return (rgnilC, fb)
349 ebcat entry bdy = c entries entry
350 where c :: MaybeC e [Label] -> MaybeO e (Block n O C)
351 -> Fact C f -> m (RG f n e C, Fact e f)
352 c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy
353 c (JustC entries) NothingO = body entries bdy
354 c _ _ = error "bogus GADT pattern match failure"
355
356 -- Lift from nodes to blocks
357 block (BFirst n) = node n
358 block (BMiddle n) = node n
359 block (BLast n) = node n
360 block (BCat b1 b2) = block b1 `cat` block b2
361 block (BHead h n) = block h `cat` node n
362 block (BTail n t) = node n `cat` block t
363 block (BClosed h t)= block h `cat` block t
364
365 node thenode f
366 = do { mb_g <- withFuel (brewrite pass thenode f)
367 ; case mb_g of
368 Nothing -> return (rgunit entry_f (unit thenode), entry_f)
369 where entry_f = btransfer pass thenode f
370 Just (BwdRes ag rw) ->
371 do { g <- graphOfAGraph ag
372 ; let pass' = pass { bp_rewrite = rw }
373 ; (g, f) <- arbGraph pass' (entry thenode) g f
374 ; return (g, elower (bp_lattice pass) thenode f)} }
375
376 -- | Compose fact transformers and concatenate the resulting
377 -- rewritten graphs.
378 {-# INLINE cat #-}
379 cat ft1 ft2 f = do { (g2,f2) <- ft2 f
380 ; (g1,f1) <- ft1 f2
381 ; return (g1 `rgCat` g2, f1) }
382
383 arbx :: forall thing x .
384 Edges thing
385 => (thing C x -> Fact x f -> m (RG f n C x, f))
386 -> (thing C x -> Fact x f -> m (RG f n C x, Fact C f))
387
388 arbx arb thing f = do { (rg, f) <- arb thing f
389 ; let fb = joinInFacts (bp_lattice pass) $
390 mkFactBase [(entryLabel thing, f)]
391 ; return (rg, fb) }
392 -- joinInFacts adds debugging information
393
394 -- Outgoing factbase is restricted to Labels *not* in
395 -- in the Body; the facts for Labels *in*
396 -- the Body are in the 'RG f n C C'
397 body entries blocks init_fbase
398 = fixpoint False (bp_lattice pass) do_block init_fbase $
399 backwardBlockList entries blocks
400 where
401 do_block b f = do (g, f) <- block b f
402 return (g, [(entryLabel b, f)])
403
404
405 backwardBlockList :: (LabelsPtr entries, Edges n) => entries -> Body n -> [Block n C C]
406 -- This produces a list of blocks in order suitable for backward analysis,
407 -- along with the list of Labels it may depend on for facts.
408 backwardBlockList entries body = reverse $ forwardBlockList entries body
409
410 {-
411
412 The forward and backward cases are not dual. In the forward case, the
413 entry points are known, and one simply traverses the body blocks from
414 those points. In the backward case, something is known about the exit
415 points, but this information is essentially useless, because we don't
416 actually have a dual graph (that is, one with edges reversed) to
417 compute with. (Even if we did have a dual graph, it would not avail
418 us---a backward analysis must include reachable blocks that don't
419 reach the exit, as in a procedure that loops forever and has side
420 effects.)
421
422 -}
423
424
425 -- | if the graph being analyzed is open at the exit, I don't
426 -- quite understand the implications of possible other exits
427 analyzeAndRewriteBwd
428 :: (FuelMonad m, Edges n, LabelsPtr entries)
429 => BwdPass m n f
430 -> MaybeC e entries -> Graph n e x -> Fact x f
431 -> m (Graph n e x, FactBase f, MaybeO e f)
432 analyzeAndRewriteBwd pass entries g f =
433 do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f
434 let (g', fb) = normalizeGraph rg
435 return (g', fb, distinguishedEntryFact g' fout)
436
437 distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f
438 distinguishedEntryFact g f = maybe g
439 where maybe :: Graph n e x -> MaybeO e f
440 maybe GNil = JustO f
441 maybe (GUnit {}) = JustO f
442 maybe (GMany e _ _) = case e of NothingO -> NothingO
443 JustO _ -> JustO f
444
445 -----------------------------------------------------------------------------
446 -- fixpoint: finding fixed points
447 -----------------------------------------------------------------------------
448
449 data TxFactBase n f
450 = TxFB { tfb_fbase :: FactBase f
451 , tfb_rg :: RG f n C C -- Transformed blocks
452 , tfb_cha :: ChangeFlag
453 , tfb_lbls :: LabelSet }
454 -- Note [TxFactBase change flag]
455 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456 -- Set the tfb_cha flag iff
457 -- (a) the fact in tfb_fbase for or a block L changes
458 -- (b) L is in tfb_lbls.
459 -- The tfb_lbls are all Labels of the *original*
460 -- (not transformed) blocks
461
462 updateFact :: DataflowLattice f -> LabelSet -> (Label, f)
463 -> (ChangeFlag, FactBase f)
464 -> (ChangeFlag, FactBase f)
465 -- See Note [TxFactBase change flag]
466 updateFact lat lbls (lbl, new_fact) (cha, fbase)
467 | NoChange <- cha2 = (cha, fbase)
468 | lbl `elemLabelSet` lbls = (SomeChange, new_fbase)
469 | otherwise = (cha, new_fbase)
470 where
471 (cha2, res_fact) -- Note [Unreachable blocks]
472 = case lookupFact fbase lbl of
473 Nothing -> (SomeChange, snd $ join $ fact_bot lat) -- Note [Unreachable blocks]
474 Just old_fact -> join old_fact
475 where join old_fact = fact_extend lat lbl (OldFact old_fact) (NewFact new_fact)
476 new_fbase = extendFactBase fbase lbl res_fact
477
478 fixpoint :: forall m block n f. (FuelMonad m, Edges n, Edges (block n))
479 => Bool -- Going forwards?
480 -> DataflowLattice f
481 -> (block n C C -> FactBase f -> m (RG f n C C, [(Label, f)]))
482 -> FactBase f
483 -> [block n C C]
484 -> m (RG f n C C, FactBase f)
485 fixpoint is_fwd lat do_block init_fbase untagged_blocks
486 = do { fuel <- getFuel
487 ; tx_fb <- loop fuel init_fbase
488 ; return (tfb_rg tx_fb,
489 tfb_fbase tx_fb `delFromFactBase` map fst blocks) }
490 -- The successors of the Graph are the the Labels for which
491 -- we have facts, that are *not* in the blocks of the graph
492 where
493 blocks = map tag untagged_blocks
494 where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b)
495
496 tx_blocks :: [((Label, block n C C), [Label])] -- I do not understand this type
497 -> TxFactBase n f -> m (TxFactBase n f)
498 tx_blocks [] tx_fb = return tx_fb
499 tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs
500 -- "deps" == Labels the block may _depend_ upon for facts
501
502 tx_block :: Label -> block n C C -> [Label]
503 -> TxFactBase n f -> m (TxFactBase n f)
504 tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
505 , tfb_rg = blks, tfb_cha = cha })
506 | is_fwd && not (lbl `elemFactBase` fbase)
507 = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps} -- Note [Unreachable blocks]
508 | otherwise
509 = do { (rg, out_facts) <- do_block blk fbase
510 ; let (cha',fbase')
511 = foldr (updateFact lat lbls) (cha,fbase) out_facts
512 lbls' = lbls `unionLabelSet` mkLabelSet deps
513 ; return (TxFB { tfb_lbls = lbls'
514 , tfb_rg = rg `rgCat` blks
515 , tfb_fbase = fbase', tfb_cha = cha' }) }
516
517 loop :: Fuel -> FactBase f -> m (TxFactBase n f)
518 loop fuel fbase
519 = do { let init_tx_fb = TxFB { tfb_fbase = fbase
520 , tfb_cha = NoChange
521 , tfb_rg = rgnilC
522 , tfb_lbls = emptyLabelSet }
523 ; tx_fb <- tx_blocks blocks init_tx_fb
524 ; case tfb_cha tx_fb of
525 NoChange -> return tx_fb
526 SomeChange -> do { setFuel fuel
527 ; loop fuel (tfb_fbase tx_fb) } }
528
529 {- Note [Unreachable blocks]
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
531 A block that is not in the domain of tfb_fbase is "currently unreachable".
532 A currently-unreachable block is not even analyzed. Reason: consider
533 constant prop and this graph, with entry point L1:
534 L1: x:=3; goto L4
535 L2: x:=4; goto L4
536 L4: if x>3 goto L2 else goto L5
537 Here L2 is actually unreachable, but if we process it with bottom input fact,
538 we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
539
540 * If a currently-unreachable block is not analyzed, then its rewritten
541 graph will not be accumulated in tfb_rg. And that is good:
542 unreachable blocks simply do not appear in the output.
543
544 * Note that clients must be careful to provide a fact (even if bottom)
545 for each entry point. Otherwise useful blocks may be garbage collected.
546
547 * Note that updateFact must set the change-flag if a label goes from
548 not-in-fbase to in-fbase, even if its fact is bottom. In effect the
549 real fact lattice is
550 UNR
551 bottom
552 the points above bottom
553
554 * Even if the fact is going from UNR to bottom, we still call the
555 client's fact_extend function because it might give the client
556 some useful debugging information.
557
558 * All of this only applies for *forward* fixpoints. For the backward
559 case we must treat every block as reachable; it might finish with a
560 'return', and therefore have no successors, for example.
561 -}
562
563 -----------------------------------------------------------------------------
564 -- RG: an internal data type for graphs under construction
565 -- TOTALLY internal to Hoopl; each block carries its fact
566 -----------------------------------------------------------------------------
567
568 type RG f n e x = Graph' (FBlock f) n e x
569 data FBlock f n e x = FBlock f (Block n e x)
570 instance Edges n => Edges (FBlock f n) where
571 entryLabel (FBlock _ b) = entryLabel b
572 successors (FBlock _ b) = successors b
573
574 --- constructors
575
576 rgnil :: RG f n O O
577 rgnilC :: RG f n C C
578 rgunit :: Edges n => f -> Block n e x -> RG f n e x
579 rgCat :: Edges n => RG f n e a -> RG f n a x -> RG f n e x
580
581 ---- observers
582
583 type GraphWithFacts n f e x = (Graph n e x, FactBase f)
584 -- A Graph together with the facts for that graph
585 -- The domains of the two maps should be identical
586
587 normalizeGraph :: forall n f e x .
588 Edges n => RG f n e x -> GraphWithFacts n f e x
589
590 normalizeGraph g = (graphMapBlocks dropFact g, facts g)
591 where dropFact (FBlock _ b) = b
592 facts :: RG f n e x -> FactBase f
593 facts GNil = noFacts
594 facts (GUnit _) = noFacts
595 facts (GMany _ body exit) = bodyFacts body `unionFactBase` exitFacts exit
596 exitFacts :: MaybeO x (FBlock f n C O) -> FactBase f
597 exitFacts NothingO = noFacts
598 exitFacts (JustO (FBlock f b)) = mkFactBase [(entryLabel b, f)]
599 bodyFacts :: Body' (FBlock f) n -> FactBase f
600 bodyFacts (Body body) = foldLabelMap f noFacts body
601 where f (FBlock f b) fb = extendFactBase fb (entryLabel b) f
602
603 --- implementation of the constructors (boring)
604
605 rgnil = GNil
606 rgnilC = GMany NothingO emptyBody NothingO
607
608 rgunit f b@(BFirst {}) = gUnitCO (FBlock f b)
609 rgunit f b@(BMiddle {}) = gUnitOO (FBlock f b)
610 rgunit f b@(BLast {}) = gUnitOC (FBlock f b)
611 rgunit f b@(BCat {}) = gUnitOO (FBlock f b)
612 rgunit f b@(BHead {}) = gUnitCO (FBlock f b)
613 rgunit f b@(BTail {}) = gUnitOC (FBlock f b)
614 rgunit f b@(BClosed {}) = gUnitCC (FBlock f b)
615
616 rgCat = U.splice fzCat
617 where fzCat (FBlock f b1) (FBlock _ b2) = FBlock f (b1 `U.cat` b2)
618
619 ----------------------------------------------------------------
620 -- Utilities
621 ----------------------------------------------------------------
622
623 -- Lifting based on shape:
624 -- - from nodes to blocks
625 -- - from facts to fact-like things
626 -- Lowering back:
627 -- - from fact-like things to facts
628 -- Note that the latter two functions depend only on the entry shape.
629 class ShapeLifter e x where
630 unit :: n e x -> Block n e x
631 elift :: Edges n => n e x -> f -> Fact e f
632 elower :: Edges n => DataflowLattice f -> n e x -> Fact e f -> f
633 ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f
634 btransfer :: BwdPass m n f -> n e x -> Fact x f -> f
635 frewrite :: FwdPass m n f -> n e x -> f -> Maybe (FwdRes m n f e x)
636 brewrite :: BwdPass m n f -> n e x -> Fact x f -> Maybe (BwdRes m n f e x)
637 entry :: Edges n => n e x -> Entries e
638
639 instance ShapeLifter C O where
640 unit = BFirst
641 elift n f = mkFactBase [(entryLabel n, f)]
642 elower lat n fb = getFact lat (entryLabel n) fb
643 ftransfer (FwdPass {fp_transfer = FwdTransfers (ft, _, _)}) n f = ft n f
644 btransfer (BwdPass {bp_transfer = BwdTransfers (bt, _, _)}) n f = bt n f
645 frewrite (FwdPass {fp_rewrite = FwdRewrites (fr, _, _)}) n f = fr n f
646 brewrite (BwdPass {bp_rewrite = BwdRewrites (br, _, _)}) n f = br n f
647 entry n = JustC [entryLabel n]
648
649 instance ShapeLifter O O where
650 unit = BMiddle
651 elift _ f = f
652 elower _ _ f = f
653 ftransfer (FwdPass {fp_transfer = FwdTransfers (_, ft, _)}) n f = ft n f
654 btransfer (BwdPass {bp_transfer = BwdTransfers (_, bt, _)}) n f = bt n f
655 frewrite (FwdPass {fp_rewrite = FwdRewrites (_, fr, _)}) n f = fr n f
656 brewrite (BwdPass {bp_rewrite = BwdRewrites (_, br, _)}) n f = br n f
657 entry _ = NothingC
658
659 instance ShapeLifter O C where
660 unit = BLast
661 elift _ f = f
662 elower _ _ f = f
663 ftransfer (FwdPass {fp_transfer = FwdTransfers (_, _, ft)}) n f = ft n f
664 btransfer (BwdPass {bp_transfer = BwdTransfers (_, _, bt)}) n f = bt n f
665 frewrite (FwdPass {fp_rewrite = FwdRewrites (_, _, fr)}) n f = fr n f
666 brewrite (BwdPass {bp_rewrite = BwdRewrites (_, _, br)}) n f = br n f
667 entry _ = NothingC
668
669 -- Fact lookup: the fact `orelse` bottom
670 lookupF :: FwdPass m n f -> Label -> FactBase f -> f
671 lookupF = getFact . fp_lattice
672
673 getFact :: DataflowLattice f -> Label -> FactBase f -> f
674 getFact lat l fb = case lookupFact fb l of Just f -> f
675 Nothing -> fact_bot lat