compiler/cmm/DFMonad.hs

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