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