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