ZipDataflow.hs 45.8 KB
Newer Older
1
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
2
{-# OPTIONS -fglasgow-exts #-}
3 4 5
-- -fglagow-exts for kind signatures

module ZipDataflow
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
6 7
    ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
    , zdfSolveFrom, zdfRewriteFrom
8
    , zdfSolveFromL
9 10 11 12 13 14 15 16 17
    , ForwardTransfers(..), BackwardTransfers(..)
    , ForwardRewrites(..),  BackwardRewrites(..) 
    , ForwardFixedPoint, BackwardFixedPoint
    , zdfFpFacts
    , zdfFpOutputFact
    , zdfGraphChanged
    , zdfDecoratedGraph -- not yet implemented
    , zdfFpContents
    , zdfFpLastOuts
18
    , zdfBRewriteFromL, zdfFRewriteFromL 
19 20 21
    )
where

22
import BlockId
23 24
import CmmTx
import DFMonad
25
import OptimizationFuel as F
26 27 28 29 30 31 32 33 34 35 36
import MkZipCfg
import ZipCfg
import qualified ZipCfg as G

import Maybes
import Outputable
import Panic

import Control.Monad
import Maybe

37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
{- 

This module implements two useful tools:

  1. An iterative solver for dataflow problems

  2. The combined dataflow-analysis-and-transformation framework
     described by Lerner, Grove, and Chambers in their excellent
     2002 POPL paper (http://tinyurl.com/3zycbr or 
     http://tinyurl.com/3pnscd).

Each tool comes in two flavors: one for forward dataflow problems
and one for backward dataflow problems.

We quote the paper above:

  Dataflow analyses can have mutually beneficial interactions.
  Previous efforts to exploit these interactions have either
  (1) iteratively performed each individual analysis until no
  further improvements are discovered or (2) developed "super-
  analyses" that manually combine conceptually separate anal-
  yses. We have devised a new approach that allows anal-
  yses to be defined independently while still enabling them
  to be combined automatically and profitably. Our approach
  avoids the loss of precision associated with iterating indi-
  vidual analyses and the implementation difficulties of man-
  ually writing a super-analysis.    

The key idea is to provide at each CFG node not only a dataflow
transfer function but also a rewriting function that has the option to
replace the node with a new (possibly empty) graph.  The rewriting
function takes a dataflow fact as input, and the fact is used to
justify any rewriting.  For example, in a backward problem, the fact
that variable x is dead can be used to justify rewriting node
  x := e
to the empty graph.  In a forward problem, the fact that x == 7 can
be used to justify rewriting node
  y := x + 1
to 
  y := 8
which in turn will be analyzed and produce a new fact:
x == 7 and y == 8.

In its most general form, this module takes as input graph, transfer
equations, rewrites, and an initial set of dataflow facts, and
iteratively computes a new graph and a new set of dataflow facts such
that
  * The set of facts is a fixed point of the transfer equations
  * The graph has been rewritten as much as is consistent with
    the given facts and requested rewriting depth (see below)
N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'.

The types of transfer equations, rewrites, and fixed points are
different for forward and backward problems.  To avoid cluttering the
name space with two versions of every names, other names such as
zdfSolveFrom are overloaded to work in both forward or backward
directions.  This design decision is based on experience with the
predecessor module, now called ZipDataflow0 and destined for the bit bucket.


This module is deliberately very abstract.  It is a completely general
framework and well-nigh impossible to understand in isolation.  The
cautious reader will begin with some concrete examples in the form of
clients.  NR recommends

  CmmLiveZ             A simple liveness analysis

  CmmSpillReload.removeDeadAssignmentsAndReloads
                       A piece of spaghetti to pull on, which leads to
                         - a two-part liveness analysis that tracks
                           variables live in registers and live on the stack
                         - elimination of assignments to dead variables
                         - elimination of redundant reloads

Even hearty souls should avoid the CmmProcPointZ client, at least for
the time being.

-}   


{- ============ TRANSFER FUNCTIONS AND REWRITES =========== -}

-- | For a backward transfer, you're given the fact on a node's 
-- outedge and you compute the fact on the inedge.  Facts have type 'a'.
-- A last node may have multiple outedges, each pointing to a labelled
-- block, so instead of a fact it is given a mapping from BlockId to fact.
123

124 125 126 127 128
data BackwardTransfers middle last a = BackwardTransfers
    { bt_first_in  :: a              -> BlockId -> a
    , bt_middle_in :: a              -> middle  -> a
    , bt_last_in   :: (BlockId -> a) -> last    -> a
    } 
129

130 131 132 133
-- | For a forward transfer, you're given the fact on a node's 
-- inedge and you compute the fact on the outedge. Because a last node
-- may have multiple outedges, each pointing to a labelled
-- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
134 135 136 137 138 139 140 141 142 143 144 145 146

data ForwardTransfers middle last a = ForwardTransfers
    { ft_first_out  :: a -> BlockId -> a
    , ft_middle_out :: a -> middle  -> a
    , ft_last_outs  :: a -> last    -> LastOutFacts a
    , ft_exit_out   :: a            -> a
    } 

newtype LastOutFacts a = LastOutFacts [(BlockId, a)] 
  -- ^ These are facts flowing out of a last node to the node's successors.
  -- They are either to be set (if they pertain to the graph currently
  -- under analysis) or propagated out of a sub-analysis

147 148 149 150

-- | A backward rewrite takes the same inputs as a backward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.

151 152 153 154 155
data BackwardRewrites middle last a = BackwardRewrites
    { br_first  :: a              -> BlockId -> Maybe (AGraph middle last)
    , br_middle :: a              -> middle  -> Maybe (AGraph middle last)
    , br_last   :: (BlockId -> a) -> last    -> Maybe (AGraph middle last)
    , br_exit   ::                              Maybe (AGraph middle last)
156 157 158 159 160
    } 

-- | A forward rewrite takes the same inputs as a forward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.

161 162 163 164 165
data ForwardRewrites middle last a = ForwardRewrites
    { fr_first  :: a -> BlockId -> Maybe (AGraph middle last)
    , fr_middle :: a -> middle  -> Maybe (AGraph middle last)
    , fr_last   :: a -> last    -> Maybe (AGraph middle last)
    , fr_exit   :: a            -> Maybe (AGraph middle last)
166 167
    } 

168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
{- ===================== FIXED POINTS =================== -}

-- | The result of combined analysis and transformation is a 
-- solution to the set of dataflow equations together with a 'contained value'.
-- This solution is a member of type class 'FixedPoint', which is parameterized by
--   * middle and last nodes 'm' and 'l'
--   * data flow fact 'fact'
--   * the type 'a' of the contained value
--
-- In practice, the contained value 'zdfFpContents' is either a
-- rewritten graph, when rewriting, or (), when solving without
-- rewriting.  A function 'zdfFpMap' allows a client to change 
-- the contents without changing other values.
--
-- To save space, we provide the solution 'zdfFpFacts' as a mapping
-- from BlockId to fact; if necessary, facts on edges can be
-- reconstructed using the transfer functions; this functionality is
-- intended to be included as the 'zdfDecoratedGraph', but the code
-- has not yet been implemented.
--
-- The solution may also includes a fact 'zdfFpOuputFact', which is
-- not associated with any label:
--   * for a backward problem, this is the fact at entry
--   * for a forward problem, this is the fact at the distinguished exit node,
--     if such a node is present
--
-- For a forward problem only, the solution includes 'zdfFpLastOuts',
-- which is the set of facts on edges leaving the graph.
--
-- The flag 'zdfGraphChanged' tells whether the engine did any rewriting.

class FixedPoint fp where
    zdfFpContents     :: fp m l fact a -> a
    zdfFpFacts        :: fp m l fact a -> BlockEnv fact
    zdfFpOutputFact   :: fp m l fact a -> fact  -- entry for backward; exit for forward
    zdfDecoratedGraph :: fp m l fact a -> Graph (fact, m) (fact, l)
    zdfGraphChanged   :: fp m l fact a -> ChangeFlag
    zdfFpMap          :: (a -> b) -> (fp m l fact a -> fp m l fact b)

-- | The class 'FixedPoint' has two instances: one for forward problems and
-- one for backward problems.  The 'CommonFixedPoint' defines all fields 
-- common to both.  (The instance declarations are uninteresting and appear below.)

211 212 213 214 215 216 217 218
data CommonFixedPoint m l fact a = FP
    { fp_facts     :: BlockEnv fact
    , fp_out       :: fact  -- entry for backward; exit for forward
    , fp_changed   :: ChangeFlag
    , fp_dec_graph :: Graph (fact, m) (fact, l)
    , fp_contents  :: a
    }

219
-- | The common fixed point is sufficient for a backward problem.
220 221
type BackwardFixedPoint = CommonFixedPoint

222
-- | A forward problem needs the common fields, plus the facts on the outedges.
223 224 225 226 227
data ForwardFixedPoint m l fact a = FFP
    { ffp_common    :: CommonFixedPoint m l fact a
    , zdfFpLastOuts :: LastOutFacts fact
    }

228 229 230 231 232

{- ============== SOLVING AND REWRITING ============== -}

type PassName = String

Thomas Schilling's avatar
Thomas Schilling committed
233
-- | 'zdfSolveFrom' is an overloaded name that resolves to a pure
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
-- analysis with no rewriting.  It has only two instances: forward and
-- backward.  Since it needs no rewrites, the type parameters of the
-- class are transfer functions and the fixed point.
--
--
-- An iterative solver normally starts with the bottom fact at every
-- node, but it can be useful in other contexts as well.  For this
-- reason the initial set of facts (at labelled blocks only) is a
-- parameter to the solver.  
--
-- The constraints on the type signature exist purely for debugging;
-- they make it possible to prettyprint nodes and facts.  The parameter of
-- type 'PassName' is also used just for debugging.
--
-- Note that the result is a fixed point with no contents, that is,
-- the contents have type ().
-- 
-- The intent of the rest of the type signature should be obvious.
-- If not, place a skype call to norman-ramsey or complain bitterly
Thomas Schilling's avatar
Thomas Schilling committed
253
-- to <norman-ramsey@acm.org>.
254 255 256

class DataflowSolverDirection transfers fixedpt where
  zdfSolveFrom   :: (DebugNodes m l, Outputable a)
Thomas Schilling's avatar
Thomas Schilling committed
257
                 => BlockEnv a        -- ^ Initial facts (unbound == bottom)
258
                 -> PassName
Thomas Schilling's avatar
Thomas Schilling committed
259 260 261 262 263
                 -> DataflowLattice a -- ^ Lattice
                 -> transfers m l a   -- ^ Dataflow transfer functions
                 -> a                 -- ^ Fact flowing in (at entry or exit)
                 -> Graph m l         -- ^ Graph to be analyzed
                 -> FuelMonad (fixedpt m l a ())  -- ^ Answers
264 265 266 267 268 269 270 271 272
  zdfSolveFromL  :: (DebugNodes m l, Outputable a)
                 => BlockEnv a        -- Initial facts (unbound == bottom)
                 -> PassName
                 -> DataflowLattice a -- Lattice
                 -> transfers m l a   -- Dataflow transfer functions
                 -> a                 -- Fact flowing in (at entry or exit)
                 -> LGraph m l         -- Graph to be analyzed
                 -> FuelMonad (fixedpt m l a ())  -- Answers
  zdfSolveFromL b p l t a g = zdfSolveFrom b p l t a $ quickGraph g
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302

-- There are exactly two instances: forward and backward
instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
  where zdfSolveFrom = solve_f

instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
  where zdfSolveFrom = solve_b


-- | zdfRewriteFrom is an overloaded name that resolves to an
-- interleaved analysis and transformation.  It too is instantiated in
-- forward and backward directions.
-- 
-- The type parameters of the class include not only transfer
-- functions and the fixed point but also rewrites and the type
-- constructor (here called 'graph') for making rewritten graphs.  As
-- above, in the definitoins of the rewrites, it might simplify
-- matters if 'graph' were replaced with 'AGraph'.
--
-- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
-- with additional parameters and a different result.  Of course the
-- rewrites are an additional parameter, but there are further
-- parameters which reflect the fact that rewriting consumes both
-- OptimizationFuel and Uniqs.
--
-- The result type is changed to reflect fuel consumption, and also
-- the resulting fixed point containts a rewritten graph.
--
-- John Dias is going to improve the management of Uniqs and Fuel so
-- that it doesn't make us sick to look at the types.
303 304

class DataflowSolverDirection transfers fixedpt =>
305
      DataflowDirection transfers fixedpt rewrites where
306
  zdfRewriteFrom :: (DebugNodes m l, Outputable a)
307 308
                 => RewritingDepth      -- whether to rewrite a rewritten graph
                 -> BlockEnv a          -- initial facts (unbound == botton)
309 310 311
                 -> PassName
                 -> DataflowLattice a
                 -> transfers m l a
312
                 -> rewrites m l a
313
                 -> a                   -- fact flowing in (at entry or exit)
314 315 316
                 -> Graph m l
                 -> FuelMonad (fixedpt m l a (Graph m l))

317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
-- Temporarily lifting from Graph to LGraph -- an experiment to see how we
-- can eliminate some hysteresis between Graph and LGraph.
-- Perhaps Graph should be confined to dataflow code.
-- Trading space for time
quickGraph :: LastNode l => LGraph m l -> Graph m l
quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g

quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l)
quickLGraph args (Graph (ZLast (LastOther l)) blockenv)
    | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv
