compiler/cmm/DFMonad.hs

   1 module DFMonad
   2     ( DataflowLattice(..) , DataflowAnalysis
   3     , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
   4                         , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv
   5     , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch
   6     , subAnalysis
   7
   8     , DFM, runDFM, liftToDFM
   9     , markGraphRewritten, graphWasRewritten
  10     , module OptimizationFuel
  11     )
  12 where
  13
  14 import BlockId
  15 import CmmTx
  16 import PprCmm()
  17 import OptimizationFuel
  18
  19 import Control.Monad
  20 import Maybes
  21 import Outputable
  22 import UniqSupply
  23
  24 {-
  25
  26 A dataflow monad maintains a mapping from BlockIds to dataflow facts,
  27 where a dataflow fact is a value of type [[a]].  Values of type [[a]]
  28 must form a lattice, as described by type [[Fact a]].
  29
  30 The dataflow engine uses the lattice structure to compute a least
  31 solution to a set of dataflow equations.  To compute a greatest
  32 solution, flip the lattice over.
  33
  34 The engine works by starting at the bottom and iterating to a fixed
  35 point, so in principle we require the bottom element, a join (least
  36 upper bound) operation, and a comparison to find out if a value has
  37 changed (grown).  In practice, the comparison is only ever used in
  38 conjunction with the join, so we have [[fact_add_to]]:
  39
  40   fact_add_to new old =
  41      let j = join new old in
  42      if j <= old then noTx old -- nothing changed
  43      else aTx j                -- the fact changed
  44
  45 -}
  46
  47 data DataflowLattice a = DataflowLattice  {
  48   fact_name       :: String,                 -- documentation
  49   fact_bot        :: a,                      -- lattice bottom element
  50   fact_add_to     :: a -> a -> TxRes a,      -- lattice join and compare
  51     -- ^ compute join of two args; something changed iff join is greater than 2nd arg
  52   fact_do_logging :: Bool                    -- log changes
  53 }
  54
  55
  56 -- DFM is the monad of combined analysis and transformation,
  57 -- which needs a UniqSupply and may consume optimization fuel
  58 -- DFM is defined using a monad transformer, DFM', which is the general
  59 -- case of DFM, parameterized over any monad.
  60 -- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and
  61 -- the unique supply.
  62 data DFState f = DFState { df_rewritten    :: !ChangeFlag
  63                          , df_facts        :: !(BlockEnv f)
  64                          , df_exit_fact    :: !f
  65                          , df_last_outs    :: ![(BlockId, f)]
  66                          , df_facts_change :: !ChangeFlag
  67                          }
  68
  69 newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
  70                                                    -> m (a, DFState  fact))
  71 type DFM fact a = DFM' FuelMonad fact a
  72
  73
  74 runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
  75 runDFM lattice (DFM' f) =
  76   (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice) [] NoChange)
  77   >>= return . fst
  78
  79 class DataflowAnalysis m where
  80   markFactsUnchanged :: m f ()   -- ^ Useful for starting a new iteration
  81   factsStatus :: m f ChangeFlag
  82   subAnalysis :: m f a -> m f a  -- ^ Do a new analysis and then throw away
  83                                  -- /all/ the related state.
  84
  85   getFact :: BlockId -> m f f
  86   setFact :: Outputable f => BlockId -> f -> m f ()
  87   getExitFact :: m f f
  88   setExitFact :: Outputable f => f -> m f  ()
  89   checkFactMatch :: Outputable f =>
  90                     BlockId -> f -> m f () -- ^ assert fact already at this val
  91   botFact :: m f f
  92   forgetFact :: BlockId -> m f ()
  93   -- | It might be surprising these next two are needed in a pure analysis,
  94   -- but for some problems we do a 'shallow' rewriting in which a rewritten
  95   -- graph is not itself considered for further rewriting but merely undergoes
  96   -- an analysis.  In this case the results of a forward analysis might produce
  97   -- new facts that go on BlockId's that reside outside the graph being analyzed.
  98   -- Thus these 'lastOutFacts' need to be available even in a pure analysis.
  99   addLastOutFact :: (BlockId, f) -> m f ()
 100   bareLastOutFacts :: m f [(BlockId, f)]
 101   forgetLastOutFacts :: m f ()
 102   getAllFacts :: m f (BlockEnv f)
 103   setAllFacts :: BlockEnv f -> m f ()
 104   factsEnv :: Monad (m f) => m f (BlockId -> f)
 105
 106   lattice :: m f (DataflowLattice f)
 107   factsEnv = do { map <- getAllFacts
 108                 ; bot <- botFact
 109                 ; return $ \id -> lookupBlockEnv map id `orElse` bot }
 110
 111 instance Monad m => DataflowAnalysis (DFM' m) where
 112   markFactsUnchanged = DFM' f
 113     where f _ s = return ((), s {df_facts_change = NoChange})
 114   factsStatus = DFM' f'
 115     where f' _ s = return (df_facts_change s, s)
 116   subAnalysis (DFM' f) = DFM' f'
 117     where f' l s = do (a, _) <- f l (subAnalysisState s)
 118                       return (a, s)
 119   getFact id = DFM' get
 120     where get lattice s =
 121             return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
 122   setFact id a = DFM' set
 123     where set (DataflowLattice name bot add_fact log) s =
 124             case add_fact a old of
 125                  TxRes NoChange _ -> if initialized then return ((), s) else update old old
 126                  TxRes SomeChange join -> update join old
 127               where (old, initialized) =
 128                       case lookupBlockEnv (df_facts s) id of
 129                         Just f  -> (f,   True)
 130                         Nothing -> (bot, False)
 131                     update join old =
 132                       let facts' = extendBlockEnv (df_facts s) id join
 133                           debug = if log then pprTrace else \_ _ a -> a
 134                       in  debug name (pprSetFact id old a join) $
 135                           return ((), s { df_facts = facts', df_facts_change = SomeChange })
 136   getExitFact = DFM' get
 137     where get _ s = return (df_exit_fact s, s)
 138   setExitFact a =
 139     do DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice
 140        DFM' $ \_ s ->
 141                 let debug = if log then pprTrace else \_ _ a -> a
 142                 in  debug name (pprSetFact "exit" a a a) $
 143                     return ((), s { df_exit_fact = a })
 144   getAllFacts = DFM' f
 145     where f _ s = return (df_facts s, s)
 146   setAllFacts env = DFM' f
 147     where f _ s = return ((), s { df_facts = env})
 148   botFact = DFM' f
 149     where f lattice s = return (fact_bot lattice, s)
 150   forgetFact id = DFM' f
 151     where f _ s = return ((), s { df_facts = delFromBlockEnv (df_facts s) id })
 152   addLastOutFact pair = DFM' f
 153     where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
 154   bareLastOutFacts = DFM' f
 155     where f _ s = return (df_last_outs s, s)
 156   forgetLastOutFacts = DFM' f
 157     where f _ s = return ((), s { df_last_outs = [] })
 158   checkFactMatch id a =
 159       do { fact <- lattice
 160          ; old_a <- getFact id
 161          ; case fact_add_to fact a old_a of
 162              TxRes NoChange _ -> return ()
 163              TxRes SomeChange new ->
 164                do { facts <- getAllFacts
 165                   ; pprPanic "checkFactMatch"
 166                             (f4sep [text (fact_name fact), text "at id" <+> ppr id,
 167                                     text "changed from", nest 4 (ppr old_a), text "to",
 168                                     nest 4 (ppr new),
 169                                     text "after supposedly reaching fixed point;",
 170                                     text "env is", pprFacts facts]) }
 171          }
 172     where pprFacts env = vcat (map pprFact (blockEnvToList env))
 173           pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 174
 175   lattice = DFM' f
 176     where f l s = return (l, s)
 177
 178 subAnalysisState :: DFState f -> DFState f
 179 subAnalysisState s = s {df_facts_change = NoChange}
 180
 181
 182 markGraphRewritten :: Monad m => DFM' m f ()
 183 markGraphRewritten = DFM' f
 184     where f _ s = return ((), s {df_rewritten = SomeChange})
 185
 186 graphWasRewritten :: DFM f ChangeFlag
 187 graphWasRewritten = DFM' f
 188     where f _ s = return (df_rewritten s, s)
 189
 190 instance Monad m => Monad (DFM' m f) where
 191   DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
 192                                   s' `seq` case k a of DFM' f' -> f' l s')
 193   return a = DFM' (\_ s -> return (a, s))
 194  -- The `seq` is essential to ensure that entire passes of the dataflow engine
 195  -- aren't postponed in a thunk. By making the sequence strict in the state,
 196  -- we ensure that each action in the monad is executed immediately, preventing
 197  -- stack overflows that previously occurred when finally forcing the old state thunks.
 198
 199 instance FuelUsingMonad (DFM' FuelMonad f) where
 200   fuelRemaining = liftToDFM' fuelRemaining
 201   lastFuelPass  = liftToDFM' lastFuelPass
 202   fuelExhausted = liftToDFM' fuelExhausted
 203   fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f')
 204   fuelDec1      = liftToDFM' fuelDec1
 205 instance MonadUnique (DFM' FuelMonad f) where
 206     getUniqueSupplyM = liftToDFM' getUniqueSupplyM
 207     getUniqueM       = liftToDFM' getUniqueM
 208     getUniquesM      = liftToDFM' getUniquesM
 209
 210 liftToDFM' :: Monad m => m x -> DFM' m f x
 211 liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
 212 liftToDFM :: FuelMonad x -> DFM f x
 213 liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
 214
 215
 216 pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
 217 pprSetFact id old a join =
 218     f4sep [text "at" <+> text (show id),
 219            text "added" <+> ppr a, text "to" <+> ppr old,
 220            text "yielding" <+> ppr join]
 221
 222 f4sep :: [SDoc] -> SDoc
 223 f4sep [] = fsep []
 224 f4sep (d:ds) = fsep (d : map (nest 4) ds)