-
module DFMonad
- ( OptimizationFuel
- , DFTx, runDFTx, lastTxPass, txDecrement, txRemaining, txExhausted
- , functionalDFTx
-
- , DataflowLattice(..)
- , DataflowAnalysis
- , markFactsUnchanged, factsStatus, getFact, setFact, botFact
- , forgetFact, allFacts, factsEnv, checkFactMatch
- , addLastOutFact, lastOutFacts, forgetLastOutFacts
+ ( DataflowLattice(..) , DataflowAnalysis
+ , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
+ , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv
+ , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch
, subAnalysis
- , DFA, runDFA
- , DFM, runDFM, liftTx, liftAnal
- , markGraphRewritten
- , freshBlockId
- , liftUSM
+ , DFM, runDFM, liftToDFM
+ , markGraphRewritten, graphWasRewritten
+ , module OptimizationFuel
)
where
+import BlockId
import CmmTx
+import PprCmm()
+import OptimizationFuel
+
import Control.Monad
import Maybes
-import PprCmm()
+import Outputable
import UniqFM
import UniqSupply
-import ZipCfg
-import qualified ZipCfg as G
-
-import Outputable
{-
}
--- There are three monads here:
--- 1. DFTx, the monad of transactions, to be carried through all
--- graph-changing computations in the program
--- 2. DFA, the monad of analysis, which never changes anything
--- 3. DFM, the monad of combined analysis and transformation,
--- which needs a UniqSupply and may consume transactions
-
-data DFAState f = DFAState { df_facts :: BlockEnv f
- , df_facts_change :: ChangeFlag
- }
-
-data DFTxState = DFTxState { df_txlimit :: OptimizationFuel, df_lastpass :: String }
-
-data DFState f = DFState { df_uniqs :: UniqSupply
- , df_rewritten :: ChangeFlag
- , df_astate :: DFAState f
- , df_txstate :: DFTxState
- , df_last_outs :: [(BlockId, f)]
+-- DFM is the monad of combined analysis and transformation,
+-- which needs a UniqSupply and may consume optimization fuel
+-- DFM is defined using a monad transformer, DFM', which is the general
+-- case of DFM, parameterized over any monad.
+-- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and
+-- the unique supply.
+data DFState f = DFState { df_rewritten :: ChangeFlag
+ , df_facts :: BlockEnv f
+ , df_exit_fact :: f
+ , df_last_outs :: [(BlockId, f)]
+ , df_facts_change :: ChangeFlag
}
-newtype DFTx a = DFTx (DFTxState -> (a, DFTxState))
-newtype DFA fact a = DFA (DataflowLattice fact -> DFAState fact -> (a, DFAState fact))
-newtype DFM fact a = DFM (DataflowLattice fact -> DFState fact -> (a, DFState fact))
-
-
-liftAnal :: DFA f a -> DFM f a
-liftAnal (DFA f) = DFM f'
- where f' l s = let (a, anal) = f l (df_astate s)
- in (a, s {df_astate = anal})
-
-liftTx :: DFTx a -> DFM f a
-liftTx (DFTx f) = DFM f'
- where f' _ s = let (a, txs) = f (df_txstate s)
- in (a, s {df_txstate = txs})
-
-newtype OptimizationFuel = OptimizationFuel Int
- deriving (Ord, Eq, Num, Show, Bounded)
-
-initDFAState :: DFAState f
-initDFAState = DFAState emptyBlockEnv NoChange
-
-runDFA :: DataflowLattice f -> DFA f a -> a
-runDFA lattice (DFA f) = fst $ f lattice initDFAState
-
--- XXX DFTx really needs to be in IO, so we can dump programs in
--- intermediate states of optimization ---NR
-
-functionalDFTx :: String -> (OptimizationFuel -> (a, OptimizationFuel)) -> DFTx a
-functionalDFTx name pass = DFTx f
- where f s = let (a, fuel) = pass (df_txlimit s)
- in (a, DFTxState fuel name)
+newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
+ -> m (a, DFState fact))
+type DFM fact a = DFM' FuelMonad fact a
-runDFTx :: OptimizationFuel -> DFTx a -> a --- should only be called once per program!
-runDFTx lim (DFTx f) = fst $ f $ DFTxState lim "<none>"
-
-lastTxPass :: DFTx String
-lastTxPass = DFTx f
- where f s = (df_lastpass s, s)
-
-runDFM :: UniqSupply -> DataflowLattice f -> DFM f a -> DFTx a
-runDFM uniqs lattice (DFM f) = DFTx f'
- where f' txs =
- let (a, s) = f lattice $ DFState uniqs NoChange initDFAState txs [] in
- (a, df_txstate s)
-
-txExhausted :: DFTx Bool
-txExhausted = DFTx f
- where f s = (df_txlimit s <= 0, s)
-
-txRemaining :: DFTx OptimizationFuel
-txRemaining = DFTx f
- where f s = (df_txlimit s, s)
-
-txDecrement :: String -> OptimizationFuel -> OptimizationFuel -> DFTx ()
-txDecrement optimizer old new = DFTx f
- where f s = ((), s { df_txlimit = lim s, df_lastpass = optimizer })
- lim s = if old == df_txlimit s then new
- else panic $ concat ["lost track of ", optimizer, "'s transactions"]
+runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
+runDFM lattice (DFM' f) =
+ (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice)[] NoChange)
+ >>= return . fst
class DataflowAnalysis m where
markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration
factsStatus :: m f ChangeFlag
subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away
- -- *all* the related state. Even the Uniques
- -- will be reused.
+ -- /all/ the related state.
getFact :: BlockId -> m f f
setFact :: Outputable f => BlockId -> f -> m f ()
+ getExitFact :: m f f
+ setExitFact :: Outputable f => f -> m f ()
checkFactMatch :: Outputable f =>
BlockId -> f -> m f () -- ^ assert fact already at this val
botFact :: m f f
forgetFact :: BlockId -> m f ()
+ -- | It might be surprising these next two are needed in a pure analysis,
+ -- but for some problems we do a 'shallow' rewriting in which a rewritten
+ -- graph is not itself considered for further rewriting but merely undergoes
+ -- an analysis. In this case the results of a forward analysis might produce
+ -- new facts that go on BlockId's that reside outside the graph being analyzed.
+ -- Thus these 'lastOutFacts' need to be available even in a pure analysis.
+ addLastOutFact :: (BlockId, f) -> m f ()
+ bareLastOutFacts :: m f [(BlockId, f)]
forgetLastOutFacts :: m f ()
- allFacts :: m f (BlockEnv f)
+ getAllFacts :: m f (BlockEnv f)
+ setAllFacts :: BlockEnv f -> m f ()
factsEnv :: Monad (m f) => m f (BlockId -> f)
lattice :: m f (DataflowLattice f)
- factsEnv = do { map <- allFacts
+ factsEnv = do { map <- getAllFacts
; bot <- botFact
; return $ \id -> lookupBlockEnv map id `orElse` bot }
-instance DataflowAnalysis DFA where
- markFactsUnchanged = DFA f
- where f _ s = ((), s {df_facts_change = NoChange})
- factsStatus = DFA f'
- where f' _ s = (df_facts_change s, s)
- subAnalysis (DFA f) = DFA f'
- where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s)
- getFact id = DFA get
- where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
- setFact id a =
- do old <- getFact id
+instance Monad m => DataflowAnalysis (DFM' m) where
+ markFactsUnchanged = DFM' f
+ where f _ s = return ((), s {df_facts_change = NoChange})
+ factsStatus = DFM' f'
+ where f' _ s = return (df_facts_change s, s)
+ subAnalysis (DFM' f) = DFM' f'
+ where f' l s = do (a, _) <- f l (subAnalysisState s)
+ return (a, s)
+ getFact id = DFM' get
+ where get lattice s =
+ return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
+ setFact id a = DFM' set
+ where set (DataflowLattice name bot add_fact log) s =
+ case add_fact a old of
+ TxRes NoChange _ -> if initialized then return ((), s) else update old old
+ TxRes SomeChange join -> update join old
+ where (old, initialized) =
+ case lookupBlockEnv (df_facts s) id of
+ Just f -> (f, True)
+ Nothing -> (bot, False)
+ update join old =
+ let facts' = extendBlockEnv (df_facts s) id join
+ debug = if log then pprTrace else \_ _ a -> a
+ in debug name (pprSetFact id old a join) $
+ return ((), s { df_facts = facts', df_facts_change = SomeChange })
+ getExitFact = DFM' get
+ where get _ s = return (df_exit_fact s, s)
+ setExitFact a =
+ do old <- getExitFact
DataflowLattice { fact_add_to = add_fact
, fact_name = name, fact_do_logging = log } <- lattice
case add_fact a old of
TxRes NoChange _ -> return ()
- TxRes SomeChange join -> DFA $ \_ s ->
- let facts' = extendBlockEnv (df_facts s) id join
- debug = if log then pprTrace else \_ _ a -> a
- in debug name (pprSetFact id old a join) $
- ((), s { df_facts = facts', df_facts_change = SomeChange })
- botFact = DFA f
- where f lattice s = (fact_bot lattice, s)
- forgetFact id = DFA f
- where f _ s = ((), s { df_facts = delFromUFM (df_facts s) id })
- forgetLastOutFacts = return ()
- allFacts = DFA f
- where f _ s = (df_facts s, s)
+ TxRes SomeChange join -> DFM' $ \_ s ->
+ let debug = if log then pprTrace else \_ _ a -> a
+ in debug name (pprSetFact "exit" old a join) $
+ return ((), s { df_exit_fact = join, df_facts_change = SomeChange })
+ getAllFacts = DFM' f
+ where f _ s = return (df_facts s, s)
+ setAllFacts env = DFM' f
+ where f _ s = return ((), s { df_facts = env})
+ botFact = DFM' f
+ where f lattice s = return (fact_bot lattice, s)
+ forgetFact id = DFM' f
+ where f _ s = return ((), s { df_facts = delFromUFM (df_facts s) id })
+ addLastOutFact pair = DFM' f
+ where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
+ bareLastOutFacts = DFM' f
+ where f _ s = return (df_last_outs s, s)
+ forgetLastOutFacts = DFM' f
+ where f _ s = return ((), s { df_last_outs = [] })
checkFactMatch id a =
do { fact <- lattice
; old_a <- getFact id
; case fact_add_to fact a old_a of
TxRes NoChange _ -> return ()
TxRes SomeChange new ->
- do { facts <- allFacts
+ do { facts <- getAllFacts
; pprPanic "checkFactMatch"
(f4sep [text (fact_name fact), text "at id" <+> ppr id,
text "changed from", nest 4 (ppr old_a), text "to",
where pprFacts env = vcat (map pprFact (ufmToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
- lattice = DFA f
- where f l s = (l, s)
+ lattice = DFM' f
+ where f l s = return (l, s)
-subAnalysisState :: DFAState f -> DFAState f
+subAnalysisState :: DFState f -> DFState f
subAnalysisState s = s {df_facts_change = NoChange}
-instance DataflowAnalysis DFM where
- markFactsUnchanged = liftAnal $ markFactsUnchanged
- factsStatus = liftAnal $ factsStatus
- subAnalysis = dfmSubAnalysis
- getFact id = liftAnal $ getFact id
- setFact id new = liftAnal $ setFact id new
- botFact = liftAnal $ botFact
- forgetFact id = liftAnal $ forgetFact id
- forgetLastOutFacts = dfmForgetLastOutFacts
- allFacts = liftAnal $ allFacts
- checkFactMatch id a = liftAnal $ checkFactMatch id a
-
- lattice = liftAnal $ lattice
-
-dfmSubAnalysis :: DFM f a -> DFM f a
-dfmSubAnalysis (DFM f) = DFM f'
- where f' l s = let s' = s { df_astate = subAnalysisState (df_astate s) }
- (a, _) = f l s'
- in (a, s)
-
-dfmForgetLastOutFacts :: DFM f ()
-dfmForgetLastOutFacts = DFM f
- where f _ s = ((), s { df_last_outs = [] })
-
-addLastOutFact :: (BlockId, f) -> DFM f ()
-addLastOutFact pair = DFM f
- where f _ s = ((), s { df_last_outs = pair : df_last_outs s })
-
-lastOutFacts :: DFM f [(BlockId, f)]
-lastOutFacts = DFM f
- where f _ s = (df_last_outs s, s)
-
-markGraphRewritten :: DFM f ()
-markGraphRewritten = DFM f
- where f _ s = ((), s {df_rewritten = SomeChange})
-
-freshBlockId :: String -> DFM f BlockId
-freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
-
-liftUSM :: UniqSM a -> DFM f a
-liftUSM uc = DFM f
- where f _ s = let (a, us') = initUs (df_uniqs s) uc
- in (a, s {df_uniqs = us'})
-
-instance Monad (DFA f) where
- DFA f >>= k = DFA (\l s -> let (a, s') = f l s
- DFA f' = k a
- in f' l s')
- return a = DFA (\_ s -> (a, s))
-
-instance Monad (DFM f) where
- DFM f >>= k = DFM (\l s -> let (a, s') = f l s
- DFM f' = k a
- in f' l s')
- return a = DFM (\_ s -> (a, s))
-
-instance Monad (DFTx) where
- DFTx f >>= k = DFTx (\s -> let (a, s') = f s
- DFTx f' = k a
- in f' s')
- return a = DFTx (\s -> (a, s))
-
-pprSetFact :: Outputable f => BlockId -> f -> f -> f -> SDoc
+markGraphRewritten :: Monad m => DFM' m f ()
+markGraphRewritten = DFM' f
+ where f _ s = return ((), s {df_rewritten = SomeChange})
+
+graphWasRewritten :: DFM f ChangeFlag
+graphWasRewritten = DFM' f
+ where f _ s = return (df_rewritten s, s)
+
+instance Monad m => Monad (DFM' m f) where
+ DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
+ let DFM' f' = k a in f' l s')
+ return a = DFM' (\_ s -> return (a, s))
+
+instance FuelUsingMonad (DFM' FuelMonad f) where
+ fuelRemaining = liftToDFM' fuelRemaining
+ lastFuelPass = liftToDFM' lastFuelPass
+ fuelExhausted = liftToDFM' fuelExhausted
+ fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f')
+ fuelDec1 = liftToDFM' fuelDec1
+instance MonadUnique (DFM' FuelMonad f) where
+ getUniqueSupplyM = liftToDFM' getUniqueSupplyM
+ getUniqueM = liftToDFM' getUniqueM
+ getUniquesM = liftToDFM' getUniquesM
+
+liftToDFM' :: Monad m => m x -> DFM' m f x
+liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
+liftToDFM :: FuelMonad x -> DFM f x
+liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
+
+
+pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
pprSetFact id old a join =
f4sep [text "at" <+> text (show id),
text "added" <+> ppr a, text "to" <+> ppr old,
f4sep :: [SDoc] -> SDoc
f4sep [] = fsep []
f4sep (d:ds) = fsep (d : map (nest 4) ds)
-
-
-_I_am_abstract :: Int -> OptimizationFuel
-_I_am_abstract = OptimizationFuel -- prevents warning: OptimizationFuel unused
projects / ghc-hetmet.git / blobdiff