quickLGraph args g = F.lGraphOfGraph g args

fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) ->
                                 FuelMonad (CommonFixedPoint m l fact (LGraph m l))
fixptWithLGraph args cfp =
  do fp_c <- quickLGraph args $ fp_contents cfp
     return $ cfp {fp_contents = fp_c}

ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) ->
                                  FuelMonad (ForwardFixedPoint m l fact (LGraph m l))
ffixptWithLGraph args fp =
  do common <- fixptWithLGraph args $ ffp_common fp
     return $ fp {ffp_common = common}

zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
               => RewritingDepth      -- whether to rewrite a rewritten graph
               -> BlockEnv a          -- initial facts (unbound == botton)
               -> PassName
               -> DataflowLattice a
               -> ForwardTransfers m l a
               -> ForwardRewrites m l a
               -> a                   -- fact flowing in (at entry or exit)
               -> LGraph m l
               -> FuelMonad (ForwardFixedPoint m l a (LGraph m l))
zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) =
  do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
     ffixptWithLGraph args fp

zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
               => RewritingDepth      -- whether to rewrite a rewritten graph
               -> BlockEnv a          -- initial facts (unbound == botton)
               -> PassName
               -> DataflowLattice a
               -> BackwardTransfers m l a
               -> BackwardRewrites m l a
               -> a                   -- fact flowing in (at entry or exit)
               -> LGraph m l
               -> FuelMonad (BackwardFixedPoint m l a (LGraph m l))
zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) =
  do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
     fixptWithLGraph args fp


370 371 372 373 374 375 376
data RewritingDepth = RewriteShallow | RewriteDeep
-- When a transformation proposes to rewrite a node, 
-- you can either ask the system to
--  * "shallow": accept the new graph, analyse it without further rewriting
--  * "deep": recursively analyse-and-rewrite the new graph


377 378 379 380
-- There are currently four instances, but there could be more
--	forward, backward (instantiates transfers, fixedpt, rewrites)
--	Graph, AGraph     (instantiates graph)

381
instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites
382 383
  where zdfRewriteFrom = rewrite_f_agraph

384
instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites
385 386 387
  where zdfRewriteFrom = rewrite_b_agraph


388
{- =================== IMPLEMENTATIONS ===================== -}
389 390 391 392 393 394 395 396 397 398 399 400


-----------------------------------------------------------
--	solve_f: forward, pure 

solve_f         :: (DebugNodes m l, Outputable a)
                => BlockEnv a        -- initial facts (unbound == bottom)
                -> PassName
                -> DataflowLattice a -- lattice
                -> ForwardTransfers m l a   -- dataflow transfer functions
                -> a
                -> Graph m l         -- graph to be analyzed
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
401
                -> FuelMonad (ForwardFixedPoint m l a ())  -- answers
