Commit bfbdbcb9 authored by Simon Marlow's avatar Simon Marlow

Remove "fuel", adapt to Hoopl changes, fix warnings

parent 3f0afaba
......@@ -15,7 +15,7 @@ import Outputable
import Unique
import Compiler.Hoopl as Hoopl hiding (Unique)
import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
import Compiler.Hoopl.Internals (uniqueToLbl)
----------------------------------------------------------------
--- Block Ids, their environments, and their sets
......
......@@ -32,9 +32,9 @@ module Cmm (
import CLabel
import BlockId
import CmmNode
import OptimizationFuel as F
import SMRep
import CmmExpr
import UniqSupply
import Compiler.Hoopl
import Data.Word ( Word8 )
......@@ -93,9 +93,9 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
-----------------------------------------------------------------------------
-- Info Tables
......
......@@ -38,7 +38,6 @@ import IdInfo
import Data.List
import Maybes
import Name
import OptimizationFuel
import Outputable
import SMRep
import UniqSupply
......@@ -149,7 +148,7 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT)
UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl z = -- get CAFs for functions without static closures
case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
......@@ -192,7 +191,7 @@ buildSRTs topSRT topCAFMap cafs =
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
FuelUniqSM (Maybe CmmDecl, C_SRT)
UniqSM (Maybe CmmDecl, C_SRT)
procpointSRT _ _ [] =
return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
......@@ -210,7 +209,7 @@ maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmDecl, C_SRT)
to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT top_srt off len bmp
| len > maxBmpSize || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM
......@@ -276,12 +275,12 @@ bundleCAFs _ t = (Set.empty, t)
-- Construct the SRTs for the given procedure.
setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
FuelUniqSM (TopSRT, [CmmDecl])
UniqSM (TopSRT, [CmmDecl])
setInfoTableSRT topCAFMap topSRT (cafs, t) =
setSRT cafs topCAFMap topSRT t
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
CmmDecl -> FuelUniqSM (TopSRT, [CmmDecl])
CmmDecl -> UniqSM (TopSRT, [CmmDecl])
setSRT cafs topCAFMap topSRT t =
do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
let t' = updInfo id (const srt) t
......
......@@ -53,7 +53,6 @@ assignArgumentsPos conv arg_ty reps = assignments
([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode
(_, Slow) -> noRegs
_ -> pprPanic "Unknown calling convention" (ppr conv)
-- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers
-- (even if there are still available registers for args of a different type).
......
......@@ -20,7 +20,6 @@ import Hoopl hiding (ChangeFlag)
import Data.Bits
import qualified Data.List as List
import Data.Word
import FastString
import Outputable
import UniqFM
......@@ -95,7 +94,7 @@ hash_block block =
hash_lst m h = hash_node m + h `shiftL` 1
hash_node :: CmmNode O x -> Word32
hash_node (CmmComment (FastString u _ _ _ _)) = 0 -- don't care
hash_node (CmmComment _) = 0 -- don't care
hash_node (CmmAssign r e) = hash_reg r + hash_e e
hash_node (CmmStore e e') = hash_e e + hash_e e'
hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
......@@ -148,7 +147,7 @@ lookupBid subst bid = case mapLookup bid subst of
--
eqMiddleWith :: (BlockId -> BlockId -> Bool)
-> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith eqBid (CmmComment _) (CmmComment _) = True
eqMiddleWith _ (CmmComment _) (CmmComment _) = True
eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
= r1 == r2 && eqExprWith eqBid e1 e2
eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
......
......@@ -97,7 +97,7 @@ blockConcat g@CmmGraph { g_entry = entry_id }
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId)
-> (BlockEnv CmmBlock, BlockEnv BlockId)
maybe_concat block unchanged@(blocks, shortcut_map)
maybe_concat block (blocks, shortcut_map)
| CmmBranch b' <- last
, Just blk' <- mapLookup b' blocks
, shouldConcatWith b' blk'
......
......@@ -32,7 +32,6 @@ import BlockId
import CLabel
import Unique
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Set as Set
......
......@@ -17,7 +17,6 @@ import CmmLive
import CmmProcPoint
import SMRep
import Hoopl hiding ((<*>), mkLast, mkMiddle)
import OptimizationFuel
import Constants
import UniqSupply
import Maybes
......@@ -105,7 +104,7 @@ instance Outputable StackMap where
cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
-> FuelUniqSM (CmmGraph, BlockEnv StackMap)
-> UniqSM (CmmGraph, BlockEnv StackMap)
cmmLayoutStack procpoints entry_args
graph0@(CmmGraph { g_entry = entry })
= do
......@@ -114,12 +113,12 @@ cmmLayoutStack procpoints entry_args
pprTrace "liveness" (ppr liveness) $ return ()
let blocks = postorderDfs graph
(final_stackmaps, final_high_sp, new_blocks) <- liftUniq $
(final_stackmaps, final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
layout procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks
new_blocks' <- liftUniq $ mapM lowerSafeForeignCall new_blocks
new_blocks' <- mapM lowerSafeForeignCall new_blocks
pprTrace ("Sp HWM") (ppr final_high_sp) $
return (ofBlockList entry new_blocks', final_stackmaps)
......@@ -248,7 +247,7 @@ collectContInfo blocks
-- Updating the StackMap from middle nodes
-- Look for loads from stack slots, and update the StackMap. This is
-- purelyu for optimisation reasons, so that we can avoid saving a
-- purely for optimisation reasons, so that we can avoid saving a
-- variable back to a different stack slot if it is already on the
-- stack.
--
......@@ -361,6 +360,7 @@ handleLastNode procpoints liveness cont_info stackmaps
= setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0
-- For other last nodes (branches), if any of the targets is a
-- proc point, we have to set up the stack to match what the proc
-- point is expecting.
--
......@@ -701,7 +701,7 @@ manifestSp stackmaps stack0 sp0 sp_high
final_block = blockJoin first final_middle final_last
fixup_blocks' = map (blockMapNodes3 (id, adj_post_sp, id)) fixup_blocks
fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
......@@ -982,7 +982,7 @@ stackSlotRegs sm = eltsUFM (sm_regs sm)
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.
cmmSink :: CmmGraph -> FuelUniqSM CmmGraph
cmmSink :: CmmGraph -> UniqSM CmmGraph
cmmSink graph = do
let liveness = cmmLiveness graph
return $ cmmSink' liveness graph
......
......@@ -16,7 +16,6 @@ import CmmUtils
import PprCmm ()
import BlockId
import FastString
import CLabel
import Outputable
import Constants
......
......@@ -11,11 +11,10 @@ module CmmLive
)
where
import UniqSupply
import BlockId
import Cmm
import CmmUtils
import Control.Monad
import OptimizationFuel
import PprCmmExpr ()
import Hoopl
......@@ -81,7 +80,7 @@ xferLive = mkBTransfer3 fst mid lst
-- Removing assignments to dead variables
-----------------------------------------------------------------------------
removeDeadAssignments :: CmmGraph -> FuelUniqSM (CmmGraph, BlockEnv CmmLive)
removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive)
removeDeadAssignments g =
dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites
where rewrites = mkBRewrite3 nothing middle nothing
......
......@@ -400,5 +400,5 @@ mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n)
mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
mapSuccessors f n = n
mapSuccessors _ n = n
......@@ -16,9 +16,9 @@ import CmmBuildInfoTables
import CmmCommonBlockElim
import CmmProcPoint
import CmmContFlowOpt
import OptimizationFuel
import CmmLayoutStack
import UniqSupply
import DynFlags
import ErrUtils
import HscTypes
......@@ -65,7 +65,7 @@ cmmPipeline hsc_env topSRT prog =
let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
-- folding over the groups
(topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
(topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops topCAFEnv) (topSRT, []) tops
let cmms :: CmmGroup
cmms = reverse (concat tops)
......@@ -101,17 +101,17 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Proc points -------------------
let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
procPoints <- {-# SCC "minimalProcPointSet" #-} run $
procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet (targetPlatform dflags) callPPs g
----------- Layout the stack and manifest Sp ---------------
-- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
(g, stackmaps) <- {-# SCC "layoutStack" #-}
run $ cmmLayoutStack procPoints entry_off g
runUniqSM $ cmmLayoutStack procPoints entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- {-# SCC "sink" #-} run $ cmmSink g
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
-- g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
-- dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
-- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
......@@ -119,10 +119,10 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
------------- Split into separate procedures ------------
procPointMap <- {-# SCC "procPointAnalysis" #-} run $
procPointMap <- {-# SCC "procPointAnalysis" #-} runUniqSM $
procPointAnalysis procPoints g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- {-# SCC "splitAtProcPoints" #-} run $
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
......@@ -156,8 +156,10 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dumps flag name
= mapM_ (dumpWith dflags flag name)
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
us <- mkSplitUniqSupply 'u'
return (initUs_ us m)
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
......@@ -183,11 +185,11 @@ dumpWith dflags flag txt g = do
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
toTops hsc_env topCAFEnv (topSRT, tops) gs =
toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
toTops topCAFEnv (topSRT, tops) gs =
do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
return (topSRT, gs : rst)
(topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
(topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs
return (topSRT, concat gs' : tops)
......@@ -13,19 +13,14 @@ import Prelude hiding (last, unzip, succ, zip)
import BlockId
import CLabel
import Cmm
import PprCmm ()
import CmmUtils
import CmmContFlowOpt
import CmmInfo
import CmmLive
import Constants
import Data.List (sortBy)
import Maybes
import MkGraph
import Control.Monad
import OptimizationFuel
import Outputable
import Platform
import UniqSet
import UniqSupply
import Hoopl
......@@ -106,7 +101,7 @@ instance Outputable Status where
--------------------------------------------------
-- Proc point analysis
procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
-- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from
procPointAnalysis procPoints g =
......@@ -156,13 +151,13 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
_ -> set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-> FuelUniqSM ProcPointSet
-> UniqSM ProcPointSet
-- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points
minimalProcPointSet platform callProcPoints g
= extendPPSet platform g (postorderDfs g) callProcPoints
extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet platform g blocks procPoints =
do env <- procPointAnalysis procPoints g
-- pprTrace "extensPPSet" (ppr env) $ return ()
......@@ -212,10 +207,9 @@ extendPPSet platform g blocks procPoints =
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> FuelUniqSM [CmmDecl]
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbl=info_tbl,
stack_info=stack_info})
(CmmProc (TopInfo {info_tbl=info_tbl})
top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
let addBlock b graphEnv =
......
......@@ -18,10 +18,9 @@ module CmmRewriteAssignments
import Cmm
import CmmUtils
import CmmOpt
import OptimizationFuel
import StgCmmUtils
import Control.Monad
import UniqSupply
import Platform
import UniqFM
import Unique
......@@ -29,12 +28,13 @@ import BlockId
import Hoopl
import Data.Maybe
import Control.Monad
import Prelude hiding (succ, zip)
----------------------------------------------------------------
--- Main function
rewriteAssignments :: Platform -> CmmGraph -> FuelUniqSM CmmGraph
rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph
rewriteAssignments platform g = do
-- Because we need to act on forwards and backwards information, we
-- first perform usage analysis and bake this information into the
......@@ -213,7 +213,7 @@ usageTransfer = mkBTransfer3 first middle last
increaseUsage f r = addToUFM_C combine f r SingleUse
where combine _ _ = ManyUse
usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
usageRewrite :: BwdRewrite UniqSM (WithRegUsage CmmNode) UsageMap
usageRewrite = mkBRewrite3 first middle last
where first _ _ = return Nothing
middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
......@@ -226,7 +226,7 @@ usageRewrite = mkBRewrite3 first middle last
last _ _ = return Nothing
type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
annotateUsage :: CmmGraph -> UniqSM (CmmGraphWithRegUsage)
annotateUsage vanilla_g =
let g = modifyGraph liftRegUsage vanilla_g
in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
......@@ -524,7 +524,7 @@ assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase ass
-- values from the assignment map, due to reassignment of the local
-- register.) This is probably not locally sound.
assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
assignmentRewrite :: FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap
assignmentRewrite = mkFRewrite3 first middle last
where
first _ _ = return Nothing
......@@ -605,7 +605,7 @@ assignmentRewrite = mkFRewrite3 first middle last
-- in literals, which we can inline more aggressively, and inlining
-- gives us opportunities for more folding. However, we don't need any
-- facts to do MachOp folding.
machOpFoldRewrite :: Platform -> FwdRewrite FuelUniqSM (WithRegUsage CmmNode) a
machOpFoldRewrite :: Platform -> FwdRewrite UniqSM (WithRegUsage CmmNode) a
machOpFoldRewrite platform = mkFRewrite3 first middle last
where first _ _ = return Nothing
middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O
......
......@@ -35,7 +35,6 @@ import CmmProcPoint
import Maybes
import MkGraph (stackStubExpr)
import Control.Monad
import OptimizationFuel
import Outputable
import SMRep (ByteOff)
......
......@@ -80,7 +80,6 @@ import Cmm
import BlockId
import CLabel
import Outputable
import OptimizationFuel as F
import Unique
import UniqSupply
import Constants( wORD_SIZE, tAG_MASK )
......@@ -89,7 +88,6 @@ import Util
import Data.Word
import Data.Maybe
import Data.Bits
import Control.Monad
import Hoopl
---------------------------------------------------
......@@ -431,10 +429,10 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph
mapGraphNodes funs@(mf,_,_) g =
ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g
ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (mapBlock3' funs) $ toBlockMap g
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 f g = modifyGraph (graphMapBlocks (blockMapNodes f)) g
mapGraphNodes1 f = modifyGraph (mapGraph f)
foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
......@@ -447,21 +445,21 @@ postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g
-- Running dataflow analysis and/or rewrites
-- Constructing forward and backward analysis-only pass
analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass FuelUniqSM n f
analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass FuelUniqSM n f
analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f
analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f
analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
-- Constructing forward and backward analysis + rewrite pass
analRewFwd :: DataflowLattice f -> FwdTransfer n f
-> FwdRewrite FuelUniqSM n f
-> FwdPass FuelUniqSM n f
-> FwdRewrite UniqSM n f
-> FwdPass UniqSM n f
analRewBwd :: DataflowLattice f
-> BwdTransfer n f
-> BwdRewrite FuelUniqSM n f
-> BwdPass FuelUniqSM n f
-> BwdRewrite UniqSM n f
-> BwdPass UniqSM n f
analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
......@@ -469,23 +467,23 @@ analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewr
-- Running forward and backward dataflow analysis + optional rewrite
dataflowPassFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass FuelUniqSM n f
-> FuelUniqSM (GenCmmGraph n, BlockEnv f)
-> FwdPass UniqSM n f
-> UniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
(graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
dataflowAnalFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass FuelUniqSM n f
-> FwdPass UniqSM n f
-> BlockEnv f
dataflowAnalFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd =
analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
dataflowAnalFwdBlocks :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass FuelUniqSM n f
-> FuelUniqSM (BlockEnv f)
-> FwdPass UniqSM n f
-> UniqSM (BlockEnv f)
dataflowAnalFwdBlocks (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
-- (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
-- return facts
......@@ -493,15 +491,15 @@ dataflowAnalFwdBlocks (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
dataflowAnalBwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> BwdPass FuelUniqSM n f
-> BwdPass UniqSM n f
-> BlockEnv f
dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd =
analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
dataflowPassBwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> BwdPass FuelUniqSM n f
-> FuelUniqSM (GenCmmGraph n, BlockEnv f)
-> BwdPass UniqSM n f
-> UniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
(graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
module Hoopl (
module Compiler.Hoopl,
module Hoopl.Dataflow,
deepBwdRw3, deepBwdRw,
deepFwdRw, deepFwdRw3,
deepBwdRw, deepBwdRw3,
thenFwdRw
) where
......@@ -10,7 +11,7 @@ import Compiler.Hoopl hiding
FwdTransfer(..), FwdRewrite(..), FwdPass(..),
BwdTransfer(..), BwdRewrite(..), BwdPass(..),
noFwdRewrite, noBwdRewrite,
-- analyzeAndRewriteFwd, analyzeAndRewriteBwd,
analyzeAndRewriteFwd, analyzeAndRewriteBwd,
mkFactBase, Fact,
mkBRewrite, mkBRewrite3, mkBTransfer, mkBTransfer3,
mkFRewrite, mkFRewrite3, mkFTransfer, mkFTransfer3,
......@@ -19,53 +20,53 @@ import Compiler.Hoopl hiding
)
import Hoopl.Dataflow
import OptimizationFuel
import Control.Monad
import UniqSupply
deepFwdRw3 :: (n C O -> f -> FuelUniqSM (Maybe (Graph n C O)))
-> (n O O -> f -> FuelUniqSM (Maybe (Graph n O O)))
-> (n O C -> f -> FuelUniqSM (Maybe (Graph n O C)))
-> (FwdRewrite FuelUniqSM n f)
deepFwdRw :: (forall e x . n e x -> f -> FuelUniqSM (Maybe (Graph n e x))) -> FwdRewrite FuelUniqSM n f
deepFwdRw3 :: (n C O -> f -> UniqSM (Maybe (Graph n C O)))
-> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
-> (n O C -> f -> UniqSM (Maybe (Graph n O C)))
-> (FwdRewrite UniqSM n f)
deepFwdRw :: (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x))) -> FwdRewrite UniqSM n f
deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l
deepFwdRw f = deepFwdRw3 f f f
-- N.B. rw3, rw3', and rw3a are triples of functions.
-- But rw and rw' are single functions.
thenFwdRw :: forall n f.
FwdRewrite FuelUniqSM n f
-> FwdRewrite FuelUniqSM n f
-> FwdRewrite FuelUniqSM n f
FwdRewrite UniqSM n f
-> FwdRewrite UniqSM n f
-> FwdRewrite UniqSM n f
thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
where
thenrw :: forall e x t t1.
(t -> t1 -> FuelUniqSM (Maybe (Graph n e x, FwdRewrite FuelUniqSM n f)))
-> (t -> t1 -> FuelUniqSM (Maybe (Graph n e x, FwdRewrite FuelUniqSM n f)))
(t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> t
-> t1
-> FuelUniqSM (Maybe (Graph n e x, FwdRewrite FuelUniqSM n f))
-> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
thenrw rw rw' n f = rw n f >>= fwdRes
where fwdRes Nothing = rw' n f
fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr
iterFwdRw :: forall m n f.
FwdRewrite FuelUniqSM n f
-> FwdRewrite FuelUniqSM n f
iterFwdRw :: forall n f.
FwdRewrite UniqSM n f
-> FwdRewrite UniqSM n f
iterFwdRw rw3 = wrapFR iter rw3
where iter :: forall a e x t.
(t -> a -> FuelUniqSM (Maybe (Graph n e x, FwdRewrite FuelUniqSM n f)))
(t -> a -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> t
-> a