compiler/cmm/DFMonad.hs

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