402
solve_f env name lattice transfers in_fact g =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
403
   runDFM lattice $ fwd_pure_anal name env transfers in_fact g
404 405 406 407 408 409 410
    
rewrite_f_agraph :: (DebugNodes m l, Outputable a)
                 => RewritingDepth
                 -> BlockEnv a
                 -> PassName
                 -> DataflowLattice a
                 -> ForwardTransfers m l a
411
                 -> ForwardRewrites  m l a
412 413 414
                 -> a                 -- fact flowing in (at entry or exit)
                 -> Graph m l
                 -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
415 416
rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
    runDFM lattice $
417
    do fuel <- fuelRemaining
418
       (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name
419 420 421 422 423
                      transfers rewrites in_fact g fuel
       fuelDecrement name fuel fuel'
       return fp

areturn :: AGraph m l -> DFM a (Graph m l)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
424
areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
425 426 427 428 429

-- | Here we prefer not simply to slap on 'goto eid' because this
-- introduces an unnecessary basic block at each rewrite, and we don't
-- want to stress out the finite map more than necessary
lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
430
lgraphToGraph (LGraph eid _ blocks) =
431
    if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then
432 433
        Graph (ZLast (mkBranchNode eid)) blocks
    else -- common case: entry is not a branch target
434
        let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
435
        in  Graph entry (delFromBlockEnv blocks eid)
436 437 438 439
    

class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l

440
fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
441 442 443 444 445 446 447 448 449 450
             => PassName
             -> BlockEnv a
             -> ForwardTransfers m l a
             -> a
             -> Graph m l
             -> DFM a (ForwardFixedPoint m l a ())

fwd_pure_anal name env transfers in_fact g =
    do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
       return fp
451
  where -- definitely a case of "I love lazy evaluation"
452
    anal_f = forward_sol (\_ _ -> Nothing) panic_depth
453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485
    panic_rewrites = panic "pure analysis asked for a rewrite function"
    panic_fuel     = panic "pure analysis asked for fuel"
    panic_depth    = panic "pure analysis asked for a rewrite depth"

-----------------------------------------------------------------------
--
--	Here beginneth the super-general functions
--
--  Think of them as (typechecked) macros
--   *  They are not exported
--
--   *  They are called by the specialised wrappers
--	above, and always inlined into their callers
--
-- There are four functions, one for each combination of:
--	Forward, Backward
--	Solver, Rewriter
--
-- A "solver" produces a (DFM f (f, Fuel)), 
--	where f is the fact at entry(Bwd)/exit(Fwd)
--	and from the DFM you can extract 
--		the BlockId->f
--		the change-flag
--		and more besides
--
-- A "rewriter" produces a rewritten *Graph* as well
--
-- Both constrain their rewrites by 
--	a) Fuel
--	b) RewritingDepth: shallow/deep

-----------------------------------------------------------------------

486
type Fuel = OptimizationFuel
487 488 489

{-# INLINE forward_sol #-}
forward_sol
490
        :: forall m l a . 
491 492 493 494 495 496 497 498 499 500
           (DebugNodes m l, LastNode l, Outputable a)
        => (forall a . Fuel -> Maybe a -> Maybe a)
		-- Squashes proposed rewrites if there is
		-- no more fuel; OR if we are doing a pure
		-- analysis, so totally ignore the rewrite
		-- ie. For pure-analysis the fn is (\_ _ -> Nothing)
        -> RewritingDepth	-- Shallow/deep
        -> PassName
        -> BlockEnv a		-- Initial set of facts
        -> ForwardTransfers m l a
501
        -> ForwardRewrites m l a
502 503 504 505
        -> a			-- Entry fact
        -> Graph m l
        -> Fuel
        -> DFM a (ForwardFixedPoint m l a (), Fuel)
506
forward_sol check_maybe = forw
507 508 509 510 511
 where
  forw :: RewritingDepth
       -> PassName
       -> BlockEnv a
       -> ForwardTransfers m l a
512
       -> ForwardRewrites m l a
513 514 515 516 517 518 519 520 521 522 523 524 525
       -> a
       -> Graph m l
       -> Fuel
       -> DFM a (ForwardFixedPoint m l a (), Fuel)
  forw rewrite name start_facts transfers rewrites =
   let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
       anal_f finish in' g =
           do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }

       solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
       solve finish in_fact (Graph entry blockenv) fuel =
         let blocks = G.postorder_dfs_from blockenv entry
             set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
526
             set_successor_facts (Block id _ tail) fuel =
527 528 529
               do { idfact <- getFact id
                  ; (last_outs, fuel) <-
                      case check_maybe fuel $ fr_first rewrites idfact id of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
530
                        Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
531
                        Just g ->
532
                          do g <- areturn g
533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553
                             (a, fuel) <- subAnalysis' $
                               case rewrite of
                                 RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)
                                 RewriteShallow ->
                                     do { a <- anal_f getExitFact idfact g
                                        ; return (a, oneLessFuel fuel) }
                             solve_tail a tail fuel
                  ; set_or_save last_outs
                  ; return fuel }

         in do { (last_outs, fuel) <- solve_tail in_fact entry fuel
               ; set_or_save last_outs                                    
               ; fuel <- run "forward" name set_successor_facts blocks fuel
               ; b <- finish
               ; return (b, fuel)
               }

       solve_tail in' (G.ZTail m t) fuel =
         case check_maybe fuel $ fr_middle rewrites in' m of
           Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
           Just g ->
