compiler/cmm/ZipDataflow.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
   2 {-# OPTIONS -fglasgow-exts #-}
   3 -- -fglagow-exts for kind signatures
   4
   5 module ZipDataflow
   6     ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
   7     , zdfSolveFrom, zdfRewriteFrom
   8     , zdfSolveFromL
   9     , ForwardTransfers(..), BackwardTransfers(..)
  10     , ForwardRewrites(..),  BackwardRewrites(..)
  11     , ForwardFixedPoint, BackwardFixedPoint
  12     , zdfFpFacts
  13     , zdfFpOutputFact
  14     , zdfGraphChanged
  15     , zdfDecoratedGraph -- not yet implemented
  16     , zdfFpContents
  17     , zdfFpLastOuts
  18     , zdfBRewriteFromL, zdfFRewriteFromL
  19     )
  20 where
  21
  22 import BlockId
  23 import CmmTx
  24 import DFMonad
  25 import OptimizationFuel as F
  26 import MkZipCfg
  27 import ZipCfg
  28 import qualified ZipCfg as G
  29
  30 import Maybes
  31 import Outputable
  32 import Panic
  33 import UniqFM
  34
  35 import Control.Monad
  36 import Maybe
  37
  38 {-
  39
  40 This module implements two useful tools:
  41
  42   1. An iterative solver for dataflow problems
  43
  44   2. The combined dataflow-analysis-and-transformation framework
  45      described by Lerner, Grove, and Chambers in their excellent
  46      2002 POPL paper (http://tinyurl.com/3zycbr or
  47      http://tinyurl.com/3pnscd).
  48
  49 Each tool comes in two flavors: one for forward dataflow problems
  50 and one for backward dataflow problems.
  51
  52 We quote the paper above:
  53
  54   Dataflow analyses can have mutually beneficial interactions.
  55   Previous efforts to exploit these interactions have either
  56   (1) iteratively performed each individual analysis until no
  57   further improvements are discovered or (2) developed "super-
  58   analyses" that manually combine conceptually separate anal-
  59   yses. We have devised a new approach that allows anal-
  60   yses to be defined independently while still enabling them
  61   to be combined automatically and profitably. Our approach
  62   avoids the loss of precision associated with iterating indi-
  63   vidual analyses and the implementation difficulties of man-
  64   ually writing a super-analysis.
  65
  66 The key idea is to provide at each CFG node not only a dataflow
  67 transfer function but also a rewriting function that has the option to
  68 replace the node with a new (possibly empty) graph.  The rewriting
  69 function takes a dataflow fact as input, and the fact is used to
  70 justify any rewriting.  For example, in a backward problem, the fact
  71 that variable x is dead can be used to justify rewriting node
  72   x := e
  73 to the empty graph.  In a forward problem, the fact that x == 7 can
  74 be used to justify rewriting node
  75   y := x + 1
  76 to
  77   y := 8
  78 which in turn will be analyzed and produce a new fact:
  79 x == 7 and y == 8.
  80
  81 In its most general form, this module takes as input graph, transfer
  82 equations, rewrites, and an initial set of dataflow facts, and
  83 iteratively computes a new graph and a new set of dataflow facts such
  84 that
  85   * The set of facts is a fixed point of the transfer equations
  86   * The graph has been rewritten as much as is consistent with
  87     the given facts and requested rewriting depth (see below)
  88 N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'.
  89
  90 The types of transfer equations, rewrites, and fixed points are
  91 different for forward and backward problems.  To avoid cluttering the
  92 name space with two versions of every names, other names such as
  93 zdfSolveFrom are overloaded to work in both forward or backward
  94 directions.  This design decision is based on experience with the
  95 predecessor module, now called ZipDataflow0 and destined for the bit bucket.
  96
  97
  98 This module is deliberately very abstract.  It is a completely general
  99 framework and well-nigh impossible to understand in isolation.  The
 100 cautious reader will begin with some concrete examples in the form of
 101 clients.  NR recommends
 102
 103   CmmLiveZ             A simple liveness analysis
 104
 105   CmmSpillReload.removeDeadAssignmentsAndReloads
 106                        A piece of spaghetti to pull on, which leads to
 107                          - a two-part liveness analysis that tracks
 108                            variables live in registers and live on the stack
 109                          - elimination of assignments to dead variables
 110                          - elimination of redundant reloads
 111
 112 Even hearty souls should avoid the CmmProcPointZ client, at least for
 113 the time being.
 114
 115 -}
 116
 117
 118 {- ============ TRANSFER FUNCTIONS AND REWRITES =========== -}
 119
 120 -- | For a backward transfer, you're given the fact on a node's
 121 -- outedge and you compute the fact on the inedge.  Facts have type 'a'.
 122 -- A last node may have multiple outedges, each pointing to a labelled
 123 -- block, so instead of a fact it is given a mapping from BlockId to fact.
 124
 125 data BackwardTransfers middle last a = BackwardTransfers
 126     { bt_first_in  :: a              -> BlockId -> a
 127     , bt_middle_in :: a              -> middle  -> a
 128     , bt_last_in   :: (BlockId -> a) -> last    -> a
 129     }
 130
 131 -- | For a forward transfer, you're given the fact on a node's
 132 -- inedge and you compute the fact on the outedge. Because a last node
 133 -- may have multiple outedges, each pointing to a labelled
 134 -- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
 135
 136 data ForwardTransfers middle last a = ForwardTransfers
 137     { ft_first_out  :: a -> BlockId -> a
 138     , ft_middle_out :: a -> middle  -> a
 139     , ft_last_outs  :: a -> last    -> LastOutFacts a
 140     , ft_exit_out   :: a            -> a
 141     }
 142
 143 newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
 144   -- ^ These are facts flowing out of a last node to the node's successors.
 145   -- They are either to be set (if they pertain to the graph currently
 146   -- under analysis) or propagated out of a sub-analysis
 147
 148
 149 -- | A backward rewrite takes the same inputs as a backward transfer,
 150 -- but instead of producing a fact, it produces a replacement graph or Nothing.
 151 -- The type of the replacement graph is given as a type parameter 'g'
 152 -- of kind * -> * -> *.  This design offers great flexibility to clients,
 153 -- but it might be worth simplifying this module by replacing this type
 154 -- parameter with AGraph everywhere (SLPJ 19 May 2008).
 155
 156 data BackwardRewrites middle last a = BackwardRewrites
 157     { br_first  :: a              -> BlockId -> Maybe (AGraph middle last)
 158     , br_middle :: a              -> middle  -> Maybe (AGraph middle last)
 159     , br_last   :: (BlockId -> a) -> last    -> Maybe (AGraph middle last)
 160     , br_exit   ::                              Maybe (AGraph middle last)
 161     }
 162
 163 -- | A forward rewrite takes the same inputs as a forward transfer,
 164 -- but instead of producing a fact, it produces a replacement graph or Nothing.
 165
 166 data ForwardRewrites middle last a = ForwardRewrites
 167     { fr_first  :: a -> BlockId -> Maybe (AGraph middle last)
 168     , fr_middle :: a -> middle  -> Maybe (AGraph middle last)
 169     , fr_last   :: a -> last    -> Maybe (AGraph middle last)
 170     , fr_exit   :: a            -> Maybe (AGraph middle last)
 171     }
 172
 173 {- ===================== FIXED POINTS =================== -}
 174
 175 -- | The result of combined analysis and transformation is a
 176 -- solution to the set of dataflow equations together with a 'contained value'.
 177 -- This solution is a member of type class 'FixedPoint', which is parameterized by
 178 --   * middle and last nodes 'm' and 'l'
 179 --   * data flow fact 'fact'
 180 --   * the type 'a' of the contained value
 181 --
 182 -- In practice, the contained value 'zdfFpContents' is either a
 183 -- rewritten graph, when rewriting, or (), when solving without
 184 -- rewriting.  A function 'zdfFpMap' allows a client to change
 185 -- the contents without changing other values.
 186 --
 187 -- To save space, we provide the solution 'zdfFpFacts' as a mapping
 188 -- from BlockId to fact; if necessary, facts on edges can be
 189 -- reconstructed using the transfer functions; this functionality is
 190 -- intended to be included as the 'zdfDecoratedGraph', but the code
 191 -- has not yet been implemented.
 192 --
 193 -- The solution may also includes a fact 'zdfFpOuputFact', which is
 194 -- not associated with any label:
 195 --   * for a backward problem, this is the fact at entry
 196 --   * for a forward problem, this is the fact at the distinguished exit node,
 197 --     if such a node is present
 198 --
 199 -- For a forward problem only, the solution includes 'zdfFpLastOuts',
 200 -- which is the set of facts on edges leaving the graph.
 201 --
 202 -- The flag 'zdfGraphChanged' tells whether the engine did any rewriting.
 203
 204 class FixedPoint fp where
 205     zdfFpContents     :: fp m l fact a -> a
 206     zdfFpFacts        :: fp m l fact a -> BlockEnv fact
 207     zdfFpOutputFact   :: fp m l fact a -> fact  -- entry for backward; exit for forward
 208     zdfDecoratedGraph :: fp m l fact a -> Graph (fact, m) (fact, l)
 209     zdfGraphChanged   :: fp m l fact a -> ChangeFlag
 210     zdfFpMap          :: (a -> b) -> (fp m l fact a -> fp m l fact b)
 211
 212 -- | The class 'FixedPoint' has two instances: one for forward problems and
 213 -- one for backward problems.  The 'CommonFixedPoint' defines all fields
 214 -- common to both.  (The instance declarations are uninteresting and appear below.)
 215
 216 data CommonFixedPoint m l fact a = FP
 217     { fp_facts     :: BlockEnv fact
 218     , fp_out       :: fact  -- entry for backward; exit for forward
 219     , fp_changed   :: ChangeFlag
 220     , fp_dec_graph :: Graph (fact, m) (fact, l)
 221     , fp_contents  :: a
 222     }
 223
 224 -- | The common fixed point is sufficient for a backward problem.
 225 type BackwardFixedPoint = CommonFixedPoint
 226
 227 -- | A forward problem needs the common fields, plus the facts on the outedges.
 228 data ForwardFixedPoint m l fact a = FFP
 229     { ffp_common    :: CommonFixedPoint m l fact a
 230     , zdfFpLastOuts :: LastOutFacts fact
 231     }
 232
 233
 234 {- ============== SOLVING AND REWRITING ============== -}
 235
 236 type PassName = String
 237
 238 -- | 'zdfSolveFrom' is an overloaded name that resolves to a pure
 239 -- analysis with no rewriting.  It has only two instances: forward and
 240 -- backward.  Since it needs no rewrites, the type parameters of the
 241 -- class are transfer functions and the fixed point.
 242 --
 243 --
 244 -- An iterative solver normally starts with the bottom fact at every
 245 -- node, but it can be useful in other contexts as well.  For this
 246 -- reason the initial set of facts (at labelled blocks only) is a
 247 -- parameter to the solver.
 248 --
 249 -- The constraints on the type signature exist purely for debugging;
 250 -- they make it possible to prettyprint nodes and facts.  The parameter of
 251 -- type 'PassName' is also used just for debugging.
 252 --
 253 -- Note that the result is a fixed point with no contents, that is,
 254 -- the contents have type ().
 255 --
 256 -- The intent of the rest of the type signature should be obvious.
 257 -- If not, place a skype call to norman-ramsey or complain bitterly
 258 -- to <norman-ramsey@acm.org>.
 259
 260 class DataflowSolverDirection transfers fixedpt where
 261   zdfSolveFrom   :: (DebugNodes m l, Outputable a)
 262                  => BlockEnv a        -- ^ Initial facts (unbound == bottom)
 263                  -> PassName
 264                  -> DataflowLattice a -- ^ Lattice
 265                  -> transfers m l a   -- ^ Dataflow transfer functions
 266                  -> a                 -- ^ Fact flowing in (at entry or exit)
 267                  -> Graph m l         -- ^ Graph to be analyzed
 268                  -> FuelMonad (fixedpt m l a ())  -- ^ Answers
 269   zdfSolveFromL  :: (DebugNodes m l, Outputable a)
 270                  => BlockEnv a        -- Initial facts (unbound == bottom)
 271                  -> PassName
 272                  -> DataflowLattice a -- Lattice
 273                  -> transfers m l a   -- Dataflow transfer functions
 274                  -> a                 -- Fact flowing in (at entry or exit)
 275                  -> LGraph m l         -- Graph to be analyzed
 276                  -> FuelMonad (fixedpt m l a ())  -- Answers
 277   zdfSolveFromL b p l t a g = zdfSolveFrom b p l t a $ quickGraph g
 278
 279 -- There are exactly two instances: forward and backward
 280 instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
 281   where zdfSolveFrom = solve_f
 282
 283 instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
 284   where zdfSolveFrom = solve_b
 285
 286
 287 -- | zdfRewriteFrom is an overloaded name that resolves to an
 288 -- interleaved analysis and transformation.  It too is instantiated in
 289 -- forward and backward directions.
 290 --
 291 -- The type parameters of the class include not only transfer
 292 -- functions and the fixed point but also rewrites and the type
 293 -- constructor (here called 'graph') for making rewritten graphs.  As
 294 -- above, in the definitoins of the rewrites, it might simplify
 295 -- matters if 'graph' were replaced with 'AGraph'.
 296 --
 297 -- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
 298 -- with additional parameters and a different result.  Of course the
 299 -- rewrites are an additional parameter, but there are further
 300 -- parameters which reflect the fact that rewriting consumes both
 301 -- OptimizationFuel and Uniqs.
 302 --
 303 -- The result type is changed to reflect fuel consumption, and also
 304 -- the resulting fixed point containts a rewritten graph.
 305 --
 306 -- John Dias is going to improve the management of Uniqs and Fuel so
 307 -- that it doesn't make us sick to look at the types.
 308
 309 class DataflowSolverDirection transfers fixedpt =>
 310       DataflowDirection transfers fixedpt rewrites where
 311   zdfRewriteFrom :: (DebugNodes m l, Outputable a)
 312                  => RewritingDepth      -- whether to rewrite a rewritten graph
 313                  -> BlockEnv a          -- initial facts (unbound == botton)
 314                  -> PassName
 315                  -> DataflowLattice a
 316                  -> transfers m l a
 317                  -> rewrites m l a
 318                  -> a                   -- fact flowing in (at entry or exit)
 319                  -> Graph m l
 320                  -> FuelMonad (fixedpt m l a (Graph m l))
 321
 322 -- Temporarily lifting from Graph to LGraph -- an experiment to see how we
 323 -- can eliminate some hysteresis between Graph and LGraph.
 324 -- Perhaps Graph should be confined to dataflow code.
 325 -- Trading space for time
 326 quickGraph :: LastNode l => LGraph m l -> Graph m l
 327 quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g
 328
 329 quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l)
 330 quickLGraph args (Graph (ZLast (LastOther l)) blockenv)
 331     | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv
 332 quickLGraph args g = F.lGraphOfGraph g args
 333
 334 fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) ->
 335                                  FuelMonad (CommonFixedPoint m l fact (LGraph m l))
 336 fixptWithLGraph args cfp =
 337   do fp_c <- quickLGraph args $ fp_contents cfp
 338      return $ cfp {fp_contents = fp_c}
 339
 340 ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) ->
 341                                   FuelMonad (ForwardFixedPoint m l fact (LGraph m l))
 342 ffixptWithLGraph args fp =
 343   do common <- fixptWithLGraph args $ ffp_common fp
 344      return $ fp {ffp_common = common}
 345
 346 zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
 347                => RewritingDepth      -- whether to rewrite a rewritten graph
 348                -> BlockEnv a          -- initial facts (unbound == botton)
 349                -> PassName
 350                -> DataflowLattice a
 351                -> ForwardTransfers m l a
 352                -> ForwardRewrites m l a
 353                -> a                   -- fact flowing in (at entry or exit)
 354                -> LGraph m l
 355                -> FuelMonad (ForwardFixedPoint m l a (LGraph m l))
 356 zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) =
 357   do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
 358      ffixptWithLGraph args fp
 359
 360 zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
 361                => RewritingDepth      -- whether to rewrite a rewritten graph
 362                -> BlockEnv a          -- initial facts (unbound == botton)
 363                -> PassName
 364                -> DataflowLattice a
 365                -> BackwardTransfers m l a
 366                -> BackwardRewrites m l a
 367                -> a                   -- fact flowing in (at entry or exit)
 368                -> LGraph m l
 369                -> FuelMonad (BackwardFixedPoint m l a (LGraph m l))
 370 zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) =
 371   do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
 372      fixptWithLGraph args fp
 373
 374
 375 data RewritingDepth = RewriteShallow | RewriteDeep
 376 -- When a transformation proposes to rewrite a node,
 377 -- you can either ask the system to
 378 --  * "shallow": accept the new graph, analyse it without further rewriting
 379 --  * "deep": recursively analyse-and-rewrite the new graph
 380
 381
 382 -- There are currently four instances, but there could be more
 383 --      forward, backward (instantiates transfers, fixedpt, rewrites)
 384 --      Graph, AGraph     (instantiates graph)
 385
 386 instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites
 387   where zdfRewriteFrom = rewrite_f_agraph
 388
 389 instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites
 390   where zdfRewriteFrom = rewrite_b_agraph
 391
 392
 393 {- =================== IMPLEMENTATIONS ===================== -}
 394
 395
 396 -----------------------------------------------------------
 397 --      solve_f: forward, pure
 398
 399 solve_f         :: (DebugNodes m l, Outputable a)
 400                 => BlockEnv a        -- initial facts (unbound == bottom)
 401                 -> PassName
 402                 -> DataflowLattice a -- lattice
 403                 -> ForwardTransfers m l a   -- dataflow transfer functions
 404                 -> a
 405                 -> Graph m l         -- graph to be analyzed
 406                 -> FuelMonad (ForwardFixedPoint m l a ())  -- answers
 407 solve_f env name lattice transfers in_fact g =
 408    runDFM lattice $ fwd_pure_anal name env transfers in_fact g
 409
 410 rewrite_f_agraph :: (DebugNodes m l, Outputable a)
 411                  => RewritingDepth
 412                  -> BlockEnv a
 413                  -> PassName
 414                  -> DataflowLattice a
 415                  -> ForwardTransfers m l a
 416                  -> ForwardRewrites  m l a
 417                  -> a                 -- fact flowing in (at entry or exit)
 418                  -> Graph m l
 419                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
 420 rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
 421     runDFM lattice $
 422     do fuel <- fuelRemaining
 423        (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name
 424                       transfers rewrites in_fact g fuel
 425        fuelDecrement name fuel fuel'
 426        return fp
 427
 428 areturn :: AGraph m l -> DFM a (Graph m l)
 429 areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
 430
 431 -- | Here we prefer not simply to slap on 'goto eid' because this
 432 -- introduces an unnecessary basic block at each rewrite, and we don't
 433 -- want to stress out the finite map more than necessary
 434 lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
 435 lgraphToGraph (LGraph eid _ blocks) =
 436     if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then
 437         Graph (ZLast (mkBranchNode eid)) blocks
 438     else -- common case: entry is not a branch target
 439         let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
 440         in  Graph entry (delFromUFM blocks eid)
 441
 442
 443 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
 444
 445 fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
 446              => PassName
 447              -> BlockEnv a
 448              -> ForwardTransfers m l a
 449              -> a
 450              -> Graph m l
 451              -> DFM a (ForwardFixedPoint m l a ())
 452
 453 fwd_pure_anal name env transfers in_fact g =
 454     do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
 455        return fp
 456   where -- definitiely a case of "I love lazy evaluation"
 457     anal_f = forward_sol (\_ _ -> Nothing) panic_depth
 458     panic_rewrites = panic "pure analysis asked for a rewrite function"
 459     panic_fuel     = panic "pure analysis asked for fuel"
 460     panic_depth    = panic "pure analysis asked for a rewrite depth"
 461
 462 -----------------------------------------------------------------------
 463 --
 464 --      Here beginneth the super-general functions
 465 --
 466 --  Think of them as (typechecked) macros
 467 --   *  They are not exported
 468 --
 469 --   *  They are called by the specialised wrappers
 470 --      above, and always inlined into their callers
 471 --
 472 -- There are four functions, one for each combination of:
 473 --      Forward, Backward
 474 --      Solver, Rewriter
 475 --
 476 -- A "solver" produces a (DFM f (f, Fuel)),
 477 --      where f is the fact at entry(Bwd)/exit(Fwd)
 478 --      and from the DFM you can extract
 479 --              the BlockId->f
 480 --              the change-flag
 481 --              and more besides
 482 --
 483 -- A "rewriter" produces a rewritten *Graph* as well
 484 --
 485 -- Both constrain their rewrites by
 486 --      a) Fuel
 487 --      b) RewritingDepth: shallow/deep
 488
 489 -----------------------------------------------------------------------
 490
 491 type Fuel = OptimizationFuel
 492
 493 {-# INLINE forward_sol #-}
 494 forward_sol
 495         :: forall m l a .
 496            (DebugNodes m l, LastNode l, Outputable a)
 497         => (forall a . Fuel -> Maybe a -> Maybe a)
 498                 -- Squashes proposed rewrites if there is
 499                 -- no more fuel; OR if we are doing a pure
 500                 -- analysis, so totally ignore the rewrite
 501                 -- ie. For pure-analysis the fn is (\_ _ -> Nothing)
 502         -> RewritingDepth       -- Shallow/deep
 503         -> PassName
 504         -> BlockEnv a           -- Initial set of facts
 505         -> ForwardTransfers m l a
 506         -> ForwardRewrites m l a
 507         -> a                    -- Entry fact
 508         -> Graph m l
 509         -> Fuel
 510         -> DFM a (ForwardFixedPoint m l a (), Fuel)
 511 forward_sol check_maybe = forw
 512  where
 513   forw :: RewritingDepth
 514        -> PassName
 515        -> BlockEnv a
 516        -> ForwardTransfers m l a
 517        -> ForwardRewrites m l a
 518        -> a
 519        -> Graph m l
 520        -> Fuel
 521        -> DFM a (ForwardFixedPoint m l a (), Fuel)
 522   forw rewrite name start_facts transfers rewrites =
 523    let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
 524        anal_f finish in' g =
 525            do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
 526
 527        solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
 528        solve finish in_fact (Graph entry blockenv) fuel =
 529          let blocks = G.postorder_dfs_from blockenv entry
 530              set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
 531              set_successor_facts (Block id _ tail) fuel =
 532                do { idfact <- getFact id
 533                   ; (last_outs, fuel) <-
 534                       case check_maybe fuel $ fr_first rewrites idfact id of
 535                         Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
 536                         Just g ->
 537                           do g <- areturn g
 538                              (a, fuel) <- subAnalysis' $
 539                                case rewrite of
 540                                  RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)
 541                                  RewriteShallow ->
 542                                      do { a <- anal_f getExitFact idfact g
 543                                         ; return (a, oneLessFuel fuel) }
 544                              solve_tail a tail fuel
 545                   ; set_or_save last_outs
 546                   ; return fuel }
 547
 548          in do { (last_outs, fuel) <- solve_tail in_fact entry fuel
 549                ; set_or_save last_outs
 550                ; fuel <- run "forward" name set_successor_facts blocks fuel
 551                ; b <- finish
 552                ; return (b, fuel)
 553                }
 554
 555        solve_tail in' (G.ZTail m t) fuel =
 556          case check_maybe fuel $ fr_middle rewrites in' m of
 557            Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
 558            Just g ->
 559              do { g <- areturn g
 560                 ; (a, fuel) <- subAnalysis' $
 561                      case rewrite of
 562                        RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)
 563                        RewriteShallow -> do { a <- anal_f getExitFact in' g
 564                                             ; return (a, oneLessFuel fuel) }
 565                 ; solve_tail a t fuel
 566                 }
 567        solve_tail in' (G.ZLast l) fuel =
 568          case check_maybe fuel $ either_last rewrites in' l of
 569            Nothing ->
 570                case l of LastOther l -> return (ft_last_outs transfers in' l, fuel)
 571                          LastExit -> do { setExitFact (ft_exit_out transfers in')
 572                                         ; return (LastOutFacts [], fuel) }
 573            Just g ->
 574              do { g <- areturn g
 575                 ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
 576                     case rewrite of
 577                       RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)
 578                       RewriteShallow -> do { los <- anal_f lastOutFacts in' g
 579                                            ; return (los, fuel) }
 580                 ; return (last_outs, fuel)
 581                 }
 582
 583        fixed_point in_fact g fuel =
 584          do { setAllFacts start_facts
 585             ; (a, fuel) <- solve getExitFact in_fact g fuel
 586             ; facts <- getAllFacts
 587             ; last_outs <- lastOutFacts
 588             ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
 589             ; let fp = FFP cfp last_outs
 590             ; return (fp, fuel)
 591             }
 592
 593        either_last rewrites in' (LastExit) = fr_exit rewrites in'
 594        either_last rewrites in' (LastOther l) = fr_last rewrites in' l
 595
 596    in fixed_point
 597
 598
 599
 600
 601 mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
 602                   (BlockId -> Bool) -> LastOutFacts a -> df a ()
 603 mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
 604     where set_or_save_one (id, a) =
 605               if is_local id then setFact id a else addLastOutFact (id, a)
 606
 607
 608
 609
 610 {-# INLINE forward_rew #-}
 611 forward_rew
 612         :: forall m l a .
 613            (DebugNodes m l, LastNode l, Outputable a)
 614         => (forall a . Fuel -> Maybe a -> Maybe a)
 615         -> RewritingDepth
 616         -> BlockEnv a
 617         -> PassName
 618         -> ForwardTransfers m l a
 619         -> ForwardRewrites m l a
 620         -> a
 621         -> Graph m l
 622         -> Fuel
 623         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 624 forward_rew check_maybe = forw
 625   where
 626     solve = forward_sol check_maybe
 627     forw :: RewritingDepth
 628          -> BlockEnv a
 629          -> PassName
 630          -> ForwardTransfers m l a
 631          -> ForwardRewrites m l a
 632          -> a
 633          -> Graph m l
 634          -> Fuel
 635          -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 636     forw depth xstart_facts name transfers rewrites in_factx gx fuelx =
 637       let rewrite :: BlockEnv a -> DFM a b
 638                   -> a -> Graph m l -> Fuel
 639                   -> DFM a (b, Graph m l, Fuel)
 640           rewrite start finish in_fact g fuel =
 641             let Graph entry blockenv = g
 642                 blocks = G.postorder_dfs_from blockenv entry
 643             in do { solve depth name start transfers rewrites in_fact g fuel
 644                   ; eid <- freshBlockId "temporary entry id"
 645                   ; (rewritten, fuel) <-
 646                       rew_tail (ZFirst eid Nothing) in_fact entry emptyBlockEnv fuel
 647                   ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
 648                   ; a <- finish
 649                   ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
 650                   }
 651           don't_rewrite facts finish in_fact g fuel =
 652               do  { solve depth name facts transfers rewrites in_fact g fuel
 653                   ; a <- finish
 654                   ; return (a, g, fuel)
 655                   }
 656           inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
 657           inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
 658               where inner_rew' = case depth of RewriteShallow -> don't_rewrite
 659                                                RewriteDeep    -> rewrite
 660           fixed_pt_and_fuel =
 661               do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
 662                  ; facts <- getAllFacts
 663                  ; changed <- graphWasRewritten
 664                  ; last_outs <- lastOutFacts
 665                  ; let cfp = FP facts a changed (panic "no decoration?!") g
 666                  ; let fp = FFP cfp last_outs
 667                  ; return (fp, fuel)
 668                  }
 669           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
 670                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
 671           rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
 672           rewrite_blocks (G.Block id off t : bs) rewritten fuel =
 673             do let h = ZFirst id off
 674                a <- getFact id
 675                case check_maybe fuel $ fr_first rewrites a id of
 676                  Nothing -> do { (rewritten, fuel) <-
 677                                     rew_tail h (ft_first_out transfers a id)
 678                                              t rewritten fuel
 679                                ; rewrite_blocks bs rewritten fuel }
 680                  Just g  -> do { markGraphRewritten
 681                                ; g <- areturn g
 682                                ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
 683                                ; let (blocks, h) = splice_head' h g
 684                                ; (rewritten, fuel) <-
 685                                  rew_tail h outfact t (blocks `plusUFM` rewritten) fuel
 686                                ; rewrite_blocks bs rewritten fuel }
 687
 688           rew_tail head in' (G.ZTail m t) rewritten fuel =
 689             my_trace "Rewriting middle node" (ppr m) $
 690             case check_maybe fuel $ fr_middle rewrites in' m of
 691               Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
 692                          rewritten fuel
 693               Just g -> do { markGraphRewritten
 694                            ; g <- areturn g
 695                            ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
 696                            ; let (blocks, h) = G.splice_head' head g
 697                            ; rew_tail h a t (blocks `plusUFM` rewritten) fuel
 698                            }
 699           rew_tail h in' (G.ZLast l) rewritten fuel =
 700             my_trace "Rewriting last node" (ppr l) $
 701             case check_maybe fuel $ either_last rewrites in' l of
 702               Nothing -> do check_facts in' l
 703                             return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
 704               Just g -> do { markGraphRewritten
 705                            ; g <- areturn g
 706                            ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
 707                            ; let g' = G.splice_head_only' h g
 708                            ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
 709                            }
 710           either_last rewrites in' (LastExit) = fr_exit rewrites in'
 711           either_last rewrites in' (LastOther l) = fr_last rewrites in' l
 712           check_facts in' (LastOther l) =
 713             let LastOutFacts last_outs = ft_last_outs transfers in' l
 714             in mapM (uncurry checkFactMatch) last_outs
 715           check_facts _ LastExit = return []
 716       in  fixed_pt_and_fuel
 717
 718 lastOutFacts :: DFM f (LastOutFacts f)
 719 lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
 720
 721 {- ================================================================ -}
 722
 723 solve_b         :: (DebugNodes m l, Outputable a)
 724                 => BlockEnv a        -- initial facts (unbound == bottom)
 725                 -> PassName
 726                 -> DataflowLattice a -- lattice
 727                 -> BackwardTransfers m l a   -- dataflow transfer functions
 728                 -> a                 -- exit fact
 729                 -> Graph m l         -- graph to be analyzed
 730                 -> FuelMonad (BackwardFixedPoint m l a ())  -- answers
 731 solve_b env name lattice transfers exit_fact g =
 732    runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
 733
 734
 735 rewrite_b_agraph :: (DebugNodes m l, Outputable a)
 736                  => RewritingDepth
 737                  -> BlockEnv a
 738                  -> PassName
 739                  -> DataflowLattice a
 740                  -> BackwardTransfers m l a
 741                  -> BackwardRewrites m l a
 742                  -> a                 -- fact flowing in at exit
 743                  -> Graph m l
 744                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
 745 rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
 746     runDFM lattice $
 747     do fuel <- fuelRemaining
 748        (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name
 749                       transfers rewrites g exit_fact fuel
 750        fuelDecrement name fuel fuel'
 751        return fp
 752
 753
 754
 755 {-# INLINE backward_sol #-}
 756 backward_sol
 757         :: forall m l a .
 758            (DebugNodes m l, LastNode l, Outputable a)
 759         => (forall a . Fuel -> Maybe a -> Maybe a)
 760         -> RewritingDepth
 761         -> PassName
 762         -> BlockEnv a
 763         -> BackwardTransfers m l a
 764         -> BackwardRewrites m l a
 765         -> Graph m l
 766         -> a
 767         -> Fuel
 768         -> DFM a (BackwardFixedPoint m l a (), Fuel)
 769 backward_sol check_maybe = back
 770  where
 771   back :: RewritingDepth
 772        -> PassName
 773        -> BlockEnv a
 774        -> BackwardTransfers m l a
 775        -> BackwardRewrites m l a
 776        -> Graph m l
 777        -> a
 778        -> Fuel
 779        -> DFM a (BackwardFixedPoint m l a (), Fuel)
 780   back rewrite name start_facts transfers rewrites =
 781    let anal_b :: Graph m l -> a -> DFM a a
 782        anal_b g out =
 783            do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
 784               ; return $ zdfFpOutputFact fp }
 785
 786        subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel)
 787        subsolve =
 788          case rewrite of
 789            RewriteDeep    -> \g a fuel ->
 790                subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) }
 791            RewriteShallow -> \g a fuel ->
 792                subAnalysis' $ do { g <- areturn g; a <- anal_b g a
 793                                  ; return (a, oneLessFuel fuel) }
 794
 795        solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
 796        solve (Graph entry blockenv) exit_fact fuel =
 797          let blocks = reverse $ G.postorder_dfs_from blockenv entry
 798              last_in  _env (LastExit)    = exit_fact
 799              last_in   env (LastOther l) = bt_last_in transfers env l
 800              last_rew _env (LastExit)    = br_exit rewrites
 801              last_rew  env (LastOther l) = br_last rewrites env l
 802              set_block_fact block fuel =
 803                  let (h, l) = G.goto_end (G.unzip block) in
 804                  do { env <- factsEnv
 805                     ; (a, fuel) <-
 806                       case check_maybe fuel $ last_rew env l of
 807                         Nothing -> return (last_in env l, fuel)
 808                         Just g -> subsolve g exit_fact fuel
 809                     ; set_head_fact h a fuel
 810                     ; return fuel }
 811
 812          in do { fuel <- run "backward" name set_block_fact blocks fuel
 813                ; eid <- freshBlockId "temporary entry id"
 814                ; fuel <- set_block_fact (Block eid Nothing entry) fuel
 815                ; a <- getFact eid
 816                ; forgetFact eid
 817                ; return (a, fuel)
 818                }
 819
 820        set_head_fact (G.ZFirst id _) a fuel =
 821          case check_maybe fuel $ br_first rewrites a id of
 822            Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+>
 823                                                      ppr (bt_first_in transfers a id)) $
 824                            setFact id $ bt_first_in transfers a id
 825                          ; return fuel }
 826            Just g  -> do { (a, fuel) <- subsolve g a fuel
 827                          ; setFact id a
 828                          ; return fuel
 829                          }
 830        set_head_fact (G.ZHead h m) a fuel =
 831          case check_maybe fuel $ br_middle rewrites a m of
 832            Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
 833            Just g -> do { (a, fuel) <- subsolve g a fuel
 834                         ; set_head_fact h a fuel }
 835
 836        fixed_point g exit_fact fuel =
 837          do { setAllFacts start_facts
 838             ; (a, fuel) <- solve g exit_fact fuel
 839             ; facts <- getAllFacts
 840             ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
 841             ; return (cfp, fuel)
 842             }
 843    in fixed_point
 844
 845 bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
 846              => PassName
 847              -> BlockEnv a
 848              -> BackwardTransfers m l a
 849              -> Graph m l
 850              -> a
 851              -> DFM a (BackwardFixedPoint m l a ())
 852
 853 bwd_pure_anal name env transfers g exit_fact =
 854     do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
 855        return fp
 856   where -- another case of "I love lazy evaluation"
 857     anal_b = backward_sol (\_ _ -> Nothing) panic_depth
 858     panic_rewrites = panic "pure analysis asked for a rewrite function"
 859     panic_fuel     = panic "pure analysis asked for fuel"
 860     panic_depth    = panic "pure analysis asked for a rewrite depth"
 861
 862
 863 {- ================================================================ -}
 864
 865 {-# INLINE backward_rew #-}
 866 backward_rew
 867         :: forall m l a .
 868            (DebugNodes m l, LastNode l, Outputable a)
 869         => (forall a . Fuel -> Maybe a -> Maybe a)
 870         -> RewritingDepth
 871         -> BlockEnv a
 872         -> PassName
 873         -> BackwardTransfers m l a
 874         -> BackwardRewrites m l a
 875         -> Graph m l
 876         -> a
 877         -> Fuel
 878         -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
 879 backward_rew check_maybe = back
 880   where
 881     solve = backward_sol check_maybe
 882     back :: RewritingDepth
 883          -> BlockEnv a
 884          -> PassName
 885          -> BackwardTransfers m l a
 886          -> BackwardRewrites m l a
 887          -> Graph m l
 888          -> a
 889          -> Fuel
 890          -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
 891     back depth xstart_facts name transfers rewrites gx exit_fact fuelx =
 892       let rewrite :: BlockEnv a
 893                   -> Graph m l -> a -> Fuel
 894                   -> DFM a (a, Graph m l, Fuel)
 895           rewrite start g exit_fact fuel =
 896            let Graph entry blockenv = g
 897                blocks = reverse $ G.postorder_dfs_from blockenv entry
 898            in do { (FP env in_fact _ _ _, _) <-    -- don't drop the entry fact!
 899                      solve depth name start transfers rewrites g exit_fact fuel
 900                  --; env <- getAllFacts
 901                  ; my_trace "facts after solving" (ppr env) $ return ()
 902                  ; eid <- freshBlockId "temporary entry id"
 903                  ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
 904                  -- We can't have the fact check fail on the bogus entry, which _may_ change
 905                  ; (rewritten, fuel) <- rewrite_blocks False [Block eid Nothing entry] rewritten fuel
 906                  ; my_trace "eid" (ppr eid) $ return ()
 907                  ; my_trace "exit_fact" (ppr exit_fact) $ return ()
 908                  ; my_trace "in_fact" (ppr in_fact) $ return ()
 909                  ; return (in_fact, lgraphToGraph (LGraph eid 0 rewritten), fuel)
 910                  } -- Remember: the entry fact computed by @solve@ accounts for rewriting
 911           don't_rewrite facts g exit_fact fuel =
 912             do { (fp, _) <-
 913                      solve depth name facts transfers rewrites g exit_fact fuel
 914                ; return (zdfFpOutputFact fp, g, fuel) }
 915           inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
 916           inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f
 917               where inner_rew' = case depth of RewriteShallow -> don't_rewrite
 918                                                RewriteDeep    -> rewrite
 919           fixed_pt_and_fuel =
 920               do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
 921                  ; facts <- getAllFacts
 922                  ; changed <- graphWasRewritten
 923                  ; let fp = FP facts a changed (panic "no decoration?!") g
 924                  ; return (fp, fuel)
 925                  }
 926           rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l))
 927                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
 928           rewrite_blocks check bs rewritten fuel =
 929               do { env <- factsEnv
 930                  ; let rew [] r f = return (r, f)
 931                        rew (b : bs) r f =
 932                            do { (r, f) <- rewrite_block check env b r f; rew bs r f }
 933                  ; rew bs rewritten fuel }
 934           rewrite_block check env b rewritten fuel =
 935             let (h, l) = G.goto_end (G.unzip b) in
 936             case maybeRewriteWithFuel fuel $ either_last env l of
 937               Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
 938               Just g ->
 939                 do { markGraphRewritten
 940                    ; g <- areturn g
 941                    ; (a, g, fuel) <- inner_rew g exit_fact fuel
 942                    ; let G.Graph t new_blocks = g
 943                    ; let rewritten' = new_blocks `plusUFM` rewritten
 944                    ; propagate check fuel h a t rewritten' -- continue at entry of g
 945                    }
 946           either_last _env (LastExit)    = br_exit rewrites
 947           either_last  env (LastOther l) = br_last rewrites env l
 948           last_in _env (LastExit)    = exit_fact
 949           last_in  env (LastOther l) = bt_last_in transfers env l
 950           propagate check fuel (ZHead h m) a tail rewritten =
 951             case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
 952               Nothing ->
 953                 propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
 954               Just g  ->
 955                 do { markGraphRewritten
 956                    ; g <- areturn g
 957                    ; my_trace "With Facts" (ppr a) $ return ()
 958                    ; my_trace "  Rewrote middle node"
 959                                              (f4sep [ppr m, text "to", pprGraph g]) $
 960                      return ()
 961                    ; (a, g, fuel) <- inner_rew g a fuel
 962                    ; let Graph t newblocks = G.splice_tail g tail
 963                    ; my_trace "propagating facts" (ppr a) $
 964                      propagate check fuel h a t (newblocks `plusUFM` rewritten) }
 965           propagate check fuel (ZFirst id off) a tail rewritten =
 966             case maybeRewriteWithFuel fuel $ br_first rewrites a id of
 967               Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id
 968                               else return ()
 969                             ; return (insertBlock (Block id off tail) rewritten, fuel) }
 970               Just g ->
 971                 do { markGraphRewritten
 972                    ; g <- areturn g
 973                    ; my_trace "Rewrote first node"
 974                      (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
 975                    ; (a, g, fuel) <- inner_rew g a fuel
 976                    ; if check then checkFactMatch id a else return ()
 977                    ; let Graph t newblocks = G.splice_tail g tail
 978                    ; let r = insertBlock (Block id off t) (newblocks `plusUFM` rewritten)
 979                    ; return (r, fuel) }
 980       in  fixed_pt_and_fuel
 981
 982 {- ================================================================ -}
 983
 984 instance FixedPoint CommonFixedPoint where
 985     zdfFpFacts        = fp_facts
 986     zdfFpOutputFact   = fp_out
 987     zdfGraphChanged   = fp_changed
 988     zdfDecoratedGraph = fp_dec_graph
 989     zdfFpContents     = fp_contents
 990     zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
 991
 992 instance FixedPoint ForwardFixedPoint where
 993     zdfFpFacts        = fp_facts     . ffp_common
 994     zdfFpOutputFact   = fp_out       . ffp_common
 995     zdfGraphChanged   = fp_changed   . ffp_common
 996     zdfDecoratedGraph = fp_dec_graph . ffp_common
 997     zdfFpContents     = fp_contents  . ffp_common
 998     zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los
 999
1000
1001 dump_things :: Bool
1002 dump_things = True
1003
1004 my_trace :: String -> SDoc -> a -> a
1005 my_trace = if dump_things then pprTrace else \_ _ a -> a
1006
1007
1008 -- | Here's a function to run an action on blocks until we reach a fixed point.
1009 run :: (Outputable a, DebugNodes m l) =>
1010        String -> String -> (Block m l -> b -> DFM a b) -> [Block m l] -> b -> DFM a b
1011 run dir name do_block blocks b =
1012    do { show_blocks $ iterate (1::Int) }
1013    where
1014      -- N.B. Each iteration starts with the same transaction limit;
1015      -- only the rewrites in the final iteration actually count
1016      trace_block b block =
1017          my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
1018          do_block block b
1019      iterate n =
1020          do { markFactsUnchanged
1021             ; b <- foldM trace_block b blocks
1022             ; changed <- factsStatus
1023             ; facts <- getAllFacts
1024             ; let depth = 0 -- was nesting depth
1025             ; ppIter depth n $
1026               case changed of
1027                 NoChange -> unchanged depth $ return b
1028                 SomeChange ->
1029                     pprFacts depth n facts $
1030                     if n < 1000 then iterate (n+1)
1031                     else panic $ msg n
1032             }
1033      msg n = concat [name, " didn't converge in ", show n, " " , dir,
1034                      " iterations"]
1035      my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
1036      ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
1037      pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
1038      unchanged depth =
1039        my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
1040
1041      graphId = case blocks of { Block id _ _ : _ -> ppr id ; [] -> text "<empty>" }
1042      show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
1043      pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
1044      pprFacts depth n env =
1045          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
1046                         (nest 2 $ vcat $ map pprFact $ ufmToList env))
1047      pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
1048      pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a)
1049
1050
1051 f4sep :: [SDoc] -> SDoc
1052 f4sep [] = fsep []
1053 f4sep (d:ds) = fsep (d : map (nest 4) ds)
1054
1055
1056 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
1057                 m f a -> m f a
1058 subAnalysis' m =
1059     do { a <- subAnalysis $
1060                do { a <- m; facts <- getAllFacts
1061                   ; my_trace "after sub-analysis facts are" (pprFacts facts) $
1062                     return a }
1063        ; facts <- getAllFacts
1064        ; my_trace "in parent analysis facts are" (pprFacts facts) $
1065          return a }
1066   where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
1067         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)