Commit 46b03136 authored by Simon Marlow's avatar Simon Marlow

Snapshot

parent 919a298f
......@@ -55,7 +55,7 @@ import Platform
import SMRep
import UniqSupply
import Compiler.Hoopl
import Hoopl
import Data.Map (Map)
import qualified Data.Map as Map
......@@ -216,7 +216,7 @@ cafTransfers platform = mkBTransfer3 first middle last
cafAnal :: Platform -> CmmGraph -> FuelUniqSM CAFEnv
cafAnal platform g
= liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice (cafTransfers platform)
= dataflowAnalBwd g [] $ analBwd cafLattice (cafTransfers platform)
-----------------------------------------------------------------------
-- Building the SRTs
......
......@@ -13,17 +13,16 @@ where
import BlockId
import Cmm
import CmmUtils
import CmmContFlowOpt
import Prelude hiding (iterate, succ, unzip, zip)
import Compiler.Hoopl
import Hoopl hiding (ChangeFlag)
import Data.Bits
import qualified Data.List as List
import Data.Word
import FastString
import Control.Monad
import Outputable
import UniqFM
import Unique
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
......@@ -71,7 +70,7 @@ common_block (old_change, bmap, subst) (hash, b) =
(Just b', Nothing) -> addSubst b'
(Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
_ -> (old_change, addToUFM bmap hash (b : bs), subst)
Nothing -> (old_change, (addToUFM bmap hash [b], subst))
Nothing -> (old_change, addToUFM bmap hash [b], subst)
where bid = entryLabel b
addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
(True, bmap, mapInsert bid (entryLabel b') subst)
......@@ -142,11 +141,13 @@ lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid
Nothing -> bid
-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
-- Equality on the body of a block, modulo a function mapping block
-- IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block
(_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
eqBlockBodyWith eqBid block block'
= blockToList m == blockToList m' && eqLastWith eqBid l l'
where (_,m,l) = blockSplit block
(_,m',l') = blockSplit block'
eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
......
......@@ -3,7 +3,7 @@
module CmmContFlowOpt
( cmmCfgOpts
, runCmmContFlowOpts
, cmmCfgOptsProc
, removeUnreachableBlocks
, replaceLabels
)
......@@ -16,9 +16,10 @@ import Digraph
import Maybes
import Outputable
import Compiler.Hoopl
import Hoopl
import Control.Monad
import Prelude hiding (succ, unzip, zip)
import qualified Data.IntMap as Map
-----------------------------------------------------------------------------
--
......@@ -26,12 +27,12 @@ import Prelude hiding (succ, unzip, zip)
--
-----------------------------------------------------------------------------
runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts = map (optProc cmmCfgOpts)
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc = optProc cmmCfgOpts
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
optProc _ top = top
......@@ -99,22 +100,22 @@ 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 unchanged@(blocks, shortcut_map)
| CmmBranch b' <- last
, Just blk' <- mapLookup b' blocks
, shouldConcatWith b' blocks
-> (mapInsert bid (splice head blk') blocks, shortcut_map)
, shouldConcatWith b' blk'
= (mapInsert bid (splice head blk') blocks, shortcut_map)
| Just b' <- callContinuation_maybe last
, Just blk' <- mapLookup b' blocks
, Just dest <- canShortcut b' blk'
-> (blocks, mapInsert b' dest shortcut_map)
, Just dest <- canShortcut blk'
= (blocks, mapInsert b' dest shortcut_map)
-- replaceLabels will substitute dest for b' everywhere, later
| otherwise = unchanged
where
(head, last) = blockTail block
bid = entryLabel b
(head, last) = blockSplitTail block
bid = entryLabel block
shouldConcatWith b block
| num_preds b == 1 = True -- only one predecessor: go for it
......@@ -122,20 +123,20 @@ blockConcat g@CmmGraph { g_entry = entry_id }
| otherwise = False
where num_preds bid = mapLookup bid backEdges `orElse` 0
canShortcut :: Block C C -> Maybe BlockId
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut block
| (_, middle, CmmBranch dest) <- blockHeadTail block
| (_, middle, CmmBranch dest) <- blockSplit block
, isEmptyBlock middle
= Just dest
| otherwise
= Nothing
backEdges :: BlockEnv Int -- number of predecessors for each block
backEdges = mapMap setSize $ predMap blocks
ToDo: add 1 for the entry id
backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
mapMap setSize $ predMap blocks
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice head rest = head `cat` snd (blockHead rest)
splice head rest = head `blockAppend` snd (blockSplitHead rest)
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
......@@ -143,9 +144,9 @@ callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
callContinuation_maybe (CmmForeignCall { succ = b }) = Just b
callContinuation_maybe _ = Nothing
okToDuplicate :: Block C C -> Bool
okToDuplicate :: CmmBlock -> Bool
okToDuplicate block
= case blockToNodeList block of (_, m, _) -> null m
= case blockSplit block of (_, m, _) -> isEmptyBlock m
-- cheap and cheerful; we might expand this in the future to
-- e.g. spot blocks that represent a single instruction or two
......@@ -155,8 +156,8 @@ okToDuplicate block
replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabels env g
| isEmptyMap env = g
| otherwise = replace_eid . mapGraphNodes1 txnode
| mapNull env = g
| otherwise = replace_eid $ mapGraphNodes1 txnode g
where
replace_eid g = g {g_entry = lookup (g_entry g)}
lookup id = mapLookup id env `orElse` id
......@@ -175,7 +176,7 @@ replaceLabels env g
exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
exp e = e
mkCmmCondBranch :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
----------------------------------------------------------------
......@@ -191,8 +192,6 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
-----------------------------------------------------------------------------
--
-- Removing unreachable blocks
--
-----------------------------------------------------------------------------
removeUnreachableBlocks :: CmmGraph -> CmmGraph
removeUnreachableBlocks g
......
......@@ -12,7 +12,7 @@ import CmmUtils
import qualified OldCmm as Old
import OldPprCmm ()
import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
import Hoopl hiding ((<*>), mkLabel, mkBranch)
import Data.Maybe
import Maybes
import Outputable
......
......@@ -11,9 +11,10 @@ module CmmLint (
) where
import Cmm
import Outputable
cmmLint :: CmmGraph -> IO ()
cmmLint g = pprTrace "ToDo! CmmLint" return ()
cmmLint g = return () -- TODO!!
-- Things to check:
-- - invariant on CmmBlock in CmmExpr (see comment there)
......
......@@ -18,7 +18,7 @@ import Control.Monad
import OptimizationFuel
import PprCmmExpr ()
import Compiler.Hoopl
import Hoopl
import Maybes
import Outputable
import UniqSet
......@@ -45,7 +45,7 @@ type BlockEntryLiveness = BlockEnv CmmLive
cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness
cmmLiveness graph =
liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive
liftM check $ dataflowAnalBwd graph [] $ analBwd liveLattice xferLive
where entry = g_entry graph
check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
......
......@@ -11,6 +11,7 @@ module CmmPipeline (
import CLabel
import Cmm
import CmmLint
import CmmLive
import CmmBuildInfoTables
import CmmCommonBlockElim
......@@ -74,10 +75,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
-- SRT is not affected by control flow optimization pass
let prog' = runCmmContFlowOpts cmms
return (topSRT, prog' : rst)
return (topSRT, cmms : rst)
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
......@@ -98,86 +96,91 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- insertLateReloads, rewriteAssignments?
----------- Control-flow optimisations ---------------
g <- return $ cmmCfgOpts g
g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
----------- Eliminate common blocks -------------------
g <- return $ elimCommonBlocks g
g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
----------- Proc points -------------------
let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
procPoints <- {-# SCC "minimalProcPointSet" #-} run $ minimalProcPointSet (targetPlatform dflags) callPPs g
g <- {-# SCC "addProcPointProtocols" #-} run $ addProcPointProtocols callPPs procPoints g
dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
g <- run $ dualLivenessWithInsertion procPoints g
g <- {-# SCC "dualLivenessWithInsertion" #-} run $ dualLivenessWithInsertion procPoints g
dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
----------- Sink and inline assignments -------------------
g <- runOptimization $ rewriteAssignments platform g
g <- {-# SCC "rewriteAssignments" #-} runOptimization $ rewriteAssignments platform g
dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
----------- Eliminate dead assignments -------------------
g <- runOptimization $ removeDeadAssignments g
g <- {-# SCC "removeDeadAssignments" #-} runOptimization $ removeDeadAssignments g
dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early
g <- if opt_StubDeadValues
then run $ stubSlotsOnDeath g
then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g
else return g
dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g
let spEntryMap = getSpEntryMap entry_off g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints spEntryMap slotEnv entry_off g
let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
------------ Manifest the stack pointer --------
g <- run $ manifestSP spEntryMap areaMap entry_off g
g <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g
dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap <- run $ procPointAnalysis procPoints g
dumpWith ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
procPointMap <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g
dumpWith dflags ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- {-# SCC "splitAtProcPoints" #-} run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal platform g
cafEnv <- {-# SCC "cafAnal" #-} run $ cafAnal platform g
let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs
dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs
----------- Control-flow optimisations ---------------
gs <- return $ map cmmCfgOpts gs
mapM_ (dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations") gs
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
gs <- return $ map (bundleCAFs cafEnv) gs
mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
return (localCAFs, gs)
-- gs :: [ (CAFSet, CmmDecl) ]
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
platform = targetPlatform dflags
mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
| otherwise = z
dump = dumpGraph dflags
dumps flag name
= mapM_ (dumpWith dflags (pprPlatform platform) flag name)
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-- Runs an optional transformation/analysis (and should
......@@ -185,20 +188,19 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
runOptimization = runFuelIO (hsc_OptFuel hsc_env)
dumpGraph :: DynFlags -> DynFlag -> CmmGraph -> IO ()
dumpGraph dflags flag g = do
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
cmmLint g
dumpWith (pprPlatform platform)
where
platform = targetPlatform dflags
dumpWith pprFun flag txt g = do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
dumpIfSet_dyn dflags flag txt (pprFun g)
when (not (dopt flag dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g
dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO ()
dumpWith dflags pprFun flag txt g = do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
dumpIfSet_dyn dflags flag txt (pprFun g)
when (not (dopt flag dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
......
......@@ -28,7 +28,7 @@ import Platform
import UniqSet
import UniqSupply
import Compiler.Hoopl
import Hoopl
import qualified Data.Map as Map
......@@ -110,23 +110,23 @@ procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
-- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from
procPointAnalysis procPoints g =
liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
-- pprTrace "procPointAnalysis" (ppr procPoints) $
dataflowAnalFwd g initProcPoints $ analFwd lattice forward
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
-- transfer equations
forward :: FwdTransfer CmmNode Status
forward = mkFTransfer transfer
forward = mkFTransfer3 first middle last
where
transfer :: CmmNode e x -> Status -> Fact x Status
transfer n s
= case shapeX n of
Open -> case n of
CmmEntry id | ProcPoint <- s
-> ReachedBy $ setSingleton id
_ -> s
Closed ->
mkFactBase lattice $ map (\id -> (id, x)) (successors l)
first :: CmmNode C O -> Status -> Status
first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
first _ x = x
middle _ x = x
last :: CmmNode O C -> Status -> FactBase Status
last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
lattice :: DataflowLattice Status
lattice = DataflowLattice "direct proc-point reachability" unreached add_to
......@@ -165,6 +165,7 @@ minimalProcPointSet platform callProcPoints g
extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
extendPPSet platform g blocks procPoints =
do env <- procPointAnalysis procPoints g
-- pprTrace "extensPPSet" (ppr env) $ return ()
let add block pps = let id = entryLabel block
in case mapLookup id env of
Just ProcPoint -> setInsert id pps
......@@ -331,8 +332,9 @@ add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
| not $ setMember bid callPPs
, Just (Protocol c fs _area) <- mapLookup bid protos
= let nodes = copyInSlot c fs
(h, m, l) = blockToNodeList block
in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks
(h, b) = blockSplitHead block
block' = blockJoinHead h (blockFromList nodes `blockAppend` b)
in insertBlock block' blocks
| otherwise = insertBlock block blocks
where bid = entryLabel block
......
......@@ -27,7 +27,7 @@ import UniqFM
import Unique
import BlockId
import Compiler.Hoopl hiding (Unique)
import Hoopl
import Data.Maybe
import Prelude hiding (succ, zip)
......
......@@ -23,7 +23,7 @@ import Outputable hiding (empty)
import qualified Outputable as PP
import UniqSet
import Compiler.Hoopl hiding (Unique)
import Hoopl
import Data.Maybe
import Prelude hiding (succ, zip)
......
......@@ -39,7 +39,7 @@ import OptimizationFuel
import Outputable
import SMRep (ByteOff)
import Compiler.Hoopl
import Hoopl
import Data.Map (Map)
import qualified Data.Map as Map
......@@ -94,7 +94,7 @@ type SlotEnv = BlockEnv SubAreaSet
-- The sub-areas live on entry to the block
liveSlotAnal :: CmmGraph -> FuelUniqSM SlotEnv
liveSlotAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd slotLattice liveSlotTransfers
liveSlotAnal g = dataflowAnalBwd g [] $ analBwd slotLattice liveSlotTransfers
-- Add the subarea s to the subareas in the list-set (possibly coalescing it with
-- adjacent subareas), and also return whether s was a new addition.
......
......@@ -66,7 +66,7 @@ module CmmUtils(
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
analFwd, analBwd, analRewFwd, analRewBwd,
dataflowPassFwd, dataflowPassBwd
dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd
) where
#include "HsVersions.h"
......@@ -88,7 +88,7 @@ import Data.Word
import Data.Maybe
import Data.Bits
import Control.Monad
import Compiler.Hoopl hiding ( Unique )
import Hoopl
---------------------------------------------------
--
......@@ -440,18 +440,6 @@ foldGraphBlocks k z g = mapFold k z $ toBlockMap g
postorderDfs :: CmmGraph -> [CmmBlock]
postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
-------------------------------------------------
-- Manipulating CmmBlocks
lastNode :: CmmBlock -> CmmNode O C
lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
where nothing :: a -> b -> ()
nothing _ _ = ()
replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
where (first, middle, _) = blockToNodeList block
----------------------------------------------------------------------
----- Splicing between blocks
-- Given a middle node, a block, and a successor BlockId,
......@@ -499,26 +487,56 @@ insertBetween b ms succId = insert $ lastNode b
-- Running dataflow analysis and/or rewrites
-- Constructing forward and backward analysis-only pass
analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass FuelUniqSM n f
analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass FuelUniqSM n f
analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
-- Constructing forward and backward analysis + rewrite pass
analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
analRewFwd :: DataflowLattice f -> FwdTransfer n f
-> FwdRewrite FuelUniqSM n f
-> FwdPass FuelUniqSM n f
analRewBwd :: DataflowLattice f
-> BwdTransfer n f
-> BwdRewrite FuelUniqSM n f
-> BwdPass FuelUniqSM 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}
-- Running forward and backward dataflow analysis + optional rewrite
dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass FuelUniqSM n f
-> FuelUniqSM (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)
dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowAnalFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass FuelUniqSM n f
-> FuelUniqSM (BlockEnv f)
dataflowAnalFwd (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
return (analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))
dataflowAnalBwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> BwdPass FuelUniqSM n f
-> FuelUniqSM (BlockEnv f)
dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
-- (graph, facts, NothingO) <- analyzeAndRewriteBwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
-- return facts
return (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)
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)
......@@ -185,7 +185,7 @@ outOfLine ag = withFreshLabel "outOfLine" $ \l ->
do g <- ag
return (case g of
Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $
GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l)
GMany (JustO $ BlockOC BNil (CmmBranch l)) b (JustO $ BlockCO (CmmEntry l) BNil)
_ -> panic "outOfLine"
:: CmmGraphOC)
......
......@@ -488,6 +488,8 @@ Library
Vectorise.Env
Vectorise.Exp
Vectorise
Hoopl.Dataflow
Hoopl