554
             do { g <- areturn g
555 556 557 558 559 560 561 562 563 564 565 566 567 568
                ; (a, fuel) <- subAnalysis' $
                     case rewrite of
                       RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)
                       RewriteShallow -> do { a <- anal_f getExitFact in' g
                                            ; return (a, oneLessFuel fuel) }
                ; solve_tail a t fuel
                }
       solve_tail in' (G.ZLast l) fuel = 
         case check_maybe fuel $ either_last rewrites in' l of
           Nothing ->
               case l of LastOther l -> return (ft_last_outs transfers in' l, fuel)
                         LastExit -> do { setExitFact (ft_exit_out transfers in')
                                        ; return (LastOutFacts [], fuel) }
           Just g ->
569
             do { g <- areturn g
570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606
                ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
                    case rewrite of
                      RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)
                      RewriteShallow -> do { los <- anal_f lastOutFacts in' g
                                           ; return (los, fuel) }
                ; return (last_outs, fuel)
                } 

       fixed_point in_fact g fuel =
         do { setAllFacts start_facts
            ; (a, fuel) <- solve getExitFact in_fact g fuel
            ; facts <- getAllFacts
            ; last_outs <- lastOutFacts
            ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
            ; let fp = FFP cfp last_outs
            ; return (fp, fuel)
            }

       either_last rewrites in' (LastExit) = fr_exit rewrites in'
       either_last rewrites in' (LastOther l) = fr_last rewrites in' l

   in fixed_point




mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
                  (BlockId -> Bool) -> LastOutFacts a -> df a ()
mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
    where set_or_save_one (id, a) =
              if is_local id then setFact id a else addLastOutFact (id, a)




{-# INLINE forward_rew #-}
forward_rew
607
        :: forall m l a . 
608 609 610 611 612 613
           (DebugNodes m l, LastNode l, Outputable a)
        => (forall a . Fuel -> Maybe a -> Maybe a)
        -> RewritingDepth
        -> BlockEnv a
        -> PassName
        -> ForwardTransfers m l a
614
        -> ForwardRewrites m l a
615 616 617 618
        -> a
        -> Graph m l
        -> Fuel
        -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
619
forward_rew check_maybe = forw
620
  where
621
    solve = forward_sol check_maybe
622 623 624 625
    forw :: RewritingDepth
         -> BlockEnv a
         -> PassName
         -> ForwardTransfers m l a
626
         -> ForwardRewrites m l a
627 628 629 630 631 632 633 634 635 636 637 638 639 640
         -> a
         -> Graph m l
         -> Fuel
         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
    forw depth xstart_facts name transfers rewrites in_factx gx fuelx =
      let rewrite :: BlockEnv a -> DFM a b
                  -> a -> Graph m l -> Fuel
                  -> DFM a (b, Graph m l, Fuel)
          rewrite start finish in_fact g fuel =
            let Graph entry blockenv = g
                blocks = G.postorder_dfs_from blockenv entry
            in do { solve depth name start transfers rewrites in_fact g fuel
                  ; eid <- freshBlockId "temporary entry id"
                  ; (rewritten, fuel) <-
641 642
                      rew_tail (ZFirst eid emptyStackInfo)
                               in_fact entry emptyBlockEnv fuel
643 644
                  ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
                  ; a <- finish
645
                  ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
646
                  }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
647 648
          don't_rewrite facts finish in_fact g fuel =
              do  { solve depth name facts transfers rewrites in_fact g fuel
649 650 651
                  ; a <- finish
                  ; return (a, g, fuel)
                  }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
652 653 654 655
          inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
          inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
              where inner_rew' = case depth of RewriteShallow -> don't_rewrite
                                               RewriteDeep    -> rewrite
656 657 658 659 660 661 662 663 664 665 666 667
          fixed_pt_and_fuel =
              do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
                 ; facts <- getAllFacts
                 ; changed <- graphWasRewritten
                 ; last_outs <- lastOutFacts
                 ; let cfp = FP facts a changed (panic "no decoration?!") g
                 ; let fp = FFP cfp last_outs
                 ; return (fp, fuel)
                 }
          rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
                         -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
          rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
668 669
          rewrite_blocks (G.Block id off t : bs) rewritten fuel =
            do let h = ZFirst id off
670 671
               a <- getFact id
               case check_maybe fuel $ fr_first rewrites a id of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
672 673 674
                 Nothing -> do { (rewritten, fuel) <-
                                    rew_tail h (ft_first_out transfers a id)
                                             t rewritten fuel
675 676
                               ; rewrite_blocks bs rewritten fuel }
                 Just g  -> do { markGraphRewritten
677
                               ; g <- areturn g
678
                               ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
679
                               ; let (blocks, h) = splice_head' h g
680
                               ; (rewritten, fuel) <-
681
                                 rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel
682 683 684 685 686 687 688 689
                               ; rewrite_blocks bs rewritten fuel }

          rew_tail head in' (G.ZTail m t) rewritten fuel =
            my_trace "Rewriting middle node" (ppr m) $
            case check_maybe fuel $ fr_middle rewrites in' m of
              Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
                         rewritten fuel
              Just g -> do { markGraphRewritten
690
                           ; g <- areturn g
691 692
                           ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
                           ; let (blocks, h) = G.splice_head' head g
693
                           ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel
694 695 696 697
                           }
          rew_tail h in' (G.ZLast l) rewritten fuel = 
            my_trace "Rewriting last node" (ppr l) $
            case check_maybe fuel $ either_last rewrites in' l of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
698 699
              Nothing -> do check_facts in' l
                            return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
700
              Just g -> do { markGraphRewritten
701
                           ; g <- areturn g
702 703
                           ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
                           ; let g' = G.splice_head_only' h g
704
                           ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel)
705 706 707
                           }
          either_last rewrites in' (LastExit) = fr_exit rewrites in'
          either_last rewrites in' (LastOther l) = fr_last rewrites in' l
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
708 709 710 711
          check_facts in' (LastOther l) =
            let LastOutFacts last_outs = ft_last_outs transfers in' l
            in mapM (uncurry checkFactMatch) last_outs
          check_facts _ LastExit = return []
