module CmmLint (
cmmLint, cmmLintTop
) where
import BlockId
import Cmm
import CLabel
import Outputable
import PprCmm
import Constants
import FastString
import Control.Monad
import Data.Maybe
cmmLint :: (Outputable d, Outputable h)
=> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
cmmLintTop :: (Outputable d, Outputable h)
=> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop top = runCmmLint lintCmmTop top
runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint 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 (ppr p)])
Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel lbl) $
let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
in mapM_ (lintCmmBlock labels) blocks
lintCmmTop (CmmData {})
= return ()
lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr id) $
mapM_ (lintCmmStmt labels) stmts
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad expr rep) = do
_ <- lintCmmExpr expr
when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
tys <- mapM lintCmmExpr args
if map (typeWidth . cmmExprType) args == machOpArgReps op
then cmmCheckMachOp op args tys
else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
lintCmmExpr (CmmRegOff reg offset)
= lintCmmExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
where rep = typeWidth (cmmRegType reg)
lintCmmExpr expr =
return (cmmExprType expr)
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
cmmCheckWordAddress :: CmmExpr -> CmmLint ()
cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress _
= return ()
notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
lintCmmStmt labels = lint
where lint (CmmNop) = return ()
lint (CmmComment {}) = return ()
lint stmt@(CmmAssign reg expr) = do
erep <- lintCmmExpr expr
let reg_ty = cmmRegType reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do
_ <- lintCmmExpr l
_ <- lintCmmExpr r
return ()
lint (CmmCall target _res args _ _) =
lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
erep <- lintCmmExpr e
if (erep `cmmEqType_ignoring_ptrhood` bWord)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
text " :: " <> ppr erep)
lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
checkTarget id = if elemBlockSet id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: CmmCallTarget -> CmmLint ()
lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
lintTarget (CmmPrim {}) = return ()
checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
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 :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
nest 2 (pprExpr expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$
nest 2 (vcat [pprStmt stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
nest 2 (pprExpr expr))