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