compiler/cmm/ZipDataflow.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
   2 {-# OPTIONS -fno-allow-overlapping-instances -fglasgow-exts #-}
   3 -- -fglagow-exts for kind signatures
   4
   5 module ZipDataflow
   6     ( zdfSolveFrom, zdfRewriteFrom
   7     , ForwardTransfers(..), BackwardTransfers(..)
   8     , ForwardRewrites(..),  BackwardRewrites(..)
   9     , ForwardFixedPoint, BackwardFixedPoint
  10     , zdfFpFacts
  11     , zdfFpOutputFact
  12     , zdfGraphChanged
  13     , zdfDecoratedGraph -- not yet implemented
  14     , zdfFpContents
  15     , zdfFpLastOuts
  16     )
  17 where
  18
  19 import CmmTx
  20 import DFMonad
  21 import MkZipCfg
  22 import ZipCfg
  23 import qualified ZipCfg as G
  24
  25 import Maybes
  26 import Outputable
  27 import Panic
  28 import UniqFM
  29 import UniqSupply
  30
  31 import Control.Monad
  32 import Maybe
  33
  34
  35 type PassName = String
  36 type Fuel = OptimizationFuel
  37
  38 data RewritingDepth = RewriteShallow | RewriteDeep
  39 -- When a transformation proposes to rewrite a node,
  40 -- you can either ask the system to
  41 --  * "shallow": accept the new graph, analyse it without further rewriting
  42 --  * "deep": recursively analyse-and-rewrite the new graph
  43
  44 -----------------------------
  45 -- zdfSolveFrom is a pure analysis with no rewriting
  46
  47 class DataflowSolverDirection transfers fixedpt where
  48   zdfSolveFrom   :: (DebugNodes m l, Outputable a)
  49                  => BlockEnv a        -- Initial facts (unbound == bottom)
  50                  -> PassName
  51                  -> DataflowLattice a -- Lattice
  52                  -> transfers m l a   -- Dataflow transfer functions
  53                  -> a                 -- Fact flowing in (at entry or exit)
  54                  -> Graph m l         -- Graph to be analyzed
  55                  -> fixedpt m l a ()  -- Answers
  56
  57 -- There are exactly two instances: forward and backward
  58 instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
  59   where zdfSolveFrom = solve_f
  60
  61 instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
  62   where zdfSolveFrom = solve_b
  63
  64 data ForwardTransfers middle last a = ForwardTransfers
  65     { ft_first_out  :: a -> BlockId -> a
  66     , ft_middle_out :: a -> middle  -> a
  67     , ft_last_outs  :: a -> last    -> LastOutFacts a
  68     , ft_exit_out   :: a            -> a
  69     }
  70
  71 newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
  72   -- ^ These are facts flowing out of a last node to the node's successors.
  73   -- They are either to be set (if they pertain to the graph currently
  74   -- under analysis) or propagated out of a sub-analysis
  75
  76 data BackwardTransfers middle last a = BackwardTransfers
  77     { bt_first_in  :: a              -> BlockId -> a
  78     , bt_middle_in :: a              -> middle  -> a
  79     , bt_last_in   :: (BlockId -> a) -> last    -> a
  80     }
  81
  82 data CommonFixedPoint m l fact a = FP
  83     { fp_facts     :: BlockEnv fact
  84     , fp_out       :: fact  -- entry for backward; exit for forward
  85     , fp_changed   :: ChangeFlag
  86     , fp_dec_graph :: Graph (fact, m) (fact, l)
  87     , fp_contents  :: a
  88     }
  89
  90 type BackwardFixedPoint = CommonFixedPoint
  91
  92 data ForwardFixedPoint m l fact a = FFP
  93     { ffp_common    :: CommonFixedPoint m l fact a
  94     , zdfFpLastOuts :: LastOutFacts fact
  95     }
  96
  97 -----------------------------
  98 -- zdfRewriteFrom is an interleaved analysis and transformation
  99
 100 class DataflowSolverDirection transfers fixedpt =>
 101       DataflowDirection transfers fixedpt rewrites
 102                         (graph :: * -> * -> *) where
 103   zdfRewriteFrom :: (DebugNodes m l, Outputable a)
 104                  => RewritingDepth
 105                  -> BlockEnv a
 106                  -> PassName
 107                  -> DataflowLattice a
 108                  -> transfers m l a
 109                  -> rewrites m l a graph
 110                  -> a                 -- fact flowing in (at entry or exit)
 111                  -> Graph m l
 112                  -> UniqSupply
 113                  -> FuelMonad (fixedpt m l a (Graph m l))
 114
 115 -- There are currently four instances, but there could be more
 116 --      forward, backward (instantiates transfers, fixedpt, rewrites)
 117 --      Graph, AGraph     (instantiates graph)
 118
 119 instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites Graph
 120   where zdfRewriteFrom = rewrite_f_graph
 121
 122 instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites AGraph
 123   where zdfRewriteFrom = rewrite_f_agraph
 124
 125 instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites Graph
 126   where zdfRewriteFrom = rewrite_b_graph
 127
 128 instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites AGraph
 129   where zdfRewriteFrom = rewrite_b_agraph
 130
 131 data ForwardRewrites middle last a g = ForwardRewrites
 132     { fr_first  :: a -> BlockId -> Maybe (g middle last)
 133     , fr_middle :: a -> middle  -> Maybe (g middle last)
 134     , fr_last   :: a -> last    -> Maybe (g middle last)
 135     , fr_exit   :: a            -> Maybe (g middle last)
 136     }
 137
 138 data BackwardRewrites middle last a g = BackwardRewrites
 139     { br_first  :: a              -> BlockId -> Maybe (g middle last)
 140     , br_middle :: a              -> middle  -> Maybe (g middle last)
 141     , br_last   :: (BlockId -> a) -> last    -> Maybe (g middle last)
 142     , br_exit   ::                              Maybe (g middle last)
 143     }
 144
 145 class FixedPoint fp where
 146     zdfFpFacts        :: fp m l fact a -> BlockEnv fact
 147     zdfFpOutputFact   :: fp m l fact a -> fact  -- entry for backward; exit for forward
 148     zdfGraphChanged   :: fp m l fact a -> ChangeFlag
 149     zdfDecoratedGraph :: fp m l fact a -> Graph (fact, m) (fact, l)
 150     zdfFpContents     :: fp m l fact a -> a
 151     zdfFpMap          :: (a -> b) -> (fp m l fact a -> fp m l fact b)
 152
 153
 154
 155 -----------------------------------------------------------
 156 --      solve_f: forward, pure
 157
 158 solve_f         :: (DebugNodes m l, Outputable a)
 159                 => BlockEnv a        -- initial facts (unbound == bottom)
 160                 -> PassName
 161                 -> DataflowLattice a -- lattice
 162                 -> ForwardTransfers m l a   -- dataflow transfer functions
 163                 -> a
 164                 -> Graph m l         -- graph to be analyzed
 165                 -> ForwardFixedPoint m l a ()  -- answers
 166 solve_f env name lattice transfers in_fact g =
 167    runWithInfiniteFuel $ runDFM panic_us lattice $
 168                          fwd_pure_anal name env transfers in_fact g
 169  where panic_us = panic "pure analysis pulled on a UniqSupply"
 170
 171 rewrite_f_graph  :: (DebugNodes m l, Outputable a)
 172                  => RewritingDepth
 173                  -> BlockEnv a
 174                  -> PassName
 175                  -> DataflowLattice a
 176                  -> ForwardTransfers m l a
 177                  -> ForwardRewrites m l a Graph
 178                  -> a                 -- fact flowing in (at entry or exit)
 179                  -> Graph m l
 180                  -> UniqSupply
 181                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
 182 rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g u =
 183     runDFM u lattice $
 184     do fuel <- fuelRemaining
 185        (fp, fuel') <- forward_rew maybeRewriteWithFuel return depth start_facts name
 186                       transfers rewrites in_fact g fuel
 187        fuelDecrement name fuel fuel'
 188        return fp
 189
 190 rewrite_f_agraph :: (DebugNodes m l, Outputable a)
 191                  => RewritingDepth
 192                  -> BlockEnv a
 193                  -> PassName
 194                  -> DataflowLattice a
 195                  -> ForwardTransfers m l a
 196                  -> ForwardRewrites m l a AGraph
 197                  -> a                 -- fact flowing in (at entry or exit)
 198                  -> Graph m l
 199                  -> UniqSupply
 200                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
 201 rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g u =
 202     runDFM u lattice $
 203     do fuel <- fuelRemaining
 204        (fp, fuel') <- forward_rew maybeRewriteWithFuel areturn depth start_facts name
 205                       transfers rewrites in_fact g fuel
 206        fuelDecrement name fuel fuel'
 207        return fp
 208
 209 areturn :: AGraph m l -> DFM a (Graph m l)
 210 areturn g = liftUSM $ graphOfAGraph g
 211
 212
 213 {-
 214 graphToLGraph :: LastNode l => Graph m l -> DFM a (LGraph m l)
 215 graphToLGraph (Graph (ZLast (LastOther l)) blockenv)
 216     | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv
 217 graphToLGraph (Graph tail blockenv) =
 218     do id <- freshBlockId "temporary entry label"
 219        return $ LGraph id $ insertBlock (Block id tail) blockenv
 220 -}
 221
 222 -- | Here we prefer not simply to slap on 'goto eid' because this
 223 -- introduces an unnecessary basic block at each rewrite, and we don't
 224 -- want to stress out the finite map more than necessary
 225 lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
 226 lgraphToGraph (LGraph eid blocks) =
 227     if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then
 228         Graph (ZLast (mkBranchNode eid)) blocks
 229     else -- common case: entry is not a branch target
 230         let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
 231         in  Graph entry (delFromUFM blocks eid)
 232
 233
 234 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
 235
 236 fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
 237              => PassName
 238              -> BlockEnv a
 239              -> ForwardTransfers m l a
 240              -> a
 241              -> Graph m l
 242              -> DFM a (ForwardFixedPoint m l a ())
 243
 244 fwd_pure_anal name env transfers in_fact g =
 245     do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
 246        return fp
 247   where -- definitiely a case of "I love lazy evaluation"
 248     anal_f = forward_sol (\_ _ -> Nothing) panic_return panic_depth
 249     panic_rewrites = panic "pure analysis asked for a rewrite function"
 250     panic_fuel     = panic "pure analysis asked for fuel"
 251     panic_return   = panic "pure analysis tried to return a rewritten graph"
 252     panic_depth    = panic "pure analysis asked for a rewrite depth"
 253
 254 -----------------------------------------------------------------------
 255 --
 256 --      Here beginneth the super-general functions
 257 --
 258 --  Think of them as (typechecked) macros
 259 --   *  They are not exported
 260 --
 261 --   *  They are called by the specialised wrappers
 262 --      above, and always inlined into their callers
 263 --
 264 -- There are four functions, one for each combination of:
 265 --      Forward, Backward
 266 --      Solver, Rewriter
 267 --
 268 -- A "solver" produces a (DFM f (f, Fuel)),
 269 --      where f is the fact at entry(Bwd)/exit(Fwd)
 270 --      and from the DFM you can extract
 271 --              the BlockId->f
 272 --              the change-flag
 273 --              and more besides
 274 --
 275 -- A "rewriter" produces a rewritten *Graph* as well
 276 --
 277 -- Both constrain their rewrites by
 278 --      a) Fuel
 279 --      b) RewritingDepth: shallow/deep
 280
 281 -----------------------------------------------------------------------
 282
 283
 284 {-# INLINE forward_sol #-}
 285 forward_sol
 286         :: forall m l g a .
 287            (DebugNodes m l, LastNode l, Outputable a)
 288         => (forall a . Fuel -> Maybe a -> Maybe a)
 289                 -- Squashes proposed rewrites if there is
 290                 -- no more fuel; OR if we are doing a pure
 291                 -- analysis, so totally ignore the rewrite
 292                 -- ie. For pure-analysis the fn is (\_ _ -> Nothing)
 293         -> (g m l -> DFM a (Graph m l))
 294                 -- Transforms the kind of graph 'g' wanted by the
 295                 -- client (in ForwardRewrites) to the kind forward_sol likes
 296         -> RewritingDepth       -- Shallow/deep
 297         -> PassName
 298         -> BlockEnv a           -- Initial set of facts
 299         -> ForwardTransfers m l a
 300         -> ForwardRewrites m l a g
 301         -> a                    -- Entry fact
 302         -> Graph m l
 303         -> Fuel
 304         -> DFM a (ForwardFixedPoint m l a (), Fuel)
 305 forward_sol check_maybe return_graph = forw
 306  where
 307   forw :: RewritingDepth
 308        -> PassName
 309        -> BlockEnv a
 310        -> ForwardTransfers m l a
 311        -> ForwardRewrites m l a g
 312        -> a
 313        -> Graph m l
 314        -> Fuel
 315        -> DFM a (ForwardFixedPoint m l a (), Fuel)
 316   forw rewrite name start_facts transfers rewrites =
 317    let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
 318        anal_f finish in' g =
 319            do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
 320
 321        solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
 322        solve finish in_fact (Graph entry blockenv) fuel =
 323          let blocks = G.postorder_dfs_from blockenv entry
 324              set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
 325              set_successor_facts (Block id tail) fuel =
 326                do { idfact <- getFact id
 327                   ; (last_outs, fuel) <-
 328                       case check_maybe fuel $ fr_first rewrites idfact id of
 329                         Nothing -> solve_tail idfact tail fuel
 330                         Just g ->
 331                           do g <- return_graph g
 332                              (a, fuel) <- subAnalysis' $
 333                                case rewrite of
 334                                  RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)
 335                                  RewriteShallow ->
 336                                      do { a <- anal_f getExitFact idfact g
 337                                         ; return (a, oneLessFuel fuel) }
 338                              solve_tail a tail fuel
 339                   ; set_or_save last_outs
 340                   ; return fuel }
 341
 342          in do { (last_outs, fuel) <- solve_tail in_fact entry fuel
 343                ; set_or_save last_outs
 344                ; fuel <- run "forward" name set_successor_facts blocks fuel
 345                ; b <- finish
 346                ; return (b, fuel)
 347                }
 348
 349        solve_tail in' (G.ZTail m t) fuel =
 350          case check_maybe fuel $ fr_middle rewrites in' m of
 351            Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
 352            Just g ->
 353              do { g <- return_graph g
 354                 ; (a, fuel) <- subAnalysis' $
 355                      case rewrite of
 356                        RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)
 357                        RewriteShallow -> do { a <- anal_f getExitFact in' g
 358                                             ; return (a, oneLessFuel fuel) }
 359                 ; solve_tail a t fuel
 360                 }
 361        solve_tail in' (G.ZLast l) fuel =
 362          case check_maybe fuel $ either_last rewrites in' l of
 363            Nothing ->
 364                case l of LastOther l -> return (ft_last_outs transfers in' l, fuel)
 365                          LastExit -> do { setExitFact (ft_exit_out transfers in')
 366                                         ; return (LastOutFacts [], fuel) }
 367            Just g ->
 368              do { g <- return_graph g
 369                 ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
 370                     case rewrite of
 371                       RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)
 372                       RewriteShallow -> do { los <- anal_f lastOutFacts in' g
 373                                            ; return (los, fuel) }
 374                 ; return (last_outs, fuel)
 375                 }
 376
 377        fixed_point in_fact g fuel =
 378          do { setAllFacts start_facts
 379             ; (a, fuel) <- solve getExitFact in_fact g fuel
 380             ; facts <- getAllFacts
 381             ; last_outs <- lastOutFacts
 382             ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
 383             ; let fp = FFP cfp last_outs
 384             ; return (fp, fuel)
 385             }
 386
 387        either_last rewrites in' (LastExit) = fr_exit rewrites in'
 388        either_last rewrites in' (LastOther l) = fr_last rewrites in' l
 389
 390    in fixed_point
 391
 392
 393
 394
 395 mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
 396                   (BlockId -> Bool) -> LastOutFacts a -> df a ()
 397 mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
 398     where set_or_save_one (id, a) =
 399               if is_local id then setFact id a else addLastOutFact (id, a)
 400
 401
 402
 403
 404 {-# INLINE forward_rew #-}
 405 forward_rew
 406         :: forall m l g a .
 407            (DebugNodes m l, LastNode l, Outputable a)
 408         => (forall a . Fuel -> Maybe a -> Maybe a)
 409         -> (g m l -> DFM a (Graph m l))  -- option on what to rewrite
 410         -> RewritingDepth
 411         -> BlockEnv a
 412         -> PassName
 413         -> ForwardTransfers m l a
 414         -> ForwardRewrites m l a g
 415         -> a
 416         -> Graph m l
 417         -> Fuel
 418         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 419 forward_rew check_maybe return_graph = forw
 420   where
 421     solve = forward_sol check_maybe return_graph
 422     forw :: RewritingDepth
 423          -> BlockEnv a
 424          -> PassName
 425          -> ForwardTransfers m l a
 426          -> ForwardRewrites m l a g
 427          -> a
 428          -> Graph m l
 429          -> Fuel
 430          -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 431     forw depth xstart_facts name transfers rewrites in_factx gx fuelx =
 432       let rewrite :: BlockEnv a -> DFM a b
 433                   -> a -> Graph m l -> Fuel
 434                   -> DFM a (b, Graph m l, Fuel)
 435           rewrite start finish in_fact g fuel =
 436             let Graph entry blockenv = g
 437                 blocks = G.postorder_dfs_from blockenv entry
 438             in do { solve depth name start transfers rewrites in_fact g fuel
 439                   ; eid <- freshBlockId "temporary entry id"
 440                   ; (rewritten, fuel) <-
 441                       rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
 442                   ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
 443                   ; a <- finish
 444                   ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
 445                   }
 446           don't_rewrite finish in_fact g fuel =
 447               do  { solve depth name emptyBlockEnv transfers rewrites in_fact g fuel
 448                   ; a <- finish
 449                   ; return (a, g, fuel)
 450                   }
 451           inner_rew = case depth of RewriteShallow -> don't_rewrite
 452                                     RewriteDeep -> rewrite emptyBlockEnv
 453           fixed_pt_and_fuel =
 454               do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
 455                  ; facts <- getAllFacts
 456                  ; changed <- graphWasRewritten
 457                  ; last_outs <- lastOutFacts
 458                  ; let cfp = FP facts a changed (panic "no decoration?!") g
 459                  ; let fp = FFP cfp last_outs
 460                  ; return (fp, fuel)
 461                  }
 462           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
 463                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
 464           rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
 465           rewrite_blocks (G.Block id t : bs) rewritten fuel =
 466             do let h = ZFirst id
 467                a <- getFact id
 468                case check_maybe fuel $ fr_first rewrites a id of
 469                  Nothing -> do { (rewritten, fuel) <- rew_tail h a t rewritten fuel
 470                                ; rewrite_blocks bs rewritten fuel }
 471                  Just g  -> do { markGraphRewritten
 472                                ; g <- return_graph g
 473                                ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
 474                                ; let (blocks, h) = splice_head' (ZFirst id) g
 475                                ; (rewritten, fuel) <-
 476                                  rew_tail h outfact t (blocks `plusUFM` rewritten) fuel
 477                                ; rewrite_blocks bs rewritten fuel }
 478
 479           rew_tail head in' (G.ZTail m t) rewritten fuel =
 480             my_trace "Rewriting middle node" (ppr m) $
 481             case check_maybe fuel $ fr_middle rewrites in' m of
 482               Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
 483                          rewritten fuel
 484               Just g -> do { markGraphRewritten
 485                            ; g <- return_graph g
 486                            ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
 487                            ; let (blocks, h) = G.splice_head' head g
 488                            ; rew_tail h a t (blocks `plusUFM` rewritten) fuel
 489                            }
 490           rew_tail h in' (G.ZLast l) rewritten fuel =
 491             my_trace "Rewriting last node" (ppr l) $
 492             case check_maybe fuel $ either_last rewrites in' l of
 493               Nothing -> -- can throw away facts because this is the rewriting phase
 494                          return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
 495               Just g -> do { markGraphRewritten
 496                            ; g <- return_graph g
 497                            ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
 498                            ; let g' = G.splice_head_only' h g
 499                            ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
 500                            }
 501           either_last rewrites in' (LastExit) = fr_exit rewrites in'
 502           either_last rewrites in' (LastOther l) = fr_last rewrites in' l
 503       in  fixed_pt_and_fuel
 504
 505 --lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
 506 lastOutFacts :: DFM f (LastOutFacts f)
 507 lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
 508
 509 {- ================================================================ -}
 510
 511 solve_b         :: (DebugNodes m l, Outputable a)
 512                 => BlockEnv a        -- initial facts (unbound == bottom)
 513                 -> PassName
 514                 -> DataflowLattice a -- lattice
 515                 -> BackwardTransfers m l a   -- dataflow transfer functions
 516                 -> a                 -- exit fact
 517                 -> Graph m l         -- graph to be analyzed
 518                 -> BackwardFixedPoint m l a ()  -- answers
 519 solve_b env name lattice transfers exit_fact g =
 520    runWithInfiniteFuel $ runDFM panic_us lattice $
 521                          bwd_pure_anal name env transfers g exit_fact
 522  where panic_us = panic "pure analysis pulled on a UniqSupply"
 523
 524
 525 rewrite_b_graph  :: (DebugNodes m l, Outputable a)
 526                  => RewritingDepth
 527                  -> BlockEnv a
 528                  -> PassName
 529                  -> DataflowLattice a
 530                  -> BackwardTransfers m l a
 531                  -> BackwardRewrites m l a Graph
 532                  -> a                 -- fact flowing in at exit
 533                  -> Graph m l
 534                  -> UniqSupply
 535                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
 536 rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g u =
 537     runDFM u lattice $
 538     do fuel <- fuelRemaining
 539        (fp, fuel') <- backward_rew maybeRewriteWithFuel return depth start_facts name
 540                       transfers rewrites g exit_fact fuel
 541        fuelDecrement name fuel fuel'
 542        return fp
 543
 544 rewrite_b_agraph :: (DebugNodes m l, Outputable a)
 545                  => RewritingDepth
 546                  -> BlockEnv a
 547                  -> PassName
 548                  -> DataflowLattice a
 549                  -> BackwardTransfers m l a
 550                  -> BackwardRewrites m l a AGraph
 551                  -> a                 -- fact flowing in at exit
 552                  -> Graph m l
 553                  -> UniqSupply
 554                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
 555 rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g u =
 556     runDFM u lattice $
 557     do fuel <- fuelRemaining
 558        (fp, fuel') <- backward_rew maybeRewriteWithFuel areturn depth start_facts name
 559                       transfers rewrites g exit_fact fuel
 560        fuelDecrement name fuel fuel'
 561        return fp
 562
 563
 564
 565 {-# INLINE backward_sol #-}
 566 backward_sol
 567         :: forall m l g a .
 568            (DebugNodes m l, LastNode l, Outputable a)
 569         => (forall a . Fuel -> Maybe a -> Maybe a)
 570         -> (g m l -> DFM a (Graph m l))  -- option on what to rewrite
 571         -> RewritingDepth
 572         -> PassName
 573         -> BlockEnv a
 574         -> BackwardTransfers m l a
 575         -> BackwardRewrites m l a g
 576         -> Graph m l
 577         -> a
 578         -> Fuel
 579         -> DFM a (BackwardFixedPoint m l a (), Fuel)
 580 backward_sol check_maybe return_graph = back
 581  where
 582   back :: RewritingDepth
 583        -> PassName
 584        -> BlockEnv a
 585        -> BackwardTransfers m l a
 586        -> BackwardRewrites m l a g
 587        -> Graph m l
 588        -> a
 589        -> Fuel
 590        -> DFM a (BackwardFixedPoint m l a (), Fuel)
 591   back rewrite name start_facts transfers rewrites =
 592    let anal_b :: Graph m l -> a -> DFM a a
 593        anal_b g out =
 594            do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
 595               ; return $ zdfFpOutputFact fp }
 596
 597        subsolve :: g m l -> a -> Fuel -> DFM a (a, Fuel)
 598        subsolve =
 599          case rewrite of
 600            RewriteDeep    -> \g a fuel ->
 601                subAnalysis' $ do { g <- return_graph g; solve g a (oneLessFuel fuel) }
 602            RewriteShallow -> \g a fuel ->
 603                subAnalysis' $ do { g <- return_graph g; a <- anal_b g a
 604                                  ; return (a, oneLessFuel fuel) }
 605
 606        solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
 607        solve (Graph entry blockenv) exit_fact fuel =
 608          let blocks = reverse $ G.postorder_dfs_from blockenv entry
 609              last_in  _env (LastExit)    = exit_fact
 610              last_in   env (LastOther l) = bt_last_in transfers env l
 611              last_rew _env (LastExit)    = br_exit rewrites
 612              last_rew  env (LastOther l) = br_last rewrites env l
 613              set_block_fact block fuel =
 614                  let (h, l) = G.goto_end (G.unzip block) in
 615                  do { env <- factsEnv
 616                     ; (a, fuel) <-
 617                       case check_maybe fuel $ last_rew env l of
 618                         Nothing -> return (last_in env l, fuel)
 619                         Just g -> subsolve g exit_fact fuel
 620                     ; set_head_fact h a fuel
 621                     ; return fuel }
 622
 623          in do { fuel <- run "backward" name set_block_fact blocks fuel
 624                ; eid <- freshBlockId "temporary entry id"
 625                ; fuel <- set_block_fact (Block eid entry) fuel
 626                ; a <- getFact eid
 627                ; forgetFact eid
 628                ; return (a, fuel)
 629                }
 630
 631        set_head_fact (G.ZFirst id) a fuel =
 632          case check_maybe fuel $ br_first rewrites a id of
 633            Nothing -> do { setFact id a; return fuel }
 634            Just g  -> do { (a, fuel) <- subsolve g a fuel
 635                          ; setFact id a
 636                          ; return fuel
 637                          }
 638        set_head_fact (G.ZHead h m) a fuel =
 639          case check_maybe fuel $ br_middle rewrites a m of
 640            Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
 641            Just g -> do { (a, fuel) <- subsolve g a fuel
 642                         ; set_head_fact h a fuel }
 643
 644        fixed_point g exit_fact fuel =
 645          do { setAllFacts start_facts
 646             ; (a, fuel) <- solve g exit_fact fuel
 647             ; facts <- getAllFacts
 648             ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
 649             ; return (cfp, fuel)
 650             }
 651    in fixed_point
 652
 653 bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
 654              => PassName
 655              -> BlockEnv a
 656              -> BackwardTransfers m l a
 657              -> Graph m l
 658              -> a
 659              -> DFM a (BackwardFixedPoint m l a ())
 660
 661 bwd_pure_anal name env transfers g exit_fact =
 662     do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
 663        return fp
 664   where -- another case of "I love lazy evaluation"
 665     anal_b = backward_sol (\_ _ -> Nothing) panic_return panic_depth
 666     panic_rewrites = panic "pure analysis asked for a rewrite function"
 667     panic_fuel     = panic "pure analysis asked for fuel"
 668     panic_return   = panic "pure analysis tried to return a rewritten graph"
 669     panic_depth    = panic "pure analysis asked for a rewrite depth"
 670
 671
 672 {- ================================================================ -}
 673
 674 {-# INLINE backward_rew #-}
 675 backward_rew
 676         :: forall m l g a .
 677            (DebugNodes m l, LastNode l, Outputable a)
 678         => (forall a . Fuel -> Maybe a -> Maybe a)
 679         -> (g m l -> DFM a (Graph m l))  -- option on what to rewrite
 680         -> RewritingDepth
 681         -> BlockEnv a
 682         -> PassName
 683         -> BackwardTransfers m l a
 684         -> BackwardRewrites m l a g
 685         -> Graph m l
 686         -> a
 687         -> Fuel
 688         -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
 689 backward_rew check_maybe return_graph = back
 690   where
 691     solve = backward_sol check_maybe return_graph
 692     back :: RewritingDepth
 693          -> BlockEnv a
 694          -> PassName
 695          -> BackwardTransfers m l a
 696          -> BackwardRewrites m l a g
 697          -> Graph m l
 698          -> a
 699          -> Fuel
 700          -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
 701     back depth xstart_facts name transfers rewrites gx exit_fact fuelx =
 702       let rewrite :: BlockEnv a
 703                   -> Graph m l -> a -> Fuel
 704                   -> DFM a (a, Graph m l, Fuel)
 705           rewrite start g exit_fact fuel =
 706            let Graph entry blockenv = g
 707                blocks = reverse $ G.postorder_dfs_from blockenv entry
 708            in do { solve depth name start transfers rewrites g exit_fact fuel
 709                  ; eid <- freshBlockId "temporary entry id"
 710                  ; (rewritten, fuel) <- rewrite_blocks blocks emptyBlockEnv fuel
 711                  ; (rewritten, fuel) <- rewrite_blocks [Block eid entry] rewritten fuel
 712                  ; a <- getFact eid
 713                  ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
 714                  }
 715           don't_rewrite g exit_fact fuel =
 716             do { (fp, _) <-
 717                      solve depth name emptyBlockEnv transfers rewrites g exit_fact fuel
 718                ; return (zdfFpOutputFact fp, g, fuel) }
 719           inner_rew = case depth of RewriteShallow -> don't_rewrite
 720                                     RewriteDeep    -> rewrite emptyBlockEnv
 721           inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
 722           fixed_pt_and_fuel =
 723               do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
 724                  ; facts <- getAllFacts
 725                  ; changed <- graphWasRewritten
 726                  ; let fp = FP facts a changed (panic "no decoration?!") g
 727                  ; return (fp, fuel)
 728                  }
 729           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
 730                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
 731           rewrite_blocks bs rewritten fuel =
 732               do { env <- factsEnv
 733                  ; let rew [] r f = return (r, f)
 734                        rew (b : bs) r f =
 735                            do { (r, f) <- rewrite_block env b r f; rew bs r f }
 736                  ; rew bs rewritten fuel }
 737           rewrite_block env b rewritten fuel =
 738             let (h, l) = G.goto_end (G.unzip b) in
 739             case maybeRewriteWithFuel fuel $ either_last env l of
 740               Nothing -> propagate fuel h (last_in env l) (ZLast l) rewritten
 741               Just g ->
 742                 do { markGraphRewritten
 743                    ; g <- return_graph g
 744                    ; (a, g, fuel) <- inner_rew g exit_fact fuel
 745                    ; let G.Graph t new_blocks = g
 746                    ; let rewritten' = new_blocks `plusUFM` rewritten
 747                    ; propagate fuel h a t rewritten' -- continue at entry of g
 748                    }
 749           either_last _env (LastExit)    = br_exit rewrites
 750           either_last  env (LastOther l) = br_last rewrites env l
 751           last_in _env (LastExit)    = exit_fact
 752           last_in  env (LastOther l) = bt_last_in transfers env l
 753           propagate fuel (ZHead h m) a tail rewritten =
 754             case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
 755               Nothing ->
 756                 propagate fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
 757               Just g  ->
 758                 do { markGraphRewritten
 759                    ; g <- return_graph g
 760                    ; my_trace "Rewrote middle node"
 761                                              (f4sep [ppr m, text "to", pprGraph g]) $
 762                      return ()
 763                    ; (a, g, fuel) <- inner_rew g a fuel
 764                    ; let Graph t newblocks = G.splice_tail g tail
 765                    ; propagate fuel h a t (newblocks `plusUFM` rewritten) }
 766           propagate fuel (ZFirst id) a tail rewritten =
 767             case maybeRewriteWithFuel fuel $ br_first rewrites a id of
 768               Nothing -> do { checkFactMatch id a
 769                             ; return (insertBlock (Block id tail) rewritten, fuel) }
 770               Just g ->
 771                 do { markGraphRewritten
 772                    ; g <- return_graph g
 773                    ; my_trace "Rewrote first node"
 774                      (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
 775                    ; (a, g, fuel) <- inner_rew g a fuel
 776                    ; checkFactMatch id a
 777                    ; let Graph t newblocks = G.splice_tail g tail
 778                    ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten)
 779                    ; return (r, fuel) }
 780       in  fixed_pt_and_fuel
 781
 782 {- ================================================================ -}
 783
 784 instance FixedPoint CommonFixedPoint where
 785     zdfFpFacts        = fp_facts
 786     zdfFpOutputFact   = fp_out
 787     zdfGraphChanged   = fp_changed
 788     zdfDecoratedGraph = fp_dec_graph
 789     zdfFpContents     = fp_contents
 790     zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
 791
 792 instance FixedPoint ForwardFixedPoint where
 793     zdfFpFacts        = fp_facts     . ffp_common
 794     zdfFpOutputFact   = fp_out       . ffp_common
 795     zdfGraphChanged   = fp_changed   . ffp_common
 796     zdfDecoratedGraph = fp_dec_graph . ffp_common
 797     zdfFpContents     = fp_contents  . ffp_common
 798     zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los
 799
 800
 801 dump_things :: Bool
 802 dump_things = True
 803
 804 my_trace :: String -> SDoc -> a -> a
 805 my_trace = if dump_things then pprTrace else \_ _ a -> a
 806
 807
 808 -- | Here's a function to run an action on blocks until we reach a fixed point.
 809 run :: (Outputable a, DebugNodes m l) =>
 810        String -> String -> (Block m l -> b -> DFM a b) -> [Block m l] -> b -> DFM a b
 811 run dir name do_block blocks b =
 812    do { show_blocks $ iterate (1::Int) }
 813    where
 814      -- N.B. Each iteration starts with the same transaction limit;
 815      -- only the rewrites in the final iteration actually count
 816      trace_block b block =
 817          my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
 818          do_block block b
 819      iterate n =
 820          do { markFactsUnchanged
 821             ; b <- foldM trace_block b blocks
 822             ; changed <- factsStatus
 823             ; facts <- getAllFacts
 824             ; let depth = 0 -- was nesting depth
 825             ; ppIter depth n $
 826               case changed of
 827                 NoChange -> unchanged depth $ return b
 828                 SomeChange ->
 829                     pprFacts depth n facts $
 830                     if n < 1000 then iterate (n+1)
 831                     else panic $ msg n
 832             }
 833      msg n = concat [name, " didn't converge in ", show n, " " , dir,
 834                      " iterations"]
 835      my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
 836      ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
 837      pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
 838      unchanged depth = my_nest depth (text "facts are unchanged")
 839
 840      pprFacts depth n env =
 841          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
 842                         (nest 2 $ vcat $ map pprFact $ ufmToList env))
 843      pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 844      graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
 845      show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
 846      pprBlock (Block id t) = nest 2 (pprFact (id, t))
 847
 848
 849 f4sep :: [SDoc] -> SDoc
 850 f4sep [] = fsep []
 851 f4sep (d:ds) = fsep (d : map (nest 4) ds)
 852
 853
 854 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
 855                 m f a -> m f a
 856 subAnalysis' m =
 857     do { a <- subAnalysis $
 858                do { a <- m; facts <- getAllFacts
 859                   ; my_trace "after sub-analysis facts are" (pprFacts facts) $
 860                     return a }
 861        ; facts <- getAllFacts
 862        ; my_trace "in parent analysis facts are" (pprFacts facts) $
 863          return a }
 864   where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
 865         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)