X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FDFMonad.hs;h=cce112bff5877249e079b72284fdcb9e964dda16;hp=789b4010b0b047b99048d7e01d55173fd11d64fd;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0 diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index 789b401..cce112b 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -1,33 +1,26 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} module DFMonad - ( Txlimit - , DFTx, runDFTx, lastTxPass, txDecrement, txRemaining, txExhausted - - , 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 hiding (freshBlockId) -import qualified ZipCfg as G - -import Outputable {- @@ -61,137 +54,119 @@ data DataflowLattice a = DataflowLattice { } --- 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 :: Txlimit, 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 Txlimit = Txlimit 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 - -runDFTx :: Txlimit -> DFTx a -> a --- should only be called once per program! -runDFTx lim (DFTx f) = fst $ f $ DFTxState lim "" +newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact + -> m (a, DFState fact)) +type DFM fact a = DFM' FuelMonad fact a -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 Txlimit -txRemaining = DFTx f - where f s = (df_txlimit s, s) - -txDecrement :: String -> Txlimit -> Txlimit -> 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", @@ -203,76 +178,44 @@ instance DataflowAnalysis DFA where 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 $ G.freshBlockId s - -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, @@ -281,7 +224,3 @@ pprSetFact id old a join = f4sep :: [SDoc] -> SDoc f4sep [] = fsep [] f4sep (d:ds) = fsep (d : map (nest 4) ds) - - -_I_am_abstract :: Int -> Txlimit -_I_am_abstract = Txlimit -- prevents a warning about Txlimit being unused