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