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