712 713 714 715 716 717 718 719 720 721 722 723 724 725
      in  fixed_pt_and_fuel

lastOutFacts :: DFM f (LastOutFacts f)
lastOutFacts = bareLastOutFacts >>= return . LastOutFacts

{- ================================================================ -}

solve_b         :: (DebugNodes m l, Outputable a)
                => BlockEnv a        -- initial facts (unbound == bottom)
                -> PassName
                -> DataflowLattice a -- lattice
                -> BackwardTransfers m l a   -- dataflow transfer functions
                -> a                 -- exit fact
                -> Graph m l         -- graph to be analyzed
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
726
                -> FuelMonad (BackwardFixedPoint m l a ())  -- answers
727
solve_b env name lattice transfers exit_fact g =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
728
   runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
729 730 731 732 733 734 735 736
    

rewrite_b_agraph :: (DebugNodes m l, Outputable a)
                 => RewritingDepth
                 -> BlockEnv a
                 -> PassName
                 -> DataflowLattice a
                 -> BackwardTransfers m l a
737
                 -> BackwardRewrites m l a
738 739 740
                 -> a                 -- fact flowing in at exit
                 -> Graph m l
                 -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
741 742
rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
    runDFM lattice $
743
    do fuel <- fuelRemaining
744
       (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name
745 746 747 748 749 750 751 752
                      transfers rewrites g exit_fact fuel
       fuelDecrement name fuel fuel'
       return fp



{-# INLINE backward_sol #-}
backward_sol
753
        :: forall m l a . 
754 755 756 757 758 759
           (DebugNodes m l, LastNode l, Outputable a)
        => (forall a . Fuel -> Maybe a -> Maybe a)
        -> RewritingDepth
        -> PassName
        -> BlockEnv a
        -> BackwardTransfers m l a
760
        -> BackwardRewrites m l a
761 762 763 764
        -> Graph m l
        -> a
        -> Fuel
        -> DFM a (BackwardFixedPoint m l a (), Fuel)
765
backward_sol check_maybe = back
766 767 768 769 770
 where
  back :: RewritingDepth
       -> PassName
       -> BlockEnv a
       -> BackwardTransfers m l a
771
       -> BackwardRewrites m l a
772 773 774 775 776 777 778 779 780 781
       -> Graph m l
       -> a
       -> Fuel
       -> DFM a (BackwardFixedPoint m l a (), Fuel)
  back rewrite name start_facts transfers rewrites =
   let anal_b :: Graph m l -> a -> DFM a a
       anal_b g out =
           do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
              ; return $ zdfFpOutputFact fp }

782
       subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel)
783 784 785
       subsolve =
         case rewrite of
           RewriteDeep    -> \g a fuel ->
786
               subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) }
787
           RewriteShallow -> \g a fuel ->
788
               subAnalysis' $ do { g <- areturn g; a <- anal_b g a
789 790 791 792 793 794 795 796 797 798 799 800 801 802 803
                                 ; return (a, oneLessFuel fuel) }

       solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
       solve (Graph entry blockenv) exit_fact fuel =
         let blocks = reverse $ G.postorder_dfs_from blockenv entry
             last_in  _env (LastExit)    = exit_fact
             last_in   env (LastOther l) = bt_last_in transfers env l
             last_rew _env (LastExit)    = br_exit rewrites 
             last_rew  env (LastOther l) = br_last rewrites env l
             set_block_fact block fuel =
                 let (h, l) = G.goto_end (G.unzip block) in
                 do { env <- factsEnv
                    ; (a, fuel) <-
                      case check_maybe fuel $ last_rew env l of
                        Nothing -> return (last_in env l, fuel)
804 805 806 807
                        Just g -> do g' <- areturn g
                                     my_trace "analysis rewrites last node"
                                      (ppr l <+> pprGraph g') $
                                      subsolve g exit_fact fuel
808 809 810 811 812
                    ; set_head_fact h a fuel
                    ; return fuel }

         in do { fuel <- run "backward" name set_block_fact blocks fuel
               ; eid <- freshBlockId "temporary entry id"
813
               ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel
814 815 816 817 818
               ; a <- getFact eid
               ; forgetFact eid
               ; return (a, fuel)
               }

819
       set_head_fact (G.ZFirst id _) a fuel =
820
         case check_maybe fuel $ br_first rewrites a id of
821 822
           Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+>
                                                     ppr (bt_first_in transfers a id)) $
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
823 824
                           setFact id $ bt_first_in transfers a id
                         ; return fuel }
