summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/Cmm.hs1
-rw-r--r--compiler/cmm/CmmCPSZ.hs58
-rw-r--r--compiler/cmm/CmmLiveZ.hs2
-rw-r--r--compiler/cmm/CmmProcPointZ.hs4
-rw-r--r--compiler/cmm/CmmSpillReload.hs43
-rw-r--r--compiler/cmm/DFMonad.hs162
-rw-r--r--compiler/cmm/OptimizationFuel.hs124
-rw-r--r--compiler/cmm/StackColor.hs2
-rw-r--r--compiler/cmm/ZipCfg.hs4
-rw-r--r--compiler/cmm/ZipCfgCmmRep.hs2
-rw-r--r--compiler/cmm/ZipDataflow0.hs (renamed from compiler/cmm/ZipDataflow.hs)311
11 files changed, 531 insertions, 182 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index b535c8dbd2..790d072293 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -21,6 +21,7 @@ module Cmm (
CmmSafety(..),
CmmCallTarget(..),
CmmStatic(..), Section(..),
+ module CmmExpr,
BlockId(..), mkBlockId,
BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 4dff9bc1d4..35c20c048e 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -12,14 +12,17 @@ import CmmProcPointZ
import CmmSpillReload
import CmmTx
import DFMonad
+import PprCmmZ()
+import ZipCfg hiding (zip, unzip)
+import ZipCfgCmmRep
+import ZipDataflow0
+
import DynFlags
import ErrUtils
import Outputable
-import PprCmmZ()
import UniqSupply
-import ZipCfg hiding (zip, unzip)
-import ZipCfgCmmRep
-import ZipDataflow
+
+import Data.IORef
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
@@ -30,25 +33,42 @@ protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
protoCmmCPSZ dflags (Cmm tops)
= do { showPass dflags "CPSZ"
; u <- mkSplitUniqSupply 'p'
+ ; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
+ ; fuel_ref <- newIORef (tankFilledTo maxBound) -- XXX see [Note global fuel]
; let txtops = initUs_ u $ mapM cpsTop tops
- ; let pgm = Cmm $ runDFTx maxBound $ sequence txtops
- --- XXX calling runDFTx is totally bogus
- ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr pgm)
- ; return pgm
+ ; tops <- runFuelIO pass_ref fuel_ref (sequence txtops)
+ ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops))
+ ; return $ Cmm tops
}
-cpsTop :: CmmTopZ -> UniqSM (DFTx CmmTopZ)
-cpsTop p@(CmmData {}) = return $ return p
+{- [Note global fuel]
+~~~~~~~~~~~~~~~~~~~~~
+In a correct world, the identity and the last pass would be stored in
+mutable reference cells associated with an 'HscEnv' and would be
+global to one compiler session. Unfortunately the 'HscEnv' is not
+plumbed sufficiently close to this function; only the DynFlags are
+plumbed here. One day the plumbing will be extended, in which case
+this pass will use the global 'pass_ref' and 'fuel_ref' instead of the
+bogus facsimiles in place here.
+-}
+
+cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ)
+cpsTop p@(CmmData {}) = return (return p)
cpsTop (CmmProc h l args g) =
let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
g' = addProcPointProtocols procPoints args g
g'' = map_nodes id NotSpillOrReload id g'
- in do g <- dual_rewrite dualLivenessWithInsertion g''
- g <- return (g >>= insertLateReloads)
- u <- getUs
- let g' = g >>= (initUs_ u . dual_rewrite removeDeadAssignmentsAndReloads)
- return $ do g <- g' >>= return . map_nodes id spillAndReloadComments id
- return $ CmmProc h l args g
- where dual_rewrite pass g =
- do us <- getUs
- return $ runDFM us dualLiveLattice $ b_rewrite pass g
+ in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
+ ; entry <- getUniqueUs >>= return . BlockId
+ ; return $
+ do { g <- return g''
+ ; g <- dual_rewrite u1 dualLivenessWithInsertion g
+ ; g <- insertLateReloads' u2 (extend g)
+ ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
+ ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
+ }
+ }
+ where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g
+ extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
+ trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks
+ trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks)
diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs
index cd969710ba..07801be49f 100644
--- a/compiler/cmm/CmmLiveZ.hs
+++ b/compiler/cmm/CmmLiveZ.hs
@@ -13,7 +13,7 @@ import CmmTx
import DFMonad
import PprCmm()
import PprCmmZ()
-import ZipDataflow
+import ZipDataflow0
import ZipCfgCmmRep
import Maybes
diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index ac016a7538..b2dbd871c8 100644
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -23,7 +23,7 @@ import UniqFM
import UniqSet
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow
+import ZipDataflow0
-- Compute a minimal set of proc points for a control-flow graph.
@@ -118,7 +118,7 @@ forward = FComp "proc-point reachability" first middle last exit
middle x _ = x
last _ (LastCall _ (Just id)) = LastOutFacts [(id, ProcPoint)]
last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
- exit _ = LastOutFacts []
+ exit x = x
minimalProcPointSet :: CmmGraph -> ProcPointSet
minimalProcPointSet g = extendPPSet g (postorder_dfs g) entryPoint
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 6f59e8f093..4067f89fb1 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -10,6 +10,7 @@ module CmmSpillReload
, availRegsLattice
, cmmAvailableReloads
, insertLateReloads
+ , insertLateReloads'
, removeDeadAssignmentsAndReloads
)
where
@@ -22,7 +23,7 @@ import MkZipCfg
import PprCmm()
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow
+import ZipDataflow0
import FastString
import Maybes
@@ -30,6 +31,7 @@ import Outputable hiding (empty)
import qualified Outputable as PP
import Panic
import UniqSet
+import UniqSupply
import Maybe
import Prelude hiding (zip)
@@ -238,14 +240,15 @@ elemAvail (AvailRegs s) r = elemRegSet r s
cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
cmmAvailableReloads g = env
where env = runDFA availRegsLattice $
- do run_f_anal transfer (fact_bot availRegsLattice) g
+ do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
allFacts
- transfer :: FAnalysis M Last AvailRegs
- transfer = FComp "available-reloads analysis" first middle last exit
- exit _ = LastOutFacts []
- first avail _ = avail
- middle = flip middleAvail
- last = lastAvail
+
+avail_reloads_transfer :: FAnalysis M Last AvailRegs
+avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
+ where exit avail = avail
+ first avail _ = avail
+ middle = flip middleAvail
+ last = lastAvail
-- | The transfer equations use the traditional 'gen' and 'kill'
@@ -270,11 +273,11 @@ lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-insertLateReloads :: LGraph M Last -> DFTx (LGraph M Last)
+insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last)
insertLateReloads g = mapM_blocks insertM g
where env = cmmAvailableReloads g
avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
- insertM b = functionalDFTx "late reloads" (insert b)
+ insertM b = fuelConsumingPass "late reloads" (insert b)
insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
propagate h avail (ZTail m t) fuel =
let (h', fuel') = maybe_add_reload h avail m fuel in
@@ -284,9 +287,23 @@ insertLateReloads g = mapM_blocks insertM g
(zipht h' (ZLast l), fuel')
maybe_add_reload h avail node fuel =
let used = filterRegsUsed (elemAvail avail) node
- in if fuel == 0 || isEmptyUniqSet used then (h, fuel)
- else (ZHead h (Reload used), fuel-1)
-
+ in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used then (h,fuel)
+ else (ZHead h (Reload used), oneLessFuel fuel)
+
+insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last)
+insertLateReloads' us g =
+ runDFM us availRegsLattice $
+ f_shallow_rewrite avail_reloads_transfer insert bot g
+ where bot = fact_bot availRegsLattice
+ insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last }
+ middle :: AvailRegs -> M -> Maybe (Graph M Last)
+ last :: AvailRegs -> Last -> Maybe (Graph M Last)
+ middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
+ last avail l = maybe_reload_before avail l (ZLast (LastOther l))
+ maybe_reload_before avail node tail =
+ let used = filterRegsUsed (elemAvail avail) node
+ in if isEmptyUniqSet used then Nothing
+ else Just $ graphOfZTail $ ZTail (Reload used) tail
_lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
_lateReloadsWithoutFuel g = map_blocks insert g
diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs
index 970cdcb943..65c033ebb8 100644
--- a/compiler/cmm/DFMonad.hs
+++ b/compiler/cmm/DFMonad.hs
@@ -1,34 +1,32 @@
module DFMonad
- ( OptimizationFuel
- , DFTx, runDFTx, lastTxPass, txDecrement, txRemaining, txExhausted
- , functionalDFTx
-
- , DataflowLattice(..)
+ ( DataflowLattice(..)
, DataflowAnalysis
- , markFactsUnchanged, factsStatus, getFact, setFact, botFact
- , forgetFact, allFacts, factsEnv, checkFactMatch
- , addLastOutFact, lastOutFacts, forgetLastOutFacts
+ , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
+ , forgetFact, botFact, allFacts, factsEnv, checkFactMatch
+ , addLastOutFact, bareLastOutFacts, forgetLastOutFacts
, subAnalysis
, DFA, runDFA
- , DFM, runDFM, liftTx, liftAnal
+ , DFM, runDFM, liftAnal
, markGraphRewritten
, freshBlockId
, liftUSM
+ , module OptimizationFuel
)
where
import CmmTx
-import Control.Monad
-import Maybes
import PprCmm()
-import UniqFM
-import UniqSupply
+import OptimizationFuel
import ZipCfg
-import qualified ZipCfg as G
+import Maybes
import Outputable
+import UniqFM
+import UniqSupply
+
+import Control.Monad
{-
@@ -62,27 +60,24 @@ 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,
+-- There are two monads here:
+-- 1. DFA, the monad of analysis, which never changes anything
+-- 2. 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_exit_fact :: f
+ , df_last_outs :: [(BlockId, 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)]
+ , df_fstate :: FuelState
}
-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))
@@ -92,55 +87,17 @@ 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
+initDFAState :: f -> DFAState f
+initDFAState bot = DFAState emptyBlockEnv bot [] 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)
-
-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"]
+runDFA lattice (DFA f) = fst $ f lattice (initDFAState $ fact_bot lattice)
+runDFM :: UniqSupply -> DataflowLattice f -> DFM f a -> FuelMonad a
+runDFM uniqs lattice (DFM f) = FuelMonad (\s ->
+ let (a, s') = f lattice $ DFState uniqs NoChange dfa_state s
+ in (a, df_fstate s'))
+ where dfa_state = initDFAState (fact_bot lattice)
class DataflowAnalysis m where
markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration
@@ -151,10 +108,20 @@ class DataflowAnalysis m where
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)
factsEnv :: Monad (m f) => m f (BlockId -> f)
@@ -184,11 +151,28 @@ instance DataflowAnalysis DFA where
debug = if log then pprTrace else \_ _ a -> a
in debug name (pprSetFact id old a join) $
((), s { df_facts = facts', df_facts_change = SomeChange })
+ getExitFact = DFA get
+ where get _ s = (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 debug = if log then pprTrace else \_ _ a -> a
+ in debug name (pprSetFact "exit" old a join) $
+ ((), s { df_exit_fact = join, 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 ()
+ addLastOutFact pair = DFA f
+ where f _ s = ((), s { df_last_outs = pair : df_last_outs s })
+ bareLastOutFacts = DFA f
+ where f _ s = (df_last_outs s, s)
+ forgetLastOutFacts = DFA f
+ where f _ s = ((), s { df_last_outs = [] })
allFacts = DFA f
where f _ s = (df_facts s, s)
checkFactMatch id a =
@@ -222,9 +206,13 @@ instance DataflowAnalysis DFM where
subAnalysis = dfmSubAnalysis
getFact id = liftAnal $ getFact id
setFact id new = liftAnal $ setFact id new
+ getExitFact = liftAnal $ getExitFact
+ setExitFact new = liftAnal $ setExitFact new
botFact = liftAnal $ botFact
forgetFact id = liftAnal $ forgetFact id
- forgetLastOutFacts = dfmForgetLastOutFacts
+ addLastOutFact p = liftAnal $ addLastOutFact p
+ bareLastOutFacts = liftAnal $ bareLastOutFacts
+ forgetLastOutFacts = liftAnal $ forgetLastOutFacts
allFacts = liftAnal $ allFacts
checkFactMatch id a = liftAnal $ checkFactMatch id a
@@ -236,17 +224,6 @@ dfmSubAnalysis (DFM f) = DFM f'
(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
@@ -272,13 +249,18 @@ instance Monad (DFM f) where
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))
+instance FuelUsingMonad (DFM f) where
+ fuelRemaining = extract fuelRemainingInState
+ lastFuelPass = extract lastFuelPassInState
+ fuelExhausted = extract fuelExhaustedInState
+ fuelDecrement p f f' = DFM (\_ s -> ((), s { df_fstate = fs' s }))
+ where fs' s = fuelDecrementState p f f' $ df_fstate s
-pprSetFact :: Outputable f => BlockId -> f -> f -> f -> SDoc
+extract :: (FuelState -> a) -> DFM f a
+extract f = DFM (\_ s -> (f $ df_fstate s, 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,
@@ -287,7 +269,3 @@ pprSetFact id old a join =
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
diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs
new file mode 100644
index 0000000000..c15bd4d630
--- /dev/null
+++ b/compiler/cmm/OptimizationFuel.hs
@@ -0,0 +1,124 @@
+module OptimizationFuel
+ ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
+ , tankFilledTo, diffFuel
+ , FuelConsumer
+ , FuelUsingMonad, FuelState
+ , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement
+ , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState
+ , fuelDecrementState
+ , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass
+ , FuelMonad(..)
+ )
+where
+
+import GHC.Prim
+import Panic
+
+import Data.IORef
+
+#include "HsVersions.h"
+
+type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
+
+canRewriteWithFuel :: OptimizationFuel -> Bool
+oneLessFuel :: OptimizationFuel -> OptimizationFuel
+maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
+diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
+ -- to measure consumption during compilation
+tankFilledTo :: Int -> OptimizationFuel
+
+#ifdef DEBUG
+newtype OptimizationFuel = OptimizationFuel Int
+ deriving Show
+
+tankFilledTo = OptimizationFuel
+canRewriteWithFuel (OptimizationFuel f) = f > 0
+maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
+oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
+diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
+#else
+-- type OptimizationFuel = State# () -- would like this, but it won't work
+data OptimizationFuel = OptimizationFuel
+ deriving Show
+tankFilledTo _ = undefined -- should be impossible to evaluate
+ -- realWorld# might come in handy, too...
+canRewriteWithFuel OptimizationFuel = True
+maybeRewriteWithFuel _ ma = ma
+oneLessFuel f = f
+diffFuel _ _ = 0
+#endif
+
+-- stop warnings about things that aren't used
+_unused :: State# () -> FS.FastString
+_unused = undefined panic
+
+
+data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
+newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState))
+
+fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
+fuelConsumingPass name f = do fuel <- fuelRemaining
+ let (a, fuel') = f fuel
+ fuelDecrement name fuel fuel'
+ return a
+
+runFuel :: FuelMonad a -> FuelConsumer a
+runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
+
+runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
+runFuelIO pass_ref fuel_ref (FuelMonad f) =
+ do { pass <- readIORef pass_ref
+ ; fuel <- readIORef fuel_ref
+ ; let (a, FuelState fuel' pass') = f (FuelState fuel pass)
+ ; writeIORef pass_ref pass'
+ ; writeIORef fuel_ref fuel'
+ ; return a
+ }
+
+initialFuelState :: OptimizationFuel -> FuelState
+initialFuelState fuel = FuelState fuel "unoptimized program"
+
+runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
+ in (a, fs_fuellimit s)
+runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
+ in ((a, fs_lastpass s), fs_fuellimit s)
+
+lastFuelPassInState :: FuelState -> String
+lastFuelPassInState = fs_lastpass
+
+fuelExhaustedInState :: FuelState -> Bool
+fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
+
+fuelRemainingInState :: FuelState -> OptimizationFuel
+fuelRemainingInState = fs_fuellimit
+
+fuelDecrementState
+ :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
+fuelDecrementState new_optimizer old new s =
+ FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
+ where lim = if diffFuel old (fs_fuellimit s) == 0 then new
+ else panic $
+ concat ["lost track of ", new_optimizer, "'s transactions"]
+ optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
+
+class Monad m => FuelUsingMonad m where
+ fuelRemaining :: m OptimizationFuel
+ fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
+ fuelExhausted :: m Bool
+ lastFuelPass :: m String
+
+
+instance Monad FuelMonad where
+ FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s
+ FuelMonad f' = k a
+ in f' s')
+ return a = FuelMonad (\s -> (a, s))
+
+instance FuelUsingMonad FuelMonad where
+ fuelRemaining = extract fuelRemainingInState
+ lastFuelPass = extract lastFuelPassInState
+ fuelExhausted = extract fuelExhaustedInState
+ fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s))
+
+extract :: (FuelState -> a) -> FuelMonad a
+extract f = FuelMonad (\s -> (f s, s))
diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs
index 2f97a18877..94bb5c602d 100644
--- a/compiler/cmm/StackColor.hs
+++ b/compiler/cmm/StackColor.hs
@@ -10,7 +10,7 @@ import qualified GraphOps
import MachOp
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow
+import ZipDataflow0
import Maybes
import Panic
diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index 30843e5bb8..228504ce7c 100644
--- a/compiler/cmm/ZipCfg.hs
+++ b/compiler/cmm/ZipCfg.hs
@@ -21,7 +21,7 @@ module ZipCfg
, pprLgraph, pprGraph
- , entry -- exported for the convenience of ZipDataflow, at least for now
+ , entry -- exported for the convenience of ZipDataflow0, at least for now
{-
-- the following functions might one day be useful and can be found
@@ -75,7 +75,7 @@ the data constructor 'LastExit'. A graph may contain at most one
'LastExit' node, and a graph representing a full procedure should not
contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
graphs together, either during graph construction (see module 'MkZipCfg')
-or during optimization (see module 'ZipDataflow').
+or during optimization (see module 'ZipDataflow0').
A graph is parameterized over the types of middle and last nodes. Each of
these types will typically be instantiated with a subset of C-- statements
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index b710a941b0..c5464e2b42 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -25,7 +25,7 @@ import ClosureInfo
import FastString
import ForeignCall
import MachOp
-import qualified ZipDataflow as DF
+import qualified ZipDataflow0 as DF
import ZipCfg
import MkZipCfg
diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow0.hs
index 2087b9ce34..3a3b0a8b75 100644
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow0.hs
@@ -1,16 +1,18 @@
{-# LANGUAGE MultiParamTypeClasses #-}
-module ZipDataflow
+module ZipDataflow0
( Answer(..)
, BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation
, BPass, BUnlimitedPass
- , FComputation(..), FAnalysis, FTransformation, FPass, FUnlimitedPass
+ , FComputation(..), FAnalysis, FTransformation, FFunctionalTransformation
+ , FPass, FUnlimitedPass
, LastOutFacts(..)
, DebugNodes
, anal_b, a_t_b, a_ft_b, a_ft_b_unlimited, ignore_transactions_b
, anal_f, a_t_f
+ , null_f_ft, null_b_ft
, run_b_anal, run_f_anal
, refine_f_anal, refine_b_anal, fold_edge_facts_b, fold_edge_facts_with_nodes_b
- , b_rewrite, f_rewrite
+ , b_rewrite, f_rewrite, b_shallow_rewrite, f_shallow_rewrite
, solve_graph_b, solve_graph_f
)
where
@@ -145,7 +147,7 @@ data FComputation middle last input outmid outlast = FComp
, fc_first_out :: input -> BlockId -> outmid
, fc_middle_out :: input -> middle -> outmid
, fc_last_outs :: input -> last -> outlast
- , fc_exit_outs :: input -> outlast
+ , fc_exit_out :: input -> outmid
}
-- | The notions of analysis, pass, and transformation are analogous to the
@@ -159,6 +161,11 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
type FAnalysis m l a = FComputation m l a a (LastOutFacts a)
type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l)))
(Maybe (UniqSM (Graph m l)))
+type FFunctionalTransformation m l a =
+ FComputation m l a (Maybe (Graph m l))
+ (Maybe (Graph m l))
+ -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l)
+
type FPass m l a = FComputation m l a
(OptimizationFuel -> DFM a (Answer m l a))
(OptimizationFuel -> DFM a (Answer m l (LastOutFacts a)))
@@ -177,6 +184,9 @@ We can make an analysis pass, or we can
combine a related analysis and transformation into a full pass.
-}
+null_b_ft :: BFunctionalTransformation m l a
+null_f_ft :: FFunctionalTransformation m l a
+
anal_b :: BAnalysis m l a -> BPass m l a
a_t_b :: BAnalysis m l a -> BTransformation m l a -> BPass m l a
a_ft_b :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
@@ -248,6 +258,19 @@ f_rewrite :: (DebugNodes m l, LastNode l, Outputable m, Outputable a) =>
FPass m l a -> a -> LGraph m l -> DFM a (LGraph m l)
-- ^ extra parameter is the entry fact
+b_shallow_rewrite
+ :: (DebugNodes m l, Outputable a)
+ => BAnalysis m l a -> BFunctionalTransformation m l a ->
+ Graph m l -> DFM a (Graph m l)
+
+b_shallow_rewrite = error "unimp"
+
+f_shallow_rewrite
+ :: (DebugNodes m l, Outputable a)
+ => FAnalysis m l a -> FFunctionalTransformation m l a ->
+ a -> Graph m l -> DFM a (Graph m l)
+
+
-- | If the solution to a problem is already sitting in a monad, we
-- should be able to take a short cut and just rewrite it in one pass.
-- But not yet implemented.
@@ -396,7 +419,7 @@ solve_graph_b comp fuel graph exit_fact =
Rewrite g ->
do { bot <- botFact
; (fuel, a) <- subAnalysis' $
- solve_graph_b_g comp (fuel-1) g bot
+ solve_graph_b_g comp (oneLessFuel fuel) g bot
; head_in fuel h a }
; my_trace "result of" (text (bc_name comp) <+>
text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $
@@ -407,14 +430,14 @@ solve_graph_b comp fuel graph exit_fact =
bc_middle_in comp out m fuel >>= \x -> case x of
Dataflow a -> head_in fuel h a
Rewrite g ->
- do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (fuel-1) g out
+ do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (oneLessFuel fuel) g out
; my_trace "Rewrote middle node"
(f4sep [ppr m, text "to", pprGraph g]) $
head_in fuel h a }
head_in fuel (G.ZFirst id) out =
bc_first_in comp out id fuel >>= \x -> case x of
Dataflow a -> return (fuel, a)
- Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (fuel-1) g out }
+ Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (oneLessFuel fuel) g out }
in do { fuel <-
run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
@@ -498,7 +521,7 @@ solve_and_rewrite_b comp fuel graph exit_fact =
Rewrite g ->
do { markGraphRewritten
; bot <- botFact
- ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g bot
+ ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g bot
; let G.Graph t new_blocks = g'
; let rewritten' = new_blocks `plusUFM` rewritten
; propagate fuel h a t rewritten' -- continue at entry of g'
@@ -514,7 +537,7 @@ solve_and_rewrite_b comp fuel graph exit_fact =
Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
Rewrite g ->
do { markGraphRewritten
- ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
+ ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g out
; let G.Graph t newblocks = G.splice_tail g' tail
; my_trace "Rewrote middle node"
(f4sep [ppr m, text "to", pprGraph g']) $
@@ -527,7 +550,7 @@ solve_and_rewrite_b comp fuel graph exit_fact =
; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
Rewrite g ->
do { markGraphRewritten
- ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
+ ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g out
; let G.Graph t newblocks = G.splice_tail g' tail
; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$
propagate fuel h a t (newblocks `plusUFM` rewritten) }
@@ -551,11 +574,11 @@ solve_and_rewrite_b_graph comp fuel graph exit_fact =
(fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact
return (fuel, a, remove_entry_label g')
-b_rewrite comp g =
- do { fuel <- liftTx txRemaining
+b_rewrite comp g =
+ do { fuel <- fuelRemaining
; bot <- botFact
; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
- ; liftTx $ txDecrement (bc_name comp) fuel fuel'
+ ; fuelDecrement (bc_name comp) fuel fuel'
; return gc
}
@@ -603,7 +626,8 @@ ignore_transactions_b comp =
answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
answer' lift fuel r a =
- case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g }
+ case r of Just gc | canRewriteWithFuel fuel
+ -> do { g <- lift gc; return $ Rewrite g }
_ -> return $ Dataflow a
unlimited_answer'
@@ -652,24 +676,20 @@ refine_f_anal comp graph initial =
where blocks = G.postorder_dfs graph
set_successor_facts () (G.Block id t) =
let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
- forward in' (G.ZLast l) = setEdgeFacts (last_outs comp in' l)
+ forward in' (G.ZLast l) = last_outs setEdgeFacts comp in' l
_blockname = if id == G.lg_entry graph then "<entry>" else show id
in getFact id >>= \a -> forward (fc_first_out comp a id) t
setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
setEdgeFact (id, a) = setFact id a
-last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
-last_outs comp i (G.LastExit) = fc_exit_outs comp i
-last_outs comp i (G.LastOther l) = fc_last_outs comp i l
+last_outs :: (DataflowAnalysis df, Outputable a) => (LastOutFacts a -> df a ()) -> FComputation m l i a (LastOutFacts a) -> i -> G.ZLast l -> df a ()
+last_outs _do_last_outs comp i (G.LastExit) = setExitFact (fc_exit_out comp i)
+last_outs do_last_outs comp i (G.LastOther l) = do_last_outs $ fc_last_outs comp i l
--- | In the general case we solve a graph in the context of a larger subgraph.
--- To do this, we need a locally modified computation that allows an
--- ``exit fact'' to flow out of the exit node. We pass in a fresh BlockId
--- to which the exit fact can flow
+last_rewrite :: FComputation m l i a a -> i -> G.ZLast l -> a
+last_rewrite comp i (G.LastExit) = fc_exit_out comp i
+last_rewrite comp i (G.LastOther l) = fc_last_outs comp i l
-comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
-comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
- where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
-- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
-- forward analysis on the modified computation.
@@ -678,15 +698,13 @@ solve_graph_f ::
FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
DFM a (OptimizationFuel, a, LastOutFacts a)
solve_graph_f comp fuel g in_fact =
- do { exit_fact_id <- freshBlockId "proxy for exit node"
- ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
- ; a <- getFact exit_fact_id
+ do { fuel <- general_forward fuel in_fact g
+ ; a <- getExitFact
; outs <- lastOutFacts
- ; forgetFact exit_fact_id -- close space leak
- ; return (fuel, a, LastOutFacts outs) }
+ ; return (fuel, a, outs) }
where
-- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
- general_forward comp fuel entry_fact graph =
+ general_forward fuel entry_fact graph =
let blocks = G.postorder_dfs g
is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
-- set_or_save :: LastOutFacts a -> DFM a ()
@@ -702,15 +720,19 @@ solve_graph_f comp fuel g in_fact =
Dataflow a -> set_tail_facts fuel a t
Rewrite g ->
do (fuel, out, last_outs) <-
- subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
+ subAnalysis' $ solve_graph_f_g comp (oneLessFuel fuel) g in'
set_or_save last_outs
set_tail_facts fuel out t
- set_tail_facts fuel in' (G.ZLast l) =
- last_outs comp in' l fuel >>= \x -> case x of
+ set_tail_facts fuel in' (G.ZLast LastExit) =
+ fc_exit_out comp in' fuel >>= \x -> case x of
+ Dataflow a -> do { setExitFact a; return fuel }
+ Rewrite _g -> error "rewriting exit node not implemented"
+ set_tail_facts fuel in' (G.ZLast (G.LastOther l)) =
+ fc_last_outs comp in' l fuel >>= \x -> case x of
Dataflow outs -> do { set_or_save outs; return fuel }
Rewrite g ->
do (fuel, _, last_outs) <-
- subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
+ subAnalysis' $ solve_graph_f_g comp (oneLessFuel fuel) g in'
set_or_save last_outs
return fuel
G.Block id t = b
@@ -719,7 +741,7 @@ solve_graph_f comp fuel g in_fact =
case infact of Dataflow a -> set_tail_facts fuel a t
Rewrite g ->
do (fuel, out, last_outs) <- subAnalysis' $
- solve_graph_f_g comp (fuel-1) g idfact
+ solve_graph_f_g comp (oneLessFuel fuel) g idfact
set_or_save last_outs
set_tail_facts fuel out t
in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
@@ -747,11 +769,180 @@ solve_and_rewrite_f ::
DFM a (OptimizationFuel, a, LGraph m l)
solve_and_rewrite_f comp fuel graph in_fact =
do solve_graph_f comp fuel graph in_fact -- pass 1
- exit_id <- freshBlockId "proxy for exit node"
- (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact
- exit_fact <- getFact exit_id
+ (fuel, g) <- forward_rewrite comp fuel graph in_fact
+ exit_fact <- getExitFact --- XXX should drop this; it's in the monad
return (fuel, exit_fact, g)
+f_shallow_rewrite anal ftx in_fact g =
+ do { fuel <- fuelRemaining
+ ; solve_shallow_graph_f (return ()) anal ftx in_fact g fuel
+ ; id <- freshBlockId "temporary entry id"
+ ; (blocks, fuel') <-
+ forward_rewrite_gen don't_rewrite anal ftx (ZFirst id) in_fact g fuel
+ ; fuelDecrement (fc_name ftx) fuel fuel'
+ ; return (remove_entry_label (LGraph id blocks))
+ }
+ where don't_rewrite finish g fuel = finish >>= \b -> return (b, g, fuel)
+
+
+shallow_tail_solve_f
+ :: (DebugNodes m l, Outputable a)
+ => DFM a b -- final action and result after solving this tail
+ -> FAnalysis m l a -> FFunctionalTransformation m l a
+ -> (BlockId -> Bool) -- local blocks
+ -> a -> ZTail m l -> OptimizationFuel -> DFM a (b, OptimizationFuel)
+shallow_tail_solve_f finish anal ftx is_local in' (G.ZTail m t) fuel =
+ my_trace "Solving middle node" (ppr m) $
+ case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of
+ Just g -> do out <- subAnalysis' $ liftAnal $
+ anal_f_general getExitFact anal in' g
+ shallow_tail_solve_f finish anal ftx is_local out t (oneLessFuel fuel)
+ Nothing -> shallow_tail_solve_f finish anal ftx is_local
+ (fc_middle_out anal in' m) t fuel
+shallow_tail_solve_f finish anal ftx is_local in' (G.ZLast (G.LastOther l)) fuel =
+ case maybeRewriteWithFuel fuel $ fc_last_outs ftx in' l of
+ Just g -> do { last_outs <-
+ subAnalysis' $ liftAnal $ anal_f_general lastOutFacts anal in' g
+ ; set_or_save last_outs
+ ; b <- finish
+ ; return (b, oneLessFuel fuel) }
+ Nothing -> do { set_or_save (fc_last_outs anal in' l)
+ ; b <- finish
+ ; return (b, fuel) }
+ where set_or_save = mk_set_or_save is_local
+shallow_tail_solve_f finish anal ftx _is_local in' (G.ZLast LastExit) fuel =
+ case maybeRewriteWithFuel fuel $ fc_exit_out ftx in' of
+ Just g -> do { a <-
+ subAnalysis' $ liftAnal $ anal_f_general getExitFact anal in' g
+ ; setExitFact a
+ ; b <- finish
+ ; return (b, oneLessFuel fuel) }
+ Nothing -> do { setExitFact $ fc_exit_out anal in'
+ ; b <- finish
+ ; return (b, fuel) }
+
+anal_f_general :: (DebugNodes m l, Outputable a)
+ => DFA a b -> FAnalysis m l a -> a -> Graph m l -> DFA a b
+anal_f_general finish anal in_fact (Graph entry blockenv) =
+ general_forward in_fact
+ where
+ is_local id = isJust $ lookupBlockEnv blockenv id
+ set_or_save = mk_set_or_save is_local
+ anal_tail = gen_tail_anal_f set_or_save anal
+ blocks = G.postorder_dfs_from blockenv entry
+ general_forward in_fact =
+ do { let setup = anal_tail in_fact entry -- sufficient to do once
+ ; let set_successor_facts () (Block id tail) =
+ do { idfact <- getFact id
+ ; anal_tail (fc_first_out anal idfact id) tail }
+ ; run "forward" (fc_name anal) setup set_successor_facts () blocks
+ ; finish
+ }
+
+gen_tail_anal_f :: (Outputable a) =>
+ (LastOutFacts a -> DFA a ()) -> FAnalysis m l a -> a -> ZTail m l -> DFA a ()
+gen_tail_anal_f do_last_outs anal a tail = propagate a tail
+ where propagate a (ZTail m t) = propagate (fc_middle_out anal a m) t
+ propagate a (ZLast LastExit) = setExitFact (fc_exit_out anal a)
+ propagate a (ZLast (LastOther l)) = do_last_outs $ fc_last_outs anal a l
+
+
+solve_shallow_graph_f ::
+ (DebugNodes m l, Outputable a) =>
+ DFM a b ->
+ FAnalysis m l a -> FFunctionalTransformation m l a -> a -> G.Graph m l
+ -> OptimizationFuel -> DFM a (b, OptimizationFuel)
+solve_shallow_graph_f finish anal ftx in_fact (Graph entry blockenv) fuel =
+ do { fuel <- general_forward in_fact fuel
+ ; b <- finish
+ ; return (b, fuel) }
+ where
+ is_local id = isJust $ lookupBlockEnv blockenv id
+ set_or_save = mk_set_or_save is_local
+ solve_tail = shallow_tail_solve_f lastOutFacts anal ftx is_local
+ blocks = G.postorder_dfs_from blockenv entry
+ name = concat [fc_name anal, " and ", fc_name ftx]
+ general_forward in_fact fuel =
+ do { (last_outs, fuel) <- solve_tail in_fact entry fuel
+ ; set_or_save last_outs
+ ; let set_successor_facts fuel (Block id tail) =
+ do { idfact <- getFact id
+ ; (last_outs, fuel) <-
+ case maybeRewriteWithFuel fuel $ fc_first_out ftx idfact id of
+ Nothing -> solve_tail idfact tail fuel
+ Just g ->
+ do outfact <-
+ subAnalysis' $ liftAnal $
+ anal_f_general getExitFact anal idfact g
+ solve_tail outfact tail (oneLessFuel fuel)
+ ; set_or_save last_outs
+ ; return fuel }
+ ; run "forward" name (return ()) set_successor_facts fuel blocks }
+
+mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
+ (BlockId -> Bool) -> LastOutFacts a -> df a ()
+mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
+ where set_or_save_one (id, a) =
+ if is_local id then setFact id a else addLastOutFact (id, a)
+
+lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
+lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
+
+
+fwd_rew_tail_gen :: (DebugNodes m l, Outputable a) =>
+ (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) ->
+ FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> ZTail m l
+ -> BlockEnv (Block m l)
+ -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel)
+fwd_rew_tail_gen recursive_rewrite anal ftx head in_fact tail rewritten fuel =
+ propagate head in_fact tail rewritten fuel
+ where
+ propagate h in' (G.ZTail m t) rewritten fuel =
+ my_trace "Rewriting middle node" (ppr m) $
+ case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of
+ Nothing -> propagate (G.ZHead h m) (fc_middle_out anal in' m) t rewritten fuel
+ Just g -> do markGraphRewritten
+ (a, g, fuel) <- recursive_rewrite getExitFact g fuel
+ let (blocks, h') = G.splice_head' h g
+ propagate h' a t (blocks `plusUFM` rewritten) fuel
+ propagate h in' (G.ZLast l) rewritten fuel =
+ case maybeRewriteWithFuel fuel $ last_rewrite ftx in' l of
+ Nothing -> -- can throw away facts because this is the rewriting phase
+ return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
+ Just g -> do markGraphRewritten
+ ((), g, fuel) <- recursive_rewrite (return ()) g fuel
+ let g' = G.splice_head_only' h g
+ return (G.lg_blocks g' `plusUFM` rewritten, fuel)
+
+forward_rewrite_gen ::
+ (DebugNodes m l, Outputable a) =>
+ (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) ->
+ FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> Graph m l
+ -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel)
+forward_rewrite_gen recursive_rewrite anal ftx head a (Graph entry blockenv) fuel =
+ do (rewritten, fuel) <- rewrite_tail head a entry emptyBlockEnv fuel
+ rewrite_blocks (G.postorder_dfs_from blockenv entry) rewritten fuel
+ where
+ -- need to build in some checking for consistency of facts
+ rewrite_tail = fwd_rew_tail_gen recursive_rewrite anal ftx
+ rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
+ rewrite_blocks (G.Block id t : bs) rewritten fuel =
+ do id_fact <- getFact id
+ case maybeRewriteWithFuel fuel $ fc_first_out ftx id_fact id of
+ Nothing -> do { (rewritten, fuel) <-
+ rewrite_tail (ZFirst id) id_fact t rewritten fuel
+ ; rewrite_blocks bs rewritten fuel }
+ Just g -> do { (outfact, g, fuel) <- recursive_rewrite getExitFact g fuel
+ ; let (blocks, h) = splice_head' (ZFirst id) g
+ ; (rewritten, fuel) <-
+ rewrite_tail h outfact t (blocks `plusUFM` rewritten) fuel
+ ; rewrite_blocks bs rewritten fuel }
+
+
+
+
+
+
solve_and_rewrite_f_graph ::
(DebugNodes m l, Outputable a) =>
FPass m l a -> OptimizationFuel -> Graph m l -> a ->
@@ -786,7 +977,7 @@ forward_rewrite comp fuel graph entry_fact =
case first_out of
Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
Rewrite g -> do { markGraphRewritten
- ; rewrite_blocks (fuel-1) rewritten
+ ; rewrite_blocks (oneLessFuel fuel) rewritten
(G.postorder_dfs (labelGraph id g) ++ bs) }
-- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
-- [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
@@ -796,25 +987,36 @@ forward_rewrite comp fuel graph entry_fact =
Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
Rewrite g ->
do markGraphRewritten
- (fuel, a, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
+ (fuel, a, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in'
let (blocks, h') = G.splice_head' h g
propagate fuel h' a t (blocks `plusUFM` rewritten) bs
- propagate fuel h in' (G.ZLast l) rewritten bs =
- do last_outs comp in' l fuel >>= \x -> case x of
+ propagate fuel h in' t@(G.ZLast G.LastExit) rewritten bs =
+ do fc_exit_out comp in' fuel >>= \x -> case x of
+ Dataflow a ->
+ do setExitFact a
+ let b = G.zipht h t
+ rewrite_blocks fuel (G.insertBlock b rewritten) bs
+ Rewrite g ->
+ do markGraphRewritten
+ (fuel, _, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in'
+ let g' = G.splice_head_only' h g
+ rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
+ propagate fuel h in' t@(G.ZLast (G.LastOther l)) rewritten bs =
+ do fc_last_outs comp in' l fuel >>= \x -> case x of
Dataflow outs ->
do set_or_save outs
- let b = G.zip (G.ZBlock h (G.ZLast l))
+ let b = G.zipht h t
rewrite_blocks fuel (G.insertBlock b rewritten) bs
Rewrite g ->
do markGraphRewritten
- (fuel, _, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
+ (fuel, _, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in'
let g' = G.splice_head_only' h g
rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
f_rewrite comp entry_fact g =
- do { fuel <- liftTx txRemaining
+ do { fuel <- fuelRemaining
; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
- ; liftTx $ txDecrement (fc_name comp) fuel fuel'
+ ; fuelDecrement (fc_name comp) fuel fuel'
; return gc
}
@@ -848,7 +1050,7 @@ let debug s (f, comp) =
anal_f comp = comp { fc_first_out = wrap2 $ fc_first_out comp
, fc_middle_out = wrap2 $ fc_middle_out comp
, fc_last_outs = wrap2 $ fc_last_outs comp
- , fc_exit_outs = wrap1 $ fc_exit_outs comp
+ , fc_exit_out = wrap1 $ fc_exit_out comp
}
where wrap2 f out node _fuel = return $ Dataflow (f out node)
wrap1 f fact _fuel = return $ Dataflow (f fact)
@@ -862,11 +1064,11 @@ a_t_f anal tx =
answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
last_outs in' l fuel =
answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
- exit_outs in' fuel = undefined
- answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in')
+ exit_out in' fuel = undefined
+ answer fuel (fc_exit_out tx in') (fc_exit_out anal in')
in FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
, fc_last_outs = last_outs, fc_middle_out = middle_out
- , fc_first_out = first_out, fc_exit_outs = exit_outs }
+ , fc_first_out = first_out, fc_exit_out = exit_out }
f4sep :: [SDoc] -> SDoc
@@ -889,3 +1091,10 @@ subAnalysis' m =
_unused :: FS.FastString
_unused = undefined
+
+null_b_ft = BComp "do nothing" Nothing no2 no2 no2
+ where no2 _ _ = Nothing
+
+null_f_ft = FComp "do nothing" no2 no2 no2 (\_ -> Nothing)
+ where no2 _ _ = Nothing
+
View Lorry Controller Status