Use an ordered list for the work list, which is a bit quicker than IntSet
[ghc.git] / compiler / cmm / Hoopl / Dataflow.hs
1 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}
2 #if __GLASGOW_HASKELL__ >= 703
3 {-# OPTIONS_GHC -fprof-auto-top #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 701
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8
9 module Hoopl.Dataflow
10 ( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase
11 , ChangeFlag(..)
12 , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
13 -- * Respecting Fuel
14
15 -- $fuel
16 , FwdRewrite, mkFRewrite, mkFRewrite3, getFRewrite3, noFwdRewrite
17 , wrapFR, wrapFR2
18 , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
19 , wrapBR, wrapBR2
20 , BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite
21 , analyzeAndRewriteFwd, analyzeAndRewriteBwd
22 , analyzeFwd, analyzeFwdBlocks, analyzeBwd
23 )
24 where
25
26 import OptimizationFuel
27
28 import Data.Maybe
29 import Data.Array
30
31 import Compiler.Hoopl.Collections
32 import Compiler.Hoopl.Fuel
33 import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine
34 -- and include definition in paper
35 import qualified Compiler.Hoopl.GraphUtil as U
36 import Compiler.Hoopl.Label
37 import Compiler.Hoopl.Dataflow (JoinFun)
38 import Compiler.Hoopl.Util
39
40 import Compiler.Hoopl.Dataflow (
41 DataflowLattice(..), OldFact(..), NewFact(..), Fact
42 , ChangeFlag(..), mkFactBase
43 , FwdPass(..), FwdRewrite(..), FwdTransfer(..), mkFRewrite, getFRewrite3, mkFTransfer, mkFTransfer3
44 , wrapFR, wrapFR2
45 , BwdPass(..), BwdRewrite(..), BwdTransfer(..), mkBTransfer, mkBTransfer3, getBTransfer3
46 , wrapBR, wrapBR2
47 , mkBRewrite, getBRewrite3
48 )
49
50 -- import Debug.Trace
51
52 noRewrite :: a -> b -> FuelUniqSM (Maybe c)
53 noRewrite _ _ = return Nothing
54
55 noFwdRewrite :: FwdRewrite FuelUniqSM n f
56 noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite)
57
58 -- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply.
59 -- The result returned by 'mkFRewrite3' respects fuel.
60 mkFRewrite3 :: forall n f.
61 (n C O -> f -> FuelUniqSM (Maybe (Graph n C O)))
62 -> (n O O -> f -> FuelUniqSM (Maybe (Graph n O O)))
63 -> (n O C -> f -> FuelUniqSM (Maybe (Graph n O C)))
64 -> FwdRewrite FuelUniqSM n f
65 mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l)
66 where lift :: forall t t1 a. (t -> t1 -> FuelUniqSM (Maybe a))
67 -> t -> t1 -> FuelUniqSM (Maybe (a, FwdRewrite FuelUniqSM n f))
68 {-# INLINE lift #-}
69 lift rw node fact = do
70 a <- rw node fact
71 case a of
72 Nothing -> return Nothing
73 Just a -> do f <- getFuel
74 if f == 0
75 then return Nothing
76 else setFuel (f-1) >> return (Just (a,noFwdRewrite))
77
78 noBwdRewrite :: BwdRewrite FuelUniqSM n f
79 noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite)
80
81 mkBRewrite3 :: forall n f.
82 (n C O -> f -> FuelUniqSM (Maybe (Graph n C O)))
83 -> (n O O -> f -> FuelUniqSM (Maybe (Graph n O O)))
84 -> (n O C -> FactBase f -> FuelUniqSM (Maybe (Graph n O C)))
85 -> BwdRewrite FuelUniqSM n f
86 mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l)
87 where lift :: forall t t1 a. (t -> t1 -> FuelUniqSM (Maybe a))
88 -> t -> t1 -> FuelUniqSM (Maybe (a, BwdRewrite FuelUniqSM n f))
89 {-# INLINE lift #-}
90 lift rw node fact = do
91 a <- rw node fact
92 case a of
93 Nothing -> return Nothing
94 Just a -> do f <- getFuel
95 if f == 0
96 then return Nothing
97 else setFuel (f-1) >> return (Just (a,noBwdRewrite))
98
99 -----------------------------------------------------------------------------
100 -- Analyze and rewrite forward: the interface
101 -----------------------------------------------------------------------------
102
103 -- | if the graph being analyzed is open at the entry, there must
104 -- be no other entry point, or all goes horribly wrong...
105 analyzeAndRewriteFwd
106 :: forall n f e x . NonLocal n =>
107 FwdPass FuelUniqSM n f
108 -> MaybeC e [Label]
109 -> Graph n e x -> Fact e f
110 -> FuelUniqSM (Graph n e x, FactBase f, MaybeO x f)
111 analyzeAndRewriteFwd pass entries g f =
112 do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f
113 let (g', fb) = normalizeGraph rg
114 return (g', fb, distinguishedExitFact g' fout)
115
116 distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f
117 distinguishedExitFact g f = maybe g
118 where maybe :: Graph n e x -> MaybeO x f
119 maybe GNil = JustO f
120 maybe (GUnit {}) = JustO f
121 maybe (GMany _ _ x) = case x of NothingO -> NothingO
122 JustO _ -> JustO f
123
124 ----------------------------------------------------------------
125 -- Forward Implementation
126 ----------------------------------------------------------------
127
128 type Entries e = MaybeC e [Label]
129
130 arfGraph :: forall n f e x . NonLocal n =>
131 FwdPass FuelUniqSM n f ->
132 Entries e -> Graph n e x -> Fact e f -> FuelUniqSM (DG f n e x, Fact x f)
133 arfGraph pass@FwdPass { fp_lattice = lattice,
134 fp_transfer = transfer,
135 fp_rewrite = rewrite } entries g in_fact = graph g in_fact
136 where
137 {- nested type synonyms would be so lovely here
138 type ARF thing = forall e x . thing e x -> f -> m (DG f n e x, Fact x f)
139 type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f)
140 -}
141 graph :: Graph n e x -> Fact e f -> FuelUniqSM (DG f n e x, Fact x f)
142 block :: forall e x .
143 Block n e x -> f -> FuelUniqSM (DG f n e x, Fact x f)
144
145 body :: [Label] -> LabelMap (Block n C C)
146 -> Fact C f -> FuelUniqSM (DG f n C C, Fact C f)
147 -- Outgoing factbase is restricted to Labels *not* in
148 -- in the Body; the facts for Labels *in*
149 -- the Body are in the 'DG f n C C'
150
151 cat :: forall e a x f1 f2 f3.
152 (f1 -> FuelUniqSM (DG f n e a, f2))
153 -> (f2 -> FuelUniqSM (DG f n a x, f3))
154 -> (f1 -> FuelUniqSM (DG f n e x, f3))
155
156 graph GNil f = return (dgnil, f)
157 graph (GUnit blk) f = block blk f
158 graph (GMany e bdy x) f = ((e `ebcat` bdy) `cat` exit x) f
159 where
160 ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> FuelUniqSM (DG f n e C, Fact C f)
161 exit :: MaybeO x (Block n C O) -> Fact C f -> FuelUniqSM (DG f n C x, Fact x f)
162 exit (JustO blk) f = arfx block blk f
163 exit NothingO f = return (dgnilC, f)
164 ebcat entry bdy f = c entries entry f
165 where c :: MaybeC e [Label] -> MaybeO e (Block n O C)
166 -> Fact e f -> FuelUniqSM (DG f n e C, Fact C f)
167 c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f
168 c (JustC entries) NothingO f = body entries bdy f
169 c _ _ _ = error "bogus GADT pattern match failure"
170
171 -- Lift from nodes to blocks
172 block BNil f = return (dgnil, f)
173 block (BlockCO n b) f = (node n `cat` block b) f
174 block (BlockCC l b n) f = (node l `cat` block b `cat` node n) f
175 block (BlockOC b n) f = (block b `cat` node n) f
176
177 block (BMiddle n) f = node n f
178 block (BCat b1 b2) f = (block b1 `cat` block b2) f
179 block (BHead h n) f = (block h `cat` node n) f
180 block (BTail n t) f = (node n `cat` block t) f
181
182 {-# INLINE node #-}
183 node :: forall e x . (ShapeLifter e x)
184 => n e x -> f -> FuelUniqSM (DG f n e x, Fact x f)
185 node n f
186 = do { grw <- frewrite rewrite n f
187 ; case grw of
188 Nothing -> return ( singletonDG f n
189 , ftransfer transfer n f )
190 Just (g, rw) ->
191 let pass' = pass { fp_rewrite = rw }
192 f' = fwdEntryFact n f
193 in arfGraph pass' (fwdEntryLabel n) g f' }
194
195 -- | Compose fact transformers and concatenate the resulting
196 -- rewritten graphs.
197 {-# INLINE cat #-}
198 cat ft1 ft2 f = do { (g1,f1) <- ft1 f
199 ; (g2,f2) <- ft2 f1
200 ; let !g = g1 `dgSplice` g2
201 ; return (g, f2) }
202
203 arfx :: forall x .
204 (Block n C x -> f -> FuelUniqSM (DG f n C x, Fact x f))
205 -> (Block n C x -> Fact C f -> FuelUniqSM (DG f n C x, Fact x f))
206 arfx arf thing fb =
207 arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb
208 -- joinInFacts adds debugging information
209
210
211 -- Outgoing factbase is restricted to Labels *not* in
212 -- in the Body; the facts for Labels *in*
213 -- the Body are in the 'DG f n C C'
214 body entries blockmap init_fbase
215 = fixpoint Fwd lattice do_block entries blockmap init_fbase
216 where
217 lattice = fp_lattice pass
218 do_block :: forall x . Block n C x -> FactBase f
219 -> FuelUniqSM (DG f n C x, Fact x f)
220 do_block b fb = block b entryFact
221 where entryFact = getFact lattice (entryLabel b) fb
222
223
224 -- Join all the incoming facts with bottom.
225 -- We know the results _shouldn't change_, but the transfer
226 -- functions might, for example, generate some debugging traces.
227 joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f
228 joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb =
229 mkFactBase lattice $ map botJoin $ mapToList fb
230 where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f))
231
232 forwardBlockList :: (NonLocal n)
233 => [Label] -> Body n -> [Block n C C]
234 -- This produces a list of blocks in order suitable for forward analysis,
235 -- along with the list of Labels it may depend on for facts.
236 forwardBlockList entries blks = postorder_dfs_from blks entries
237
238 ----------------------------------------------------------------
239 -- Forward Analysis only
240 ----------------------------------------------------------------
241
242 -- | if the graph being analyzed is open at the entry, there must
243 -- be no other entry point, or all goes horribly wrong...
244 analyzeFwd
245 :: forall n f e . NonLocal n =>
246 FwdPass FuelUniqSM n f
247 -> MaybeC e [Label]
248 -> Graph n e C -> Fact e f
249 -> FactBase f
250 analyzeFwd FwdPass { fp_lattice = lattice,
251 fp_transfer = FwdTransfer3 (ftr, mtr, ltr) }
252 entries g in_fact = graph g in_fact
253 where
254 graph :: Graph n e C -> Fact e f -> FactBase f
255 graph (GMany entry blockmap NothingO)
256 = case (entries, entry) of
257 (NothingC, JustO entry) -> block entry `cat` body (successors entry)
258 (JustC entries, NothingO) -> body entries
259 _ -> error "bogus GADT pattern match failure"
260 where
261 body :: [Label] -> Fact C f -> Fact C f
262 body entries f
263 = fixpoint_anal Fwd lattice do_block entries blockmap f
264 where
265 do_block :: forall x . Block n C x -> FactBase f -> Fact x f
266 do_block b fb = block b entryFact
267 where entryFact = getFact lattice (entryLabel b) fb
268
269 -- NB. eta-expand block, GHC can't do this by itself. See #5809.
270 block :: forall e x . Block n e x -> f -> Fact x f
271 block BNil f = f
272 block (BlockCO n b) f = (ftr n `cat` block b) f
273 block (BlockCC l b n) f = (ftr l `cat` (block b `cat` ltr n)) f
274 block (BlockOC b n) f = (block b `cat` ltr n) f
275
276 block (BMiddle n) f = {-# SCC "b1" #-} mtr n f
277 block (BCat b1 b2) f = {-# SCC "b2" #-} (block b1 `cat` block b2) f
278 block (BHead h n) f = {-# SCC "b3" #-} (block h `cat` mtr n) f
279 block (BTail n t) f = {-# SCC "b4" #-} (mtr n `cat` block t) f
280
281 {-# INLINE cat #-}
282 cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
283 cat ft1 ft2 = \f -> ft2 $! ft1 f
284
285 -- | if the graph being analyzed is open at the entry, there must
286 -- be no other entry point, or all goes horribly wrong...
287 analyzeFwdBlocks
288 :: forall n f e . NonLocal n =>
289 FwdPass FuelUniqSM n f
290 -> MaybeC e [Label]
291 -> Graph n e C -> Fact e f
292 -> FactBase f
293 analyzeFwdBlocks FwdPass { fp_lattice = lattice,
294 fp_transfer = FwdTransfer3 (ftr, _, ltr) }
295 entries g in_fact = graph g in_fact
296 where
297 graph :: Graph n e C -> Fact e f -> FactBase f
298 graph (GMany entry blockmap NothingO)
299 = case (entries, entry) of
300 (NothingC, JustO entry) -> block entry `cat` body (successors entry)
301 (JustC entries, NothingO) -> body entries
302 _ -> error "bogus GADT pattern match failure"
303 where
304 body :: [Label] -> Fact C f -> Fact C f
305 body entries f
306 = fixpoint_anal Fwd lattice do_block entries blockmap f
307 where
308 do_block :: forall x . Block n C x -> FactBase f -> Fact x f
309 do_block b fb = block b entryFact
310 where entryFact = getFact lattice (entryLabel b) fb
311
312 -- NB. eta-expand block, GHC can't do this by itself. See #5809.
313 block :: forall e x . Block n e x -> f -> Fact x f
314 block BNil f = f
315 block (BlockCO n _) f = ftr n f
316 block (BlockCC l _ n) f = (ftr l `cat` ltr n) f
317 block (BlockOC _ n) f = ltr n f
318
319 {-# INLINE cat #-}
320 cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
321 cat ft1 ft2 = \f -> ft2 $! ft1 f
322
323 ----------------------------------------------------------------
324 -- Backward Analysis only
325 ----------------------------------------------------------------
326
327 -- | if the graph being analyzed is open at the entry, there must
328 -- be no other entry point, or all goes horribly wrong...
329 analyzeBwd
330 :: forall n f e . NonLocal n =>
331 BwdPass FuelUniqSM n f
332 -> MaybeC e [Label]
333 -> Graph n e C -> Fact C f
334 -> FactBase f
335 analyzeBwd BwdPass { bp_lattice = lattice,
336 bp_transfer = BwdTransfer3 (ftr, mtr, ltr) }
337 entries g in_fact = graph g in_fact
338 where
339 graph :: Graph n e C -> Fact C f -> FactBase f
340 graph (GMany entry blockmap NothingO)
341 = case (entries, entry) of
342 (NothingC, JustO entry) -> body (successors entry)
343 (JustC entries, NothingO) -> body entries
344 _ -> error "bogus GADT pattern match failure"
345 where
346 body :: [Label] -> Fact C f -> Fact C f
347 body entries f
348 = fixpoint_anal Bwd lattice do_block entries blockmap f
349 where
350 do_block :: forall x . Block n C x -> Fact x f -> FactBase f
351 do_block b fb = {-# SCC do_block #-} mapSingleton (entryLabel b) ({-# SCC block #-} block b fb)
352
353 -- NB. eta-expand block, GHC can't do this by itself. See #5809.
354 block :: forall e x . Block n e x -> Fact x f -> f
355 block BNil f = f
356 block (BlockCO n b) f = (ftr n `cat` block b) f
357 block (BlockCC l b n) f = ((ftr l `cat` block b) `cat` ltr n) f
358 block (BlockOC b n) f = (block b `cat` ltr n) f
359
360 block (BMiddle n) f = mtr n f
361 block (BCat b1 b2) f = (block b1 `cat` block b2) f
362 block (BHead h n) f = (block h `cat` mtr n) f
363 block (BTail n t) f = (mtr n `cat` block t) f
364
365 {-# INLINE cat #-}
366 cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
367 cat ft1 ft2 = \f -> ft1 $! ft2 f
368
369 -----------------------------------------------------------------------------
370 -- Backward analysis and rewriting: the interface
371 -----------------------------------------------------------------------------
372
373
374 -- | if the graph being analyzed is open at the exit, I don't
375 -- quite understand the implications of possible other exits
376 analyzeAndRewriteBwd
377 :: NonLocal n
378 => BwdPass FuelUniqSM n f
379 -> MaybeC e [Label] -> Graph n e x -> Fact x f
380 -> FuelUniqSM (Graph n e x, FactBase f, MaybeO e f)
381 analyzeAndRewriteBwd pass entries g f =
382 do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f
383 let (g', fb) = normalizeGraph rg
384 return (g', fb, distinguishedEntryFact g' fout)
385
386 distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f
387 distinguishedEntryFact g f = maybe g
388 where maybe :: Graph n e x -> MaybeO e f
389 maybe GNil = JustO f
390 maybe (GUnit {}) = JustO f
391 maybe (GMany e _ _) = case e of NothingO -> NothingO
392 JustO _ -> JustO f
393
394
395 -----------------------------------------------------------------------------
396 -- Backward implementation
397 -----------------------------------------------------------------------------
398
399 arbGraph :: forall n f e x .
400 NonLocal n =>
401 BwdPass FuelUniqSM n f ->
402 Entries e -> Graph n e x -> Fact x f -> FuelUniqSM (DG f n e x, Fact e f)
403 arbGraph pass@BwdPass { bp_lattice = lattice,
404 bp_transfer = transfer,
405 bp_rewrite = rewrite } entries g in_fact = graph g in_fact
406 where
407 {- nested type synonyms would be so lovely here
408 type ARB thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)
409 type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f)
410 -}
411 graph :: Graph n e x -> Fact x f -> FuelUniqSM (DG f n e x, Fact e f)
412 block :: forall e x . Block n e x -> Fact x f -> FuelUniqSM (DG f n e x, f)
413 body :: [Label] -> Body n -> Fact C f -> FuelUniqSM (DG f n C C, Fact C f)
414 node :: forall e x . (ShapeLifter e x)
415 => n e x -> Fact x f -> FuelUniqSM (DG f n e x, f)
416 cat :: forall e a x info info' info''.
417 (info' -> FuelUniqSM (DG f n e a, info''))
418 -> (info -> FuelUniqSM (DG f n a x, info'))
419 -> (info -> FuelUniqSM (DG f n e x, info''))
420
421 graph GNil f = return (dgnil, f)
422 graph (GUnit blk) f = block blk f
423 graph (GMany e bdy x) f = ((e `ebcat` bdy) `cat` exit x) f
424 where
425 ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> FuelUniqSM (DG f n e C, Fact e f)
426 exit :: MaybeO x (Block n C O) -> Fact x f -> FuelUniqSM (DG f n C x, Fact C f)
427 exit (JustO blk) f = arbx block blk f
428 exit NothingO f = return (dgnilC, f)
429 ebcat entry bdy f = c entries entry f
430 where c :: MaybeC e [Label] -> MaybeO e (Block n O C)
431 -> Fact C f -> FuelUniqSM (DG f n e C, Fact e f)
432 c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f
433 c (JustC entries) NothingO f = body entries bdy f
434 c _ _ _ = error "bogus GADT pattern match failure"
435
436 -- Lift from nodes to blocks
437 block BNil f = return (dgnil, f)
438 block (BlockCO n b) f = (node n `cat` block b) f
439 block (BlockCC l b n) f = (node l `cat` block b `cat` node n) f
440 block (BlockOC b n) f = (block b `cat` node n) f
441
442 block (BMiddle n) f = node n f
443 block (BCat b1 b2) f = (block b1 `cat` block b2) f
444 block (BHead h n) f = (block h `cat` node n) f
445 block (BTail n t) f = (node n `cat` block t) f
446
447 {-# INLINE node #-}
448 node n f
449 = do { bwdres <- brewrite rewrite n f
450 ; case bwdres of
451 Nothing -> return (singletonDG entry_f n, entry_f)
452 where entry_f = btransfer transfer n f
453 Just (g, rw) ->
454 do { let pass' = pass { bp_rewrite = rw }
455 ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f
456 ; return (g, bwdEntryFact lattice n f)} }
457
458 -- | Compose fact transformers and concatenate the resulting
459 -- rewritten graphs.
460 {-# INLINE cat #-}
461 cat ft1 ft2 f = do { (g2,f2) <- ft2 f
462 ; (g1,f1) <- ft1 f2
463 ; let !g = g1 `dgSplice` g2
464 ; return (g, f1) }
465
466 arbx :: forall x .
467 (Block n C x -> Fact x f -> FuelUniqSM (DG f n C x, f))
468 -> (Block n C x -> Fact x f -> FuelUniqSM (DG f n C x, Fact C f))
469
470 arbx arb thing f = do { (rg, f) <- arb thing f
471 ; let fb = joinInFacts (bp_lattice pass) $
472 mapSingleton (entryLabel thing) f
473 ; return (rg, fb) }
474 -- joinInFacts adds debugging information
475
476 -- Outgoing factbase is restricted to Labels *not* in
477 -- in the Body; the facts for Labels *in*
478 -- the Body are in the 'DG f n C C'
479 body entries blockmap init_fbase
480 = fixpoint Bwd (bp_lattice pass) do_block (map entryLabel (backwardBlockList entries blockmap)) blockmap init_fbase
481 where
482 do_block :: forall x. Block n C x -> Fact x f -> FuelUniqSM (DG f n C x, LabelMap f)
483 do_block b f = do (g, f) <- block b f
484 return (g, mapSingleton (entryLabel b) f)
485
486
487 backwardBlockList :: NonLocal n => [Label] -> Body n -> [Block n C C]
488 -- This produces a list of blocks in order suitable for backward analysis,
489 -- along with the list of Labels it may depend on for facts.
490 backwardBlockList entries body = reverse $ forwardBlockList entries body
491
492 {-
493
494 The forward and backward cases are not dual. In the forward case, the
495 entry points are known, and one simply traverses the body blocks from
496 those points. In the backward case, something is known about the exit
497 points, but this information is essentially useless, because we don't
498 actually have a dual graph (that is, one with edges reversed) to
499 compute with. (Even if we did have a dual graph, it would not avail
500 us---a backward analysis must include reachable blocks that don't
501 reach the exit, as in a procedure that loops forever and has side
502 effects.)
503
504 -}
505
506 -----------------------------------------------------------------------------
507 -- fixpoint (analysis only)
508 -----------------------------------------------------------------------------
509
510 -- Note [newblocks]
511 -- For a block whose input is *in* the initial fact base, and is
512 -- reached by another block, but the join gives NoChange, we must
513 -- still process it at least once to get its out facts.
514
515 updateFact_anal :: f -> JoinFun f
516 -> Label -> f -- out fact
517 -> ([Label], FactBase f)
518 -> ([Label], FactBase f)
519 -- See Note [TxFactBase change flag]
520 updateFact_anal bot fact_join lbl new_fact (cha, fbase)
521 = case lookupFact lbl fbase of
522 Nothing -> (lbl:cha, mapInsert lbl new_fact fbase)
523 Just old_fact ->
524 case fact_join lbl (OldFact old_fact) (NewFact new_fact) of
525 (NoChange, _) -> (cha, fbase)
526 (_, f) -> (lbl:cha, mapInsert lbl f fbase)
527
528 {-
529 -- this doesn't work because it can't be implemented
530 class Monad m => FixpointMonad m where
531 observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f)
532 -}
533
534 data Direction = Fwd | Bwd
535 fixpoint_anal :: forall n f. NonLocal n
536 => Direction
537 -> DataflowLattice f
538 -> (Block n C C -> Fact C f -> Fact C f)
539 -> [Label]
540 -> LabelMap (Block n C C)
541 -> Fact C f -> FactBase f
542
543 fixpoint_anal direction DataflowLattice{ fact_bot = bot, fact_join = join }
544 do_block entries blockmap init_fbase
545 = loop start init_fbase
546 where
547 blocks = forwardBlockList entries blockmap
548
549 ordered_blocks = case direction of
550 Fwd -> blocks
551 Bwd -> reverse blocks
552 block_arr = listArray (0,length blocks - 1) ordered_blocks
553
554 start = [0 .. length blocks - 1]
555
556 -- mapping from L -> blocks. If the fact for L changes, re-analyse blocks.
557 dep_blocks :: LabelMap [Int]
558 dep_blocks = mapFromListWith (++)
559 [ (l, [ix])
560 | (b,ix) <- zip ordered_blocks [0..]
561 , l <- case direction of
562 Fwd -> [entryLabel b]
563 Bwd -> successors b
564 ]
565
566 loop
567 :: [Int] -- blocks still to analyse
568 -> FactBase f -- current factbase (increases monotonically)
569 -> FactBase f
570
571 loop [] fbase = fbase
572 loop (ix:todo) fbase =
573 let blk = block_arr ! ix
574 in
575 -- trace ("analysing: " ++ show (entryLabel blk)) $
576 let out_facts = do_block blk fbase
577
578 !(changed, fbase') = mapFoldWithKey
579 (updateFact_anal bot join)
580 ([],fbase) out_facts
581 in
582 -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
583 -- trace ("changed: " ++ show changed) $ return ()
584
585 let to_analyse
586 = concatMap (\l -> mapFindWithDefault [] l dep_blocks) changed
587 in
588
589 -- trace ("to analyse: " ++ show to_analyse) $ return ()
590
591 loop (foldr insertIntHeap todo to_analyse) fbase'
592
593 -----------------------------------------------------------------------------
594 -- fixpoint: finding fixed points
595 -----------------------------------------------------------------------------
596
597 -- See Note [TxFactBase invariants]
598
599 updateFact :: f -> JoinFun f
600 -> Label -> f -- out fact
601 -> ([Label], FactBase f)
602 -> ([Label], FactBase f)
603 -- See Note [TxFactBase change flag]
604 updateFact bot fact_join lbl new_fact (cha, fbase)
605 = case lookupFact lbl fbase of
606 Nothing -> (lbl:cha, mapInsert lbl new_fact fbase)
607 -- Note [no old fact]
608 Just old_fact ->
609 case fact_join lbl (OldFact old_fact) (NewFact new_fact) of
610 (NoChange, _) -> (cha, fbase)
611 (_, f) -> (lbl:cha, mapInsert lbl f fbase)
612
613 {-
614 Note [no old fact]
615
616 We know that the new_fact is >= _|_, so we don't need to join. However,
617 if the new fact is also _|_, and we have already analysed its block,
618 we don't need to record a change. So there's a tradeoff here. It turns
619 out that always recording a change is faster.
620 -}
621
622 {-
623 -- this doesn't work because it can't be implemented
624 class Monad m => FixpointMonad m where
625 observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f)
626 -}
627
628 fixpoint :: forall n f. NonLocal n
629 => Direction
630 -> DataflowLattice f
631 -> (Block n C C -> Fact C f -> FuelUniqSM (DG f n C C, Fact C f))
632 -> [Label]
633 -> LabelMap (Block n C C)
634 -> (Fact C f -> FuelUniqSM (DG f n C C, Fact C f))
635
636 fixpoint direction DataflowLattice{ fact_bot = bot, fact_join = join }
637 do_block entries blockmap init_fbase
638 = do
639 -- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return()
640 (fbase, newblocks) <- loop start init_fbase mapEmpty
641 -- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return()
642 return (GMany NothingO newblocks NothingO,
643 mapDeleteList (mapKeys blockmap) fbase)
644 -- The successors of the Graph are the the Labels
645 -- for which we have facts and which are *not* in
646 -- the blocks of the graph
647 where
648 blocks = forwardBlockList entries blockmap
649 ordered_blocks = case direction of
650 Fwd -> blocks
651 Bwd -> reverse blocks
652 block_arr = listArray (0,length blocks - 1) ordered_blocks
653
654 start = [0 .. length blocks - 1]
655
656 -- mapping from L -> blocks. If the fact for L changes, re-analyse blocks.
657 dep_blocks :: LabelMap [Int]
658 dep_blocks = mapFromListWith (++)
659 [ (l, [ix])
660 | (b,ix) <- zip ordered_blocks [0..]
661 , l <- case direction of
662 Fwd -> [entryLabel b]
663 Bwd -> successors b
664 ]
665
666 loop
667 :: IntHeap
668 -> FactBase f -- current factbase (increases monotonically)
669 -> LabelMap (DBlock f n C C) -- transformed graph
670 -> FuelUniqSM (FactBase f, LabelMap (DBlock f n C C))
671
672 loop [] fbase newblocks = return (fbase, newblocks)
673 loop (ix:todo) fbase !newblocks = do
674 let blk = block_arr ! ix
675
676 -- trace ("analysing: " ++ show (entryLabel blk)) $ return ()
677 (rg, out_facts) <- do_block blk fbase
678 let (changed, fbase') = mapFoldWithKey
679 (updateFact bot join)
680 ([],fbase) out_facts
681 -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
682 -- trace ("changed: " ++ show changed) $ return ()
683
684 let to_analyse
685 = concatMap (\l -> mapFindWithDefault [] l dep_blocks) changed
686
687 -- trace ("to analyse: " ++ show to_analyse) $ return ()
688
689 let newblocks' = case rg of
690 GMany _ blks _ -> mapUnion blks newblocks
691
692 loop (foldr insertIntHeap todo to_analyse) fbase' newblocks'
693
694
695 {- Note [TxFactBase invariants]
696 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
697 The TxFactBase is used only during a fixpoint iteration (or "sweep"),
698 and accumulates facts (and the transformed code) during the fixpoint
699 iteration.
700
701 * tfb_fbase increases monotonically, across all sweeps
702
703 * At the beginning of each sweep
704 tfb_cha = NoChange
705 tfb_lbls = {}
706
707 * During each sweep we process each block in turn. Processing a block
708 is done thus:
709 1. Read from tfb_fbase the facts for its entry label (forward)
710 or successors labels (backward)
711 2. Transform those facts into new facts for its successors (forward)
712 or entry label (backward)
713 3. Augment tfb_fbase with that info
714 We call the labels read in step (1) the "in-labels" of the sweep
715
716 * The field tfb_lbls is the set of in-labels of all blocks that have
717 been processed so far this sweep, including the block that is
718 currently being processed. tfb_lbls is initialised to {}. It is a
719 subset of the Labels of the *original* (not transformed) blocks.
720
721 * The tfb_cha field is set to SomeChange iff we decide we need to
722 perform another iteration of the fixpoint loop. It is initialsed to NoChange.
723
724 Specifically, we set tfb_cha to SomeChange in step (3) iff
725 (a) The fact in tfb_fbase for a block L changes
726 (b) L is in tfb_lbls
727 Reason: until a label enters the in-labels its accumuated fact in tfb_fbase
728 has not been read, hence cannot affect the outcome
729
730 Note [Unreachable blocks]
731 ~~~~~~~~~~~~~~~~~~~~~~~~~
732 A block that is not in the domain of tfb_fbase is "currently unreachable".
733 A currently-unreachable block is not even analyzed. Reason: consider
734 constant prop and this graph, with entry point L1:
735 L1: x:=3; goto L4
736 L2: x:=4; goto L4
737 L4: if x>3 goto L2 else goto L5
738 Here L2 is actually unreachable, but if we process it with bottom input fact,
739 we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
740
741 * If a currently-unreachable block is not analyzed, then its rewritten
742 graph will not be accumulated in tfb_rg. And that is good:
743 unreachable blocks simply do not appear in the output.
744
745 * Note that clients must be careful to provide a fact (even if bottom)
746 for each entry point. Otherwise useful blocks may be garbage collected.
747
748 * Note that updateFact must set the change-flag if a label goes from
749 not-in-fbase to in-fbase, even if its fact is bottom. In effect the
750 real fact lattice is
751 UNR
752 bottom
753 the points above bottom
754
755 * Even if the fact is going from UNR to bottom, we still call the
756 client's fact_join function because it might give the client
757 some useful debugging information.
758
759 * All of this only applies for *forward* ixpoints. For the backward
760 case we must treat every block as reachable; it might finish with a
761 'return', and therefore have no successors, for example.
762 -}
763
764 -----------------------------------------------------------------------------
765 -- DG: an internal data type for 'decorated graphs'
766 -- TOTALLY internal to Hoopl; each block is decorated with a fact
767 -----------------------------------------------------------------------------
768
769 type Graph = Graph' Block
770 type DG f = Graph' (DBlock f)
771 data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact
772
773 instance NonLocal n => NonLocal (DBlock f n) where
774 entryLabel (DBlock _ b) = entryLabel b
775 successors (DBlock _ b) = successors b
776
777 --- constructors
778
779 dgnil :: DG f n O O
780 dgnilC :: DG f n C C
781 dgSplice :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x
782
783 ---- observers
784
785 normalizeGraph :: forall n f e x .
786 NonLocal n => DG f n e x
787 -> (Graph n e x, FactBase f)
788 -- A Graph together with the facts for that graph
789 -- The domains of the two maps should be identical
790
791 normalizeGraph g = (graphMapBlocks dropFact g, facts g)
792 where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3
793 dropFact (DBlock _ b) = b
794 facts :: DG f n e x -> FactBase f
795 facts GNil = noFacts
796 facts (GUnit _) = noFacts
797 facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit
798 exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f
799 exitFacts NothingO = noFacts
800 exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f
801 bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f
802 bodyFacts body = mapFoldWithKey f noFacts body
803 where f :: forall t a x. (NonLocal t) => Label -> DBlock a t C x -> LabelMap a -> LabelMap a
804 f lbl (DBlock f _) fb = mapInsert lbl f fb
805
806 --- implementation of the constructors (boring)
807
808 dgnil = GNil
809 dgnilC = GMany NothingO emptyBody NothingO
810
811 dgSplice = U.splice fzCat
812 where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x
813 fzCat (DBlock f b1) (DBlock _ b2) = DBlock f $! b1 `U.cat` b2
814 -- NB. strictness, this function is hammered.
815
816 ----------------------------------------------------------------
817 -- Utilities
818 ----------------------------------------------------------------
819
820 -- Lifting based on shape:
821 -- - from nodes to blocks
822 -- - from facts to fact-like things
823 -- Lowering back:
824 -- - from fact-like things to facts
825 -- Note that the latter two functions depend only on the entry shape.
826 class ShapeLifter e x where
827 singletonDG :: f -> n e x -> DG f n e x
828 fwdEntryFact :: NonLocal n => n e x -> f -> Fact e f
829 fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]
830 ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f
831 frewrite :: FwdRewrite m n f -> n e x
832 -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))
833 -- @ end node.tex
834 bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f
835 btransfer :: BwdTransfer n f -> n e x -> Fact x f -> f
836 brewrite :: BwdRewrite m n f -> n e x
837 -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))
838
839 instance ShapeLifter C O where
840 singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))
841 fwdEntryFact n f = mapSingleton (entryLabel n) f
842 bwdEntryFact lat n fb = getFact lat (entryLabel n) fb
843 ftransfer (FwdTransfer3 (ft, _, _)) n f = ft n f
844 btransfer (BwdTransfer3 (bt, _, _)) n f = bt n f
845 frewrite (FwdRewrite3 (fr, _, _)) n f = fr n f
846 brewrite (BwdRewrite3 (br, _, _)) n f = br n f
847 fwdEntryLabel n = JustC [entryLabel n]
848
849 instance ShapeLifter O O where
850 singletonDG f = gUnitOO . DBlock f . BMiddle
851 fwdEntryFact _ f = f
852 bwdEntryFact _ _ f = f
853 ftransfer (FwdTransfer3 (_, ft, _)) n f = ft n f
854 btransfer (BwdTransfer3 (_, bt, _)) n f = bt n f
855 frewrite (FwdRewrite3 (_, fr, _)) n f = fr n f
856 brewrite (BwdRewrite3 (_, br, _)) n f = br n f
857 fwdEntryLabel _ = NothingC
858
859 instance ShapeLifter O C where
860 singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))
861 fwdEntryFact _ f = f
862 bwdEntryFact _ _ f = f
863 ftransfer (FwdTransfer3 (_, _, ft)) n f = ft n f
864 btransfer (BwdTransfer3 (_, _, bt)) n f = bt n f
865 frewrite (FwdRewrite3 (_, _, fr)) n f = fr n f
866 brewrite (BwdRewrite3 (_, _, br)) n f = br n f
867 fwdEntryLabel _ = NothingC
868
869 {-
870 class ShapeLifter e x where
871 singletonDG :: f -> n e x -> DG f n e x
872
873 instance ShapeLifter C O where
874 singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))
875
876 instance ShapeLifter O O where
877 singletonDG f = gUnitOO . DBlock f . BMiddle
878
879 instance ShapeLifter O C where
880 singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))
881 -}
882
883 -- Fact lookup: the fact `orelse` bottom
884 getFact :: DataflowLattice f -> Label -> FactBase f -> f
885 getFact lat l fb = case lookupFact l fb of Just f -> f
886 Nothing -> fact_bot lat
887
888
889
890 {- Note [Respects fuel]
891 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
892 -}
893 -- $fuel
894 -- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if
895 -- any function contained within the value satisfies the following properties:
896 --
897 -- * When fuel is exhausted, it always returns 'Nothing'.
898 --
899 -- * When it returns @Just g rw@, it consumes /exactly/ one unit
900 -- of fuel, and new rewrite 'rw' also respects fuel.
901 --
902 -- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3',
903 -- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply,
904 -- the results respect fuel.
905 --
906 -- It is an /unchecked/ run-time error for the argument passed to 'wrapFR',
907 -- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel.
908
909 -- -----------------------------------------------------------------------------
910 -- a Heap of Int
911
912 -- We should really use a proper Heap here, but my attempts to make
913 -- one have not succeeded in beating the simple ordered list. Another
914 -- alternative is IntSet (using deleteFindMin), but that was also
915 -- slower than the ordered list in my experiments --SDM 25/1/2012
916
917 type IntHeap = [Int] -- ordered
918
919 insertIntHeap :: Int -> [Int] -> [Int]
920 insertIntHeap x [] = [x]
921 insertIntHeap x (y:ys)
922 | x < y = x : y : ys
923 | x == y = x : ys
924 | otherwise = y : insertIntHeap x ys