compiler/cmm/DFMonad.hs

   1
   2 module DFMonad
   3     ( DataflowLattice(..)
   4     , DataflowAnalysis
   5     , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
   6                         , forgetFact, botFact, allFacts, factsEnv, checkFactMatch
   7     , addLastOutFact, bareLastOutFacts, forgetLastOutFacts
   8     , subAnalysis
   9
  10     , DFA, runDFA
  11     , DFM, runDFM, liftAnal
  12     , markGraphRewritten
  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   allFacts :: m f (BlockEnv f)
 127   factsEnv :: Monad (m f) => m f (BlockId -> f)
 128
 129   lattice :: m f (DataflowLattice f)
 130   factsEnv = do { map <- allFacts
 131                 ; bot <- botFact
 132                 ; return $ \id -> lookupBlockEnv map id `orElse` bot }
 133
 134 instance DataflowAnalysis DFA where
 135   markFactsUnchanged = DFA f
 136     where f _ s = ((), s {df_facts_change = NoChange})
 137   factsStatus = DFA f'
 138     where f' _ s = (df_facts_change s, s)
 139   subAnalysis (DFA f) = DFA f'
 140     where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s)
 141   getFact id = DFA get
 142     where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
 143   setFact id a =
 144     do old <- getFact id
 145        DataflowLattice { fact_add_to = add_fact
 146                        , fact_name = name, fact_do_logging = log } <- lattice
 147        case add_fact a old of
 148          TxRes NoChange _ -> return ()
 149          TxRes SomeChange join -> DFA $ \_ s ->
 150              let facts' = extendBlockEnv (df_facts s) id join
 151                  debug = if log then pprTrace else \_ _ a -> a
 152              in  debug name (pprSetFact id old a join) $
 153                  ((), s { df_facts = facts', df_facts_change = SomeChange })
 154   getExitFact = DFA get
 155     where get _ s = (df_exit_fact s, s)
 156   setExitFact a =
 157     do old <- getExitFact
 158        DataflowLattice { fact_add_to = add_fact
 159                        , fact_name = name, fact_do_logging = log } <- lattice
 160        case add_fact a old of
 161          TxRes NoChange _ -> return ()
 162          TxRes SomeChange join -> DFA $ \_ s ->
 163              let debug = if log then pprTrace else \_ _ a -> a
 164              in  debug name (pprSetFact "exit" old a join) $
 165                  ((), s { df_exit_fact = join, df_facts_change = SomeChange })
 166   botFact = DFA f
 167     where f lattice s = (fact_bot lattice, s)
 168   forgetFact id = DFA f
 169     where f _ s = ((), s { df_facts = delFromUFM (df_facts s) id })
 170   addLastOutFact pair = DFA f
 171     where f _ s = ((), s { df_last_outs = pair : df_last_outs s })
 172   bareLastOutFacts = DFA f
 173     where f _ s = (df_last_outs s, s)
 174   forgetLastOutFacts = DFA f
 175     where f _ s = ((), s { df_last_outs = [] })
 176   allFacts = DFA f
 177     where f _ s = (df_facts s, s)
 178   checkFactMatch id a =
 179       do { fact <- lattice
 180          ; old_a <- getFact id
 181          ; case fact_add_to fact a old_a of
 182              TxRes NoChange _ -> return ()
 183              TxRes SomeChange new ->
 184                do { facts <- allFacts
 185                   ; pprPanic "checkFactMatch"
 186                             (f4sep [text (fact_name fact), text "at id" <+> ppr id,
 187                                     text "changed from", nest 4 (ppr old_a), text "to",
 188                                     nest 4 (ppr new),
 189                                     text "after supposedly reaching fixed point;",
 190                                     text "env is", pprFacts facts])
 191                   ; setFact id a }
 192          }
 193     where pprFacts env = vcat (map pprFact (ufmToList env))
 194           pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 195
 196   lattice = DFA f
 197     where f l s = (l, s)
 198
 199 subAnalysisState :: DFAState f -> DFAState f
 200 subAnalysisState s = s {df_facts_change = NoChange}
 201
 202
 203 instance DataflowAnalysis DFM where
 204   markFactsUnchanged  = liftAnal $ markFactsUnchanged
 205   factsStatus         = liftAnal $ factsStatus
 206   subAnalysis         = dfmSubAnalysis
 207   getFact id          = liftAnal $ getFact id
 208   setFact id new      = liftAnal $ setFact id new
 209   getExitFact         = liftAnal $ getExitFact
 210   setExitFact new     = liftAnal $ setExitFact new
 211   botFact             = liftAnal $ botFact
 212   forgetFact id       = liftAnal $ forgetFact id
 213   addLastOutFact p    = liftAnal $ addLastOutFact p
 214   bareLastOutFacts    = liftAnal $ bareLastOutFacts
 215   forgetLastOutFacts  = liftAnal $ forgetLastOutFacts
 216   allFacts            = liftAnal $ allFacts
 217   checkFactMatch id a = liftAnal $ checkFactMatch id a
 218
 219   lattice             = liftAnal $ lattice
 220
 221 dfmSubAnalysis :: DFM f a -> DFM f a
 222 dfmSubAnalysis (DFM f) = DFM f'
 223     where f' l s = let s' = s { df_astate = subAnalysisState (df_astate s) }
 224                        (a, _) = f l s'
 225                    in  (a, s)
 226
 227
 228 markGraphRewritten :: DFM f ()
 229 markGraphRewritten = DFM f
 230     where f _ s = ((), s {df_rewritten = SomeChange})
 231
 232 freshBlockId :: String -> DFM f BlockId
 233 freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
 234
 235 liftUSM :: UniqSM a -> DFM f a
 236 liftUSM uc = DFM f
 237     where f _ s = let (a, us') = initUs (df_uniqs s) uc
 238                   in (a, s {df_uniqs = us'})
 239
 240 instance Monad (DFA f) where
 241   DFA f >>= k = DFA (\l s -> let (a, s') = f l s
 242                                  DFA f' = k a
 243                              in  f' l s')
 244   return a = DFA (\_ s -> (a, s))
 245
 246 instance Monad (DFM f) where
 247   DFM f >>= k = DFM (\l s -> let (a, s') = f l s
 248                                  DFM f' = k a
 249                              in  f' l s')
 250   return a = DFM (\_ s -> (a, s))
 251
 252 instance FuelUsingMonad (DFM f) where
 253   fuelRemaining = extract fuelRemainingInState
 254   lastFuelPass  = extract lastFuelPassInState
 255   fuelExhausted = extract fuelExhaustedInState
 256   fuelDecrement p f f' = DFM (\_ s -> ((), s { df_fstate = fs' s }))
 257     where fs' s = fuelDecrementState p f f' $ df_fstate s
 258
 259 extract :: (FuelState -> a) -> DFM f a
 260 extract f = DFM (\_ s -> (f $ df_fstate s, s))
 261
 262
 263 pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
 264 pprSetFact id old a join =
 265     f4sep [text "at" <+> text (show id),
 266            text "added" <+> ppr a, text "to" <+> ppr old,
 267            text "yielding" <+> ppr join]
 268
 269 f4sep :: [SDoc] -> SDoc
 270 f4sep [] = fsep []
 271 f4sep (d:ds) = fsep (d : map (nest 4) ds)