Skip to content

GitLab

GHC
GHC
Commit ab67c2a4 authored by Simon Marlow's avatar Simon Marlow
Browse files
Options

More codegen refactoring with simonpj

parent b4018aaa
Hide whitespace changes
Inline Side-by-side
Showing with 492 additions and 443 deletions
compiler/cmm/CmmCommonBlockElim.hs
View file @ ab67c2a4
......@@ -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
......
compiler/cmm/CmmContFlowOpt.hs
View file @ ab67c2a4
......@@ -2,8 +2,10 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
module CmmContFlowOpt
( runCmmContFlowOpts
, removeUnreachableBlocks, replaceBranches
( cmmCfgOpts
, runCmmContFlowOpts
, removeUnreachableBlocks
, replaceLabels
)
where
......@@ -28,100 +30,140 @@ runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts = map (optProc cmmCfgOpts)
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat . branchChainElim
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
cmmCfgOpts = removeUnreachableBlocks . blockConcat
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
-----------------------------------------------------------------------------
--
-- Branch Chain Elimination
-- Block concatenation
--
-----------------------------------------------------------------------------
-- | Remove any basic block of the form L: goto L', and replace L with
-- L' everywhere else, unless L is the successor of a call instruction
-- and L' is the entry block. You don't want to set the successor of a
-- function call to the entry block because there is no good way to
-- store both the infotables for the call and from the callee, while
-- putting the stack pointer in a consistent place.
-- This optimisation does two things:
-- - If a block finishes with an unconditional branch, then we may
-- be able to concatenate the block it points to and remove the
-- branch. We do this either if the destination block is small
-- (e.g. just another branch), or if this is the only jump to
-- 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
-- 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.
branchChainElim :: CmmGraph -> CmmGraph
branchChainElim g
| null lone_branch_blocks = g -- No blocks to remove
| otherwise = {- pprTrace "branchChainElim" (ppr forest) $ -}
replaceLabels (mapFromList edges) g
-- M: ...
--
-- 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
-- code (e.g. the assignment Sp[0] = L). So we keep track of
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.
blockConcat :: CmmGraph -> CmmGraph
blockConcat g@CmmGraph { g_entry = entry_id }
= replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
where
blocks = toBlockList g
lone_branch_blocks :: [(BlockId, BlockId)]
-- each (L,K) is a block of the form
-- L : goto K
lone_branch_blocks = mapCatMaybes isLoneBranch blocks
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 ]
-- we might be able to shortcut the entry BlockId itself
new_entry
| Just entry_blk <- mapLookup entry_id new_blocks
, Just dest <- canShortcut entry_blk
= dest
| otherwise
= entry_id
----------------------------------------------------------------
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 env =
replace_eid . mapGraphNodes1 txnode
replaceLabels env g
| isEmptyMap env = g
| otherwise = replace_eid . mapGraphNodes1 txnode
where
replace_eid g = g {g_entry = lookup (g_entry g)}
lookup id = mapLookup id env `orElse` id
txnode :: CmmNode e x -> CmmNode e x
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 (CmmCall t k a res r) = CmmCall (exp t) (liftM lookup k) a res r
txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
......@@ -133,81 +175,18 @@ replaceLabels env =
exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
exp e = e
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
mkCmmCondBranch :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
predMap :: [CmmBlock] -> BlockEnv BlockSet
predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
where add_preds block env = foldl (add (entryLabel block)) env (successors block)
add bid env b' =
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')
-----------------------------------------------------------------------------
--
......
compiler/cmm/CmmExpr.hs
View file @ ab67c2a4
......@@ -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
......
compiler/cmm/CmmLint.hs
View file @ ab67c2a4
-----------------------------------------------------------------------------
--
-- (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: