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