825 826 827 828 829
           Just g  -> do { g' <- areturn g
                         ; (a, fuel) <- my_trace "analysis rewrites first node"
                                      (ppr id <+> pprGraph g') $
                                      subsolve g a fuel
                         ; setFact id $ bt_first_in transfers a id
830 831 832 833 834
                         ; return fuel
                         }
       set_head_fact (G.ZHead h m) a fuel =
         case check_maybe fuel $ br_middle rewrites a m of
           Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
835 836 837 838
           Just g -> do { g' <- areturn g
                        ; (a, fuel) <- my_trace "analysis rewrites middle node"
                                      (ppr m <+> pprGraph g') $
                                      subsolve g a fuel
839 840 841 842 843 844 845 846 847 848 849
                        ; set_head_fact h a fuel }

       fixed_point g exit_fact fuel =
         do { setAllFacts start_facts
            ; (a, fuel) <- solve g exit_fact fuel
            ; facts <- getAllFacts
            ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
            ; return (cfp, fuel)
            }
   in fixed_point

850
bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
851 852 853 854 855 856 857 858 859 860 861
             => PassName
             -> BlockEnv a
             -> BackwardTransfers m l a
             -> Graph m l
             -> a
             -> DFM a (BackwardFixedPoint m l a ())

bwd_pure_anal name env transfers g exit_fact =
    do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
       return fp
  where -- another case of "I love lazy evaluation"
862
    anal_b = backward_sol (\_ _ -> Nothing) panic_depth
863 864 865 866 867 868 869 870 871
    panic_rewrites = panic "pure analysis asked for a rewrite function"
    panic_fuel     = panic "pure analysis asked for fuel"
    panic_depth    = panic "pure analysis asked for a rewrite depth"


{- ================================================================ -}

{-# INLINE backward_rew #-}
backward_rew
872
        :: forall m l a . 
873 874 875 876 877 878
           (DebugNodes m l, LastNode l, Outputable a)
        => (forall a . Fuel -> Maybe a -> Maybe a)
        -> RewritingDepth
        -> BlockEnv a
        -> PassName
        -> BackwardTransfers m l a
879
        -> BackwardRewrites m l a
880 881 882 883
        -> Graph m l
        -> a
        -> Fuel
        -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
884
backward_rew check_maybe = back
885
  where
886
    solve = backward_sol check_maybe
887 888 889 890
    back :: RewritingDepth
         -> BlockEnv a
         -> PassName
         -> BackwardTransfers m l a
891
         -> BackwardRewrites m l a
892 893 894 895 896 897 898 899 900 901 902
         -> Graph m l
         -> a
         -> Fuel
         -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
    back depth xstart_facts name transfers rewrites gx exit_fact fuelx =
      let rewrite :: BlockEnv a
                  -> Graph m l -> a -> Fuel
                  -> DFM a (a, Graph m l, Fuel)
          rewrite start g exit_fact fuel =
           let Graph entry blockenv = g
               blocks = reverse $ G.postorder_dfs_from blockenv entry
903 904 905
           in do { (FP env in_fact _ _ _, _) <-    -- don't drop the entry fact!
                     solve depth name start transfers rewrites g exit_fact fuel
                 --; env <- getAllFacts
906
                 -- ; my_trace "facts after solving" (ppr env) $ return ()
907
                 ; eid <- freshBlockId "temporary entry id"
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
908 909
                 ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
                 -- We can't have the fact check fail on the bogus entry, which _may_ change
910 911 912
                 ; (rewritten, fuel) <-
                     rewrite_blocks False [Block eid emptyStackInfo entry]
                                    rewritten fuel
913 914 915 916 917
                 ; my_trace "eid" (ppr eid) $ return ()
                 ; my_trace "exit_fact" (ppr exit_fact) $ return ()
                 ; my_trace "in_fact" (ppr in_fact) $ return ()
                 ; return (in_fact, lgraphToGraph (LGraph eid 0 rewritten), fuel)
                 } -- Remember: the entry fact computed by @solve@ accounts for rewriting
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
918
          don't_rewrite facts g exit_fact fuel =
919
            do { (fp, _) <-
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
920
                     solve depth name facts transfers rewrites g exit_fact fuel
921 922
               ; return (zdfFpOutputFact fp, g, fuel) }
          inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
923 924 925
          inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f
              where inner_rew' = case depth of RewriteShallow -> don't_rewrite
                                               RewriteDeep    -> rewrite
926 927 928 929 930 931 932
          fixed_pt_and_fuel =
              do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
                 ; facts <- getAllFacts
                 ; changed <- graphWasRewritten
                 ; let fp = FP facts a changed (panic "no decoration?!") g
                 ; return (fp, fuel)
                 }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
933
          rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l))
934
                         -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
935
          rewrite_blocks check bs rewritten fuel =
936 937 938
              do { env <- factsEnv
                 ; let rew [] r f = return (r, f)
                       rew (b : bs) r f =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
939
                           do { (r, f) <- rewrite_block check env b r f; rew bs r f }
940
                 ; rew bs rewritten fuel }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
941
          rewrite_block check env b rewritten fuel =
