module DFMonad
( DataflowLattice(..) , DataflowAnalysis
, markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
, forgetFact, botFact, setAllFacts, getAllFacts, factsEnv
, addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch
, subAnalysis
, DFM, runDFM, liftToDFM
, markGraphRewritten, graphWasRewritten
, module OptimizationFuel
)
where
import BlockId
import CmmTx
import PprCmm()
import OptimizationFuel
import Maybes
import Outputable
import UniqSupply
data DataflowLattice a = DataflowLattice {
fact_name :: String,
fact_bot :: a,
fact_add_to :: a -> a -> TxRes a,
fact_do_logging :: Bool
}
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 DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
-> m (a, DFState fact))
type DFM fact a = DFM' FuelMonad fact a
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 ()
factsStatus :: m f ChangeFlag
subAnalysis :: m f a -> m f a
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 ()
botFact :: m f f
forgetFact :: BlockId -> m f ()
addLastOutFact :: (BlockId, f) -> m f ()
bareLastOutFacts :: m f [(BlockId, f)]
forgetLastOutFacts :: m 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 <- getAllFacts
; bot <- botFact
; return $ \id -> lookupBlockEnv map id `orElse` bot }
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 DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice
DFM' $ \_ s ->
let debug = if log then pprTrace else \_ _ a -> a
in debug name (pprSetFact "exit" a a a) $
return ((), s { df_exit_fact = a })
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 = delFromBlockEnv (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 <- getAllFacts
; pprPanic "checkFactMatch"
(f4sep [text (fact_name fact), text "at id" <+> ppr id,
text "changed from", nest 4 (ppr old_a), text "to",
nest 4 (ppr new),
text "after supposedly reaching fixed point;",
text "env is", pprFacts facts]) }
}
where pprFacts env = vcat (map pprFact (blockEnvToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
lattice = DFM' f
where f l s = return (l, s)
subAnalysisState :: DFState f -> DFState f
subAnalysisState s = s {df_facts_change = NoChange}
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
s' `seq` case k a of DFM' f' -> 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,
text "yielding" <+> ppr join]
f4sep :: [SDoc] -> SDoc
f4sep [] = fsep []
f4sep (d:ds) = fsep (d : map (nest 4) ds)