Commit ab67c2a4 authored by Simon Marlow's avatar Simon Marlow

More codegen refactoring with simonpj

parent b4018aaa
......@@ -28,7 +28,9 @@ import Unique
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
-- Eliminate common blocks:
-- -----------------------------------------------------------------------------
-- Eliminate common blocks
-- If two blocks are identical except for the label on the first node,
-- then we can eliminate one of the blocks. To ensure that the semantics
-- of the program are preserved, we have to rewrite each predecessor of the
......@@ -42,59 +44,49 @@ my_trace = if False then pprTrace else \_ _ a -> a
-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g =
upd_graph g . snd $ iterate common_block reset hashed_blocks
(emptyUFM, mapEmpty)
where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
reset (_, subst) = (emptyUFM, subst)
elimCommonBlocks g = replaceLabels env g
where
env = iterate hashed_blocks mapEmpty
hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
-- Iterate over the blocks until convergence
iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
iterate upd reset blocks state =
case foldl upd' (False, state) blocks of
(True, state') -> iterate upd reset blocks (reset state')
(False, state') -> state'
where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
iterate blocks subst =
case foldl common_block (False, emptyUFM, subst) blocks of
(changed, _, subst)
| changed -> iterate blocks subst
| otherwise -> subst
type State = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
type ChangeFlag = Bool
type HashCode = Int
-- Try to find a block that is equal (or ``common'') to b.
type BidMap = BlockEnv BlockId
type State = (UniqFM [CmmBlock], BidMap)
common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State)
common_block (bmap, subst) (hash, b) =
common_block :: State -> (HashCode, CmmBlock) -> State
common_block (old_change, bmap, subst) (hash, b) =
case lookupUFM bmap hash of
Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
mapLookup bid subst) of
(Just b', Nothing) -> addSubst b'
(Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
_ -> (False, (addToUFM bmap hash (b : bs), subst))
Nothing -> (False, (addToUFM bmap hash [b], subst))
_ -> (old_change, addToUFM bmap hash (b : bs), 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))
-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
upd_graph :: CmmGraph -> BidMap -> CmmGraph
upd_graph g subst = mapGraphNodes (id, middle, last) g
where middle = mapExpDeep exp
last l = last' (mapExpDeep exp l)
last' :: CmmNode O C -> CmmNode O C
last' (CmmBranch bid) = CmmBranch $ sub bid
last' (CmmCondBranch p t f) = cond p (sub t) (sub f)
last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
last' l@(CmmCall _ Nothing _ _ _) = l
last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
last' (CmmSwitch e bs) = CmmSwitch e $ map (liftM sub) bs
cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
exp (CmmStackSlot (CallArea (Young id)) off) =
CmmStackSlot (CallArea (Young (sub id))) off
exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
exp e = e
sub = lookupBid subst
(True, bmap, mapInsert bid (entryLabel b') subst)
-- -----------------------------------------------------------------------------
-- Hashing and equality on blocks
-- Below here is mostly boilerplate: hashing blocks ignoring labels,
-- and comparing blocks modulo a label mapping.
-- To speed up comparisons, we hash each basic block modulo labels.
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.
hash_block :: CmmBlock -> Int
hash_block :: CmmBlock -> HashCode
hash_block block =
fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
-- UniqFM doesn't like negative Ints
......@@ -107,7 +99,7 @@ hash_block block =
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
hash_node (CmmBranch _) = 23 -- would be great to hash these properly
hash_node (CmmBranch _) = 23 -- NB. ignore the label
hash_node (CmmCondBranch p _ _) = hash_e p
hash_node (CmmCall e _ _ _ _) = hash_e e
hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
......@@ -143,9 +135,9 @@ hash_block block =
-- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
eqBid :: BidMap -> BlockId -> BlockId -> Bool
eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
lookupBid :: BidMap -> BlockId -> BlockId
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid
Nothing -> bid
......
This diff is collapsed.
......@@ -75,7 +75,8 @@ data Area
data AreaId
= Old -- See Note [Old Area]
| Young BlockId
| Young BlockId -- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode.
deriving (Eq, Ord)
{- Note [Old Area]
......@@ -120,7 +121,11 @@ data CmmLit
-- It is also used inside the NCG during when generating
-- position-independent code.
| CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
| CmmBlock BlockId -- Code label
| CmmBlock BlockId -- Code label
-- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode.
| CmmHighStackMark -- stands for the max stack space used during a procedure
deriving Eq
......
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2006
-- (c) The University of Glasgow 2011
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module CmmLint (
cmmLint, cmmLintTop
cmmLint
) where
import BlockId
import OldCmm
import CLabel
import Outputable
import OldPprCmm()
import Constants
import FastString
import Platform
import Data.Maybe
-- -----------------------------------------------------------------------------
-- Exported entry points:
cmmLint :: (PlatformOutputable d, PlatformOutputable h)
=> Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
cmmLintTop :: (PlatformOutputable d, PlatformOutputable h)
=> Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
runCmmLint :: PlatformOutputable a
=> Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint platform l p =
case unCL (l p) of
Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
nest 2 err,
ptext $ sLit ("Program was:"),
nest 2 (pprPlatform platform p)])
Right _ -> Nothing
lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel platform lbl) $
let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
in mapM_ (lintCmmBlock platform labels) blocks
lintCmmDecl _ (CmmData {})
= return ()
lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock platform labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr id) $
mapM_ (lintCmmStmt platform labels) stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
lintCmmExpr platform (CmmLoad expr rep) = do
_ <- lintCmmExpr platform expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- cmmCheckWordAddress expr
return rep
lintCmmExpr platform expr@(CmmMachOp op args) = do
tys <- mapM (lintCmmExpr platform) args
if map (typeWidth . cmmExprType) args == machOpArgReps op
then cmmCheckMachOp op args tys
else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op)
lintCmmExpr platform (CmmRegOff reg offset)
= lintCmmExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
where rep = typeWidth (cmmRegType reg)
lintCmmExpr _ expr =
return (cmmExprType expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
= return (machOpResultType op tys)
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint ()
_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset platform e
_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset platform e
_cmmCheckWordAddress _ _
= return ()
-- No warnings for unaligned arithmetic with the node register,
-- which is used to extract fields from tagged constructor closures.
notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
lintCmmStmt platform labels = lint
where lint (CmmNop) = return ()
lint (CmmComment {}) = return ()
lint stmt@(CmmAssign reg expr) = do
erep <- lintCmmExpr platform expr
let reg_ty = cmmRegType reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr platform stmt erep reg_ty
lint (CmmStore l r) = do
_ <- lintCmmExpr platform l
_ <- lintCmmExpr platform r
return ()
lint (CmmCall target _res args _) =
lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
erep <- lintCmmExpr platform e
if (erep `cmmEqType_ignoring_ptrhood` bWord)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
text " :: " <> ppr erep)
lint (CmmJump e args) = lintCmmExpr platform e >> mapM_ (lintCmmExpr platform . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr platform . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
lintTarget _ (CmmPrim {}) = return ()
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond platform expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
(pprPlatform platform expr))
-- -----------------------------------------------------------------------------
-- CmmLint monad
-- just a basic error monad:
newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
instance Monad CmmLint where
CmmLint m >>= k = CmmLint $ case m of
Left e -> Left e
Right a -> unCL (k a)
return a = CmmLint (Right a)
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (Left msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo info thing = CmmLint $
case unCL thing of
Left err -> Left (hang info 2 err)
Right a -> Right a
cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr platform expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
nest 2 (pprPlatform platform expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
import Cmm
cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr platform stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$
nest 2 (vcat [pprPlatform platform stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
cmmLint :: CmmGraph -> IO ()
cmmLint g = pprTrace "ToDo! CmmLint" return ()
cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a
cmmLintDubiousWordOffset platform expr
= cmmLintErr (text "offset is not a multiple of words: " $$
nest 2 (pprPlatform platform expr))
-- Things to check:
-- - invariant on CmmBlock in CmmExpr (see comment there)
-- - check for branches to blocks that don't exist
-- - check types
......@@ -78,6 +78,11 @@ data CmmNode e x where
cml_cont :: Maybe Label,
-- Label of continuation (Nothing for return or tail call)
--
-- Note [Continuation BlockId]: these BlockIds are called
-- Continuation BlockIds, and are the only BlockIds that can
-- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
-- (CmmStackSlot (Young b) _).
-- ToDO: add this:
-- cml_args_regs :: [GlobalReg],
......
......@@ -61,8 +61,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
--
showPass dflags "CPSZ"
let tops = runCmmContFlowOpts prog
(cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
(cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) prog
-- tops :: [[(CmmDecl,CAFSet]] (one list per group)
let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
......@@ -98,35 +97,40 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- Why bother doing these early: dualLivenessWithInsertion,
-- insertLateReloads, rewriteAssignments?
----------- Control-flow optimisations ---------------
g <- return $ cmmCfgOpts g
dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
----------- Eliminate common blocks -------------------
g <- return $ elimCommonBlocks g
dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_ elimCommonBlocks
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
dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g
dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
g <- run $ dualLivenessWithInsertion procPoints g
dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g
dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
----------- Sink and inline assignments -------------------
g <- runOptimization $ rewriteAssignments platform g
dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
----------- Eliminate dead assignments -------------------
g <- runOptimization $ removeDeadAssignments g
dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" 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
else return g
dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
......@@ -137,16 +141,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------ Manifest the stack pointer --------
g <- run $ manifestSP spEntryMap areaMap entry_off g
dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" 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
dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
dumpWith ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs
mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal platform g
......@@ -154,36 +158,48 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
mapM_ (dump 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
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
gs <- return $ map (bundleCAFs cafEnv) gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
mapM_ (dump 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
platform = targetPlatform dflags
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f = dumpWith ppr f
dumpPlatform platform = dumpWith (pprPlatform platform)
dumpWith pprFun f 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 f txt (pprFun g)
when (not (dopt f dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
dump = dumpGraph dflags
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-- Runs an optional transformation/analysis (and should
-- thus be subject to optimization fuel)
runOptimization = runFuelIO (hsc_OptFuel hsc_env)
dumpGraph :: DynFlags -> DynFlag -> CmmGraph -> IO ()
dumpGraph dflags flag 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)
-- 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.
......
......@@ -103,34 +103,50 @@ instance Outputable Status where
(hsep $ punctuate comma $ map ppr $ setElems ps)
ppr ProcPoint = text "<procpt>"
lattice :: DataflowLattice Status
lattice = DataflowLattice "direct proc-point reachability" unreached add_to
where unreached = ReachedBy setEmpty
add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) -- because of previous case
add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) =
let union = setUnion p' p
in if setSize union > setSize p then (SomeChange, ReachedBy union)
else (NoChange, ReachedBy p)
--------------------------------------------------
-- transfer equations
-- Proc point analysis
forward :: FwdTransfer CmmNode Status
forward = mkFTransfer3 first middle ((mkFactBase lattice . ) . last)
where first :: CmmNode C O -> Status -> Status
first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
first _ x = x
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
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
middle _ x = x
-- transfer equations
last :: CmmNode O C -> Status -> [(Label, Status)]
last (CmmCall {cml_cont = Just k}) _ = [(k, ProcPoint)]
last (CmmForeignCall {succ = k}) _ = [(k, ProcPoint)]
last l x = map (\id -> (id, x)) (successors l)
forward :: FwdTransfer CmmNode Status
forward = mkFTransfer transfer
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)
-- It is worth distinguishing two sets of proc points:
-- those that are induced by calls in the original graph
-- and those that are introduced because they're reachable from multiple proc points.
lattice :: DataflowLattice Status
lattice = DataflowLattice "direct proc-point reachability" unreached add_to
where unreached = ReachedBy setEmpty
add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint)
-- because of previous case
add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
| setSize union > setSize p = (SomeChange, ReachedBy union)
| otherwise = (NoChange, ReachedBy p)
where
union = setUnion p' p
----------------------------------------------------------------------
-- It is worth distinguishing two sets of proc points: those that are
-- induced by calls in the original graph and those that are
-- introduced because they're reachable from multiple proc points.
--
-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
where add :: CmmBlock -> BlockSet -> BlockSet
......@@ -139,17 +155,12 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
CmmForeignCall {succ=k} -> setInsert k set
_ -> set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-> FuelUniqSM 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
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
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
minimalProcPointSet platform callProcPoints g
= extendPPSet platform g (postorderDfs g) callProcPoints
extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
extendPPSet platform g blocks procPoints =
......@@ -179,10 +190,12 @@ extendPPSet platform g blocks procPoints =
pps -> extendPPSet g blocks
(foldl extendBlockSet procPoints' pps)
-}
case newPoint of Just id ->
if setMember id procPoints' then panic "added old proc pt"
else extendPPSet platform g blocks (setInsert id procPoints')
Nothing -> return procPoints'
case newPoint of
Just id ->
if setMember id procPoints'
then panic "added old proc pt"
else extendPPSet platform g blocks (setInsert id procPoints')
Nothing -> return procPoints'
------------------------------------------------------------------------
......@@ -482,6 +495,23 @@ splitAtProcPoints entry_label callPPs procPoints procMap
procs
splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceBranches env g = mapGraphNodes (id, id, last) g
where
last :: CmmNode O C -> CmmNode O C
last (CmmBranch id) = CmmBranch (lookup id)
last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
last l@(CmmCall {}) = l
last l@(CmmForeignCall {}) = l
lookup id = fmap lookup (mapLookup id env) `orElse` id
-- XXX: this is a recursive lookup, it follows chains
-- until the lookup returns Nothing, at which point we
-- return the last BlockId
----------------------------------------------------------------
{-
......
......@@ -401,13 +401,13 @@ mkLiveness (reg:regs)
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
insertBlock block map =
ASSERT (isNothing $ mapLookup id map)
mapInsert id block map
......
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2006
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module OldCmmLint (
cmmLint, cmmLintTop
) where
import BlockId
import OldCmm
import CLabel
import Outputable
import OldPprCmm()
import Constants
import FastString
import Platform