compiler/cmm/DFMonad.hs

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