942 943
            let (h, l) = G.goto_end (G.unzip b) in
            case maybeRewriteWithFuel fuel $ either_last env l of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
944
              Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
945 946
              Just g ->
                do { markGraphRewritten
947
                   ; g <- areturn g
948 949
                   ; (a, g, fuel) <- inner_rew g exit_fact fuel
                   ; let G.Graph t new_blocks = g
950
                   ; let rewritten' = new_blocks `plusBlockEnv` rewritten
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
951
                   ; propagate check fuel h a t rewritten' -- continue at entry of g
952 953 954 955 956
                   } 
          either_last _env (LastExit)    = br_exit rewrites 
          either_last  env (LastOther l) = br_last rewrites env l
          last_in _env (LastExit)    = exit_fact
          last_in  env (LastOther l) = bt_last_in transfers env l
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
957
          propagate check fuel (ZHead h m) a tail rewritten =
958 959
            case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
              Nothing ->
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
960
                propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
961 962
              Just g  ->
                do { markGraphRewritten
963
                   ; g <- areturn g
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
964 965
                   ; my_trace "With Facts" (ppr a) $ return ()
                   ; my_trace "  Rewrote middle node"
966 967 968 969
                                             (f4sep [ppr m, text "to", pprGraph g]) $
                     return ()
                   ; (a, g, fuel) <- inner_rew g a fuel
                   ; let Graph t newblocks = G.splice_tail g tail
970
                   ; my_trace "propagating facts" (ppr a) $
971
                     propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) }
972
          propagate check fuel (ZFirst id off) a tail rewritten =
973
            case maybeRewriteWithFuel fuel $ br_first rewrites a id of
974 975
              Nothing -> do { if check then
                                checkFactMatch id $ bt_first_in transfers a id
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
976
                              else return ()
977
                            ; return (insertBlock (Block id off tail) rewritten, fuel) }
978 979
              Just g ->
                do { markGraphRewritten
980
                   ; g <- areturn g
981 982 983
                   ; my_trace "Rewrote first node"
                     (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
                   ; (a, g, fuel) <- inner_rew g a fuel
984 985
                   ; if check then checkFactMatch id (bt_first_in transfers a id)
                     else return ()
986
                   ; let Graph t newblocks = G.splice_tail g tail
987
                   ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010
                   ; return (r, fuel) }
      in  fixed_pt_and_fuel

{- ================================================================ -}

instance FixedPoint CommonFixedPoint where
    zdfFpFacts        = fp_facts
    zdfFpOutputFact   = fp_out
    zdfGraphChanged   = fp_changed
    zdfDecoratedGraph = fp_dec_graph
    zdfFpContents     = fp_contents
    zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)

instance FixedPoint ForwardFixedPoint where
    zdfFpFacts        = fp_facts     . ffp_common
    zdfFpOutputFact   = fp_out       . ffp_common
    zdfGraphChanged   = fp_changed   . ffp_common
    zdfDecoratedGraph = fp_dec_graph . ffp_common
    zdfFpContents     = fp_contents  . ffp_common
    zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los


dump_things :: Bool
1011
dump_things = False
1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024

my_trace :: String -> SDoc -> a -> a
my_trace = if dump_things then pprTrace else \_ _ a -> a


-- | Here's a function to run an action on blocks until we reach a fixed point.
run :: (Outputable a, DebugNodes m l) =>
       String -> String -> (Block m l -> b -> DFM a b) -> [Block m l] -> b -> DFM a b
run dir name do_block blocks b =
   do { show_blocks $ iterate (1::Int) }
   where
     -- N.B. Each iteration starts with the same transaction limit;
     -- only the rewrites in the final iteration actually count
1025 1026 1027 1028 1029
     trace_block (b, cnt) block =
         do b' <- my_trace "about to do" (text name <+> text "on" <+>
                     ppr (blockId block) <+> ppr cnt) $
                    do_block block b
            return (b', cnt + 1)
1030 1031
     iterate n = 
         do { markFactsUnchanged
1032 1033 1034
            ; (b, _) <-
                 my_trace "block count:" (ppr (length blocks)) $
                   foldM trace_block (b, 0 :: Int) blocks
1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050
            ; changed <- factsStatus
            ; facts <- getAllFacts
            ; let depth = 0 -- was nesting depth
            ; ppIter depth n $
              case changed of
                NoChange -> unchanged depth $ return b
                SomeChange ->
                    pprFacts depth n facts $ 
                    if n < 1000 then iterate (n+1)
                    else panic $ msg n
            }
     msg n = concat [name, " didn't converge in ", show n, " " , dir,
                     " iterations"]
     my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
     ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
     pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
1051 1052
     unchanged depth =
       my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
1053

1054
     graphId = case blocks of { Block id _ _ : _ -> ppr id ; [] -> text "<empty>" }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
1055
     show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
1056
     pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
1057 1058
     pprFacts depth n env =
         my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
1059
                        (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
1060 1061
     pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
     pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a)
1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073


f4sep :: [SDoc] -> SDoc
f4sep [] = fsep []
f4sep (d:ds) = fsep (d : map (nest 4) ds)


subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
                m f a -> m f a
subAnalysis' m =
    do { a <- subAnalysis $
               do { a <- m; facts <- getAllFacts
1074
                  ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
1075 1076
                    return a }
       ; facts <- getAllFacts
1077
       ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
1078
         return a }
1079
  where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
1080
        pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)