Commit ab67c2a4 authored by Simon Marlow's avatar Simon Marlow

More codegen refactoring with simonpj

parent b4018aaa
...@@ -28,7 +28,9 @@ import Unique ...@@ -28,7 +28,9 @@ import Unique
my_trace :: String -> SDoc -> a -> a my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ 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, -- 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 -- 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 -- 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 ...@@ -42,59 +44,49 @@ my_trace = if False then pprTrace else \_ _ a -> a
-- TODO: Use optimization fuel -- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g = elimCommonBlocks g = replaceLabels env g
upd_graph g . snd $ iterate common_block reset hashed_blocks where
(emptyUFM, mapEmpty) env = iterate hashed_blocks mapEmpty
where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g)) hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
reset (_, subst) = (emptyUFM, subst)
-- Iterate over the blocks until convergence -- Iterate over the blocks until convergence
iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
iterate upd reset blocks state = iterate blocks subst =
case foldl upd' (False, state) blocks of case foldl common_block (False, emptyUFM, subst) blocks of
(True, state') -> iterate upd reset blocks (reset state') (changed, _, subst)
(False, state') -> state' | changed -> iterate blocks subst
where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes | 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. -- Try to find a block that is equal (or ``common'') to b.
type BidMap = BlockEnv BlockId common_block :: State -> (HashCode, CmmBlock) -> State
type State = (UniqFM [CmmBlock], BidMap) common_block (old_change, bmap, subst) (hash, b) =
common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State)
common_block (bmap, subst) (hash, b) =
case lookupUFM bmap hash of case lookupUFM bmap hash of
Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs, Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
mapLookup bid subst) of mapLookup bid subst) of
(Just b', Nothing) -> addSubst b' (Just b', Nothing) -> addSubst b'
(Just b', Just b'') | entryLabel b' /= b'' -> addSubst b' (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
_ -> (False, (addToUFM bmap hash (b : bs), subst)) _ -> (old_change, addToUFM bmap hash (b : bs), subst)
Nothing -> (False, (addToUFM bmap hash [b], subst)) Nothing -> (old_change, (addToUFM bmap hash [b], subst))
where bid = entryLabel b where bid = entryLabel b
addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $ addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
(True, (bmap, mapInsert bid (entryLabel b') subst)) (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 -- Hashing and equality on blocks
where middle = mapExpDeep exp
last l = last' (mapExpDeep exp l) -- Below here is mostly boilerplate: hashing blocks ignoring labels,
last' :: CmmNode O C -> CmmNode O C -- and comparing blocks modulo a label mapping.
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
-- To speed up comparisons, we hash each basic block modulo labels. -- To speed up comparisons, we hash each basic block modulo labels.
-- The hashing is a bit arbitrary (the numbers are completely arbitrary), -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough. -- but it should be fast and good enough.
hash_block :: CmmBlock -> Int hash_block :: CmmBlock -> HashCode
hash_block block = hash_block block =
fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
-- UniqFM doesn't like negative Ints -- UniqFM doesn't like negative Ints
...@@ -107,7 +99,7 @@ hash_block block = ...@@ -107,7 +99,7 @@ hash_block block =
hash_node (CmmAssign r e) = hash_reg r + hash_e e hash_node (CmmAssign r e) = hash_reg r + hash_e e
hash_node (CmmStore e e') = hash_e e + 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 (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 (CmmCondBranch p _ _) = hash_e p
hash_node (CmmCall e _ _ _ _) = hash_e e hash_node (CmmCall e _ _ _ _) = hash_e e
hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
...@@ -143,9 +135,9 @@ hash_block block = ...@@ -143,9 +135,9 @@ hash_block block =
-- Utilities: equality and substitution on the graph. -- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality. -- 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' 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 lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid Just bid -> lookupBid subst bid
Nothing -> bid Nothing -> bid
......
...@@ -2,8 +2,10 @@ ...@@ -2,8 +2,10 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
module CmmContFlowOpt module CmmContFlowOpt
( runCmmContFlowOpts ( cmmCfgOpts
, removeUnreachableBlocks, replaceBranches , runCmmContFlowOpts
, removeUnreachableBlocks
, replaceLabels
) )
where where
...@@ -28,100 +30,140 @@ runCmmContFlowOpts :: CmmGroup -> CmmGroup ...@@ -28,100 +30,140 @@ runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts = map (optProc cmmCfgOpts) runCmmContFlowOpts = map (optProc cmmCfgOpts)
cmmCfgOpts :: CmmGraph -> CmmGraph cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat . branchChainElim cmmCfgOpts = removeUnreachableBlocks . blockConcat
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g) optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
optProc _ top = top optProc _ top = top
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
-- Branch Chain Elimination -- Block concatenation
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | Remove any basic block of the form L: goto L', and replace L with -- This optimisation does two things:
-- L' everywhere else, unless L is the successor of a call instruction -- - If a block finishes with an unconditional branch, then we may
-- and L' is the entry block. You don't want to set the successor of a -- be able to concatenate the block it points to and remove the
-- function call to the entry block because there is no good way to -- branch. We do this either if the destination block is small
-- store both the infotables for the call and from the callee, while -- (e.g. just another branch), or if this is the only jump to
-- putting the stack pointer in a consistent place. -- this particular destination block.
--
-- - If a block finishes in a call whose continuation block is a
-- goto, then we can shortcut the destination, making the
-- continuation block the destination of the goto.
--
-- Both transformations are improved by working from the end of the
-- graph towards the beginning, because we may be able to perform many
-- shortcuts in one go.
-- We need to walk over the blocks from the end back to the
-- beginning. We are going to maintain the "current" graph
-- (BlockEnv CmmBlock) as we go, and also a mapping from BlockId
-- to BlockId, representing continuation labels that we have
-- renamed. This latter mapping is important because we might
-- shortcut a CmmCall continuation. For example:
--
-- Sp[0] = L
-- call g returns to L
--
-- L: goto M
-- --
-- JD isn't quite sure when it's safe to share continuations for different -- M: ...
-- function calls -- have to think about where the SP will be, --
-- so we'll table that problem for now by leaving all call successors alone. -- So when we shortcut the L block, we need to replace not only
-- the continuation of the call, but also references to L in the
branchChainElim :: CmmGraph -> CmmGraph -- code (e.g. the assignment Sp[0] = L). So we keep track of
branchChainElim g -- which labels we have renamed and apply the mapping at the end
| null lone_branch_blocks = g -- No blocks to remove -- with replaceLabels.
| otherwise = {- pprTrace "branchChainElim" (ppr forest) $ -}
replaceLabels (mapFromList edges) g blockConcat :: CmmGraph -> CmmGraph
blockConcat g@CmmGraph { g_entry = entry_id }
= replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
where where
blocks = toBlockList g -- we might be able to shortcut the entry BlockId itself
new_entry
lone_branch_blocks :: [(BlockId, BlockId)] | Just entry_blk <- mapLookup entry_id new_blocks
-- each (L,K) is a block of the form , Just dest <- canShortcut entry_blk
-- L : goto K = dest
lone_branch_blocks = mapCatMaybes isLoneBranch blocks | otherwise
= entry_id
call_succs = foldl add emptyBlockSet blocks
where add :: BlockSet -> CmmBlock -> BlockSet
add succs b =
case lastNode b of
(CmmCall _ (Just k) _ _ _) -> setInsert k succs
(CmmForeignCall {succ=k}) -> setInsert k succs
_ -> succs
isLoneBranch :: CmmBlock -> Maybe (BlockId, BlockId)
isLoneBranch block
| (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block
, not (setMember id call_succs)
= Just (id,target)
| otherwise
= Nothing
-- We build a graph from lone_branch_blocks (every node has only
-- one out edge). Then we
-- - topologically sort the graph: if from A we can reach B,
-- then A occurs before B in the result list.
-- - depth-first search starting from the nodes in this list.
-- This gives us a [[node]], in which each list is a dependency
-- chain.
-- - for each list [a1,a2,...an] replace branches to ai with an.
--
-- This approach nicely deals with cycles by ignoring them.
-- Branches in a cycle will be redirected to somewhere in the
-- cycle, but we don't really care where. A cycle should be dead code,
-- and so will be eliminated by removeUnreachableBlocks.
--
fromNode (b,_) = b
toNode a = (a,a)
all_block_ids :: LabelSet
all_block_ids = setFromList (map fst lone_branch_blocks)
`setUnion`
setFromList (map snd lone_branch_blocks)
forest = dfsTopSortG $ graphFromVerticesAndAdjacency nodes lone_branch_blocks
where nodes = map toNode $ setElems $ all_block_ids
edges = [ (fromNode y, fromNode x)
| (x:xs) <- map reverse forest, y <- xs ]
---------------------------------------------------------------- blocks = postorderDfs g
(new_blocks, shortcut_map) =
foldr maybe_concat (toBlockMap g, mapEmpty) blocks
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId)
-> (BlockEnv CmmBlock, BlockEnv BlockId)
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)
| Just b' <- callContinuation_maybe last
, Just blk' <- mapLookup b' blocks
, Just dest <- canShortcut b' 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
shouldConcatWith b block
| num_preds b == 1 = True -- only one predecessor: go for it
| okToDuplicate block = True -- short enough to duplicate
| otherwise = False
where num_preds bid = mapLookup bid backEdges `orElse` 0
canShortcut :: Block C C -> Maybe BlockId
canShortcut block
| (_, middle, CmmBranch dest) <- blockHeadTail 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
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice head rest = head `cat` snd (blockHead rest)
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
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 block
= case blockToNodeList block of (_, m, _) -> null m
-- cheap and cheerful; we might expand this in the future to
-- e.g. spot blocks that represent a single instruction or two
------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabels env = replaceLabels env g
replace_eid . mapGraphNodes1 txnode | isEmptyMap env = g
| otherwise = replace_eid . mapGraphNodes1 txnode
where where
replace_eid g = g {g_entry = lookup (g_entry g)} replace_eid g = g {g_entry = lookup (g_entry g)}
lookup id = mapLookup id env `orElse` id lookup id = mapLookup id env `orElse` id
txnode :: CmmNode e x -> CmmNode e x txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch bid) = CmmBranch (lookup bid) txnode (CmmBranch bid) = CmmBranch (lookup bid)
txnode (CmmCondBranch p t f) = CmmCondBranch (exp p) (lookup t) (lookup f) txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms) txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
txnode (CmmCall t k a res r) = CmmCall (exp t) (liftM lookup k) a res r txnode (CmmCall t k a res r) = CmmCall (exp t) (liftM lookup k) a res r
txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc) txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
...@@ -133,81 +175,18 @@ replaceLabels env = ...@@ -133,81 +175,18 @@ replaceLabels env =
exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
exp e = e exp e = e
mkCmmCondBranch :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
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
---------------------------------------------------------------- ----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful. -- Build a map from a block to its set of predecessors. Very useful.
predMap :: [CmmBlock] -> BlockEnv BlockSet predMap :: [CmmBlock] -> BlockEnv BlockSet
predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
where add_preds block env = foldl (add (entryLabel block)) env (successors block) where add_preds block env = foldl (add (entryLabel block)) env (successors block)
add bid env b' = add bid env b' =
mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
-----------------------------------------------------------------------------
--
-- Block concatenation
--
-----------------------------------------------------------------------------
-- If a block B branches to a label L, L is not the entry block,
-- and L has no other predecessors,
-- then we can splice the block starting with L onto the end of B.
-- Order matters, so we work bottom up (reverse postorder DFS).
-- This optimization can be inhibited by unreachable blocks, but
-- the reverse postorder DFS returns only reachable blocks.
--
-- To ensure correctness, we have to make sure that the BlockId of the block
-- we are about to eliminate is not named in another instruction.
--
-- Note: This optimization does _not_ subsume branch chain elimination.
blockConcat :: CmmGraph -> CmmGraph
blockConcat g@(CmmGraph {g_entry=eid}) =
replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
where
blocks = postorderDfs g
(blocks', concatMap) =
foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
maybe_concat b unchanged@(blocks', concatMap) =
let bid = entryLabel b
in case blockToNodeList b of
(JustC h, m, JustC (CmmBranch b')) ->
if canConcatWith b' then
(mapInsert bid (splice blocks' h m b') blocks',
mapInsert b' bid concatMap)
else unchanged
_ -> unchanged
num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
canConcatWith b' = b' /= eid && num_preds b' == 1
backEdges = predMap blocks
splice :: forall map n e x.
IsMap map =>
map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
splice blocks' h m bid' =
case mapLookup bid' blocks' of
Nothing -> panic "unknown successor block"
Just block | (_, m', l') <- blockToNodeList block
-> blockOfNodeList (JustC h, (m ++ m'), l')
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
......
...@@ -75,7 +75,8 @@ data Area ...@@ -75,7 +75,8 @@ data Area
data AreaId data AreaId
= Old -- See Note [Old Area] = Old -- See Note [Old Area]
| Young BlockId | Young BlockId -- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode.
deriving (Eq, Ord) deriving (Eq, Ord)
{- Note [Old Area] {- Note [Old Area]
...@@ -120,7 +121,11 @@ data CmmLit ...@@ -120,7 +121,11 @@ data CmmLit
-- It is also used inside the NCG during when generating -- It is also used inside the NCG during when generating
-- position-independent code. -- position-independent code.
| CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset | 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 | CmmHighStackMark -- stands for the max stack space used during a procedure
deriving Eq deriving Eq
......
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
-- (c) The University of Glasgow 2004-2006 -- (c) The University of Glasgow 2011
-- --
-- CmmLint: checking the correctness of Cmm statements and expressions -- 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 ( module CmmLint (
cmmLint, cmmLintTop cmmLint
) where ) where
import BlockId import Cmm
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)