1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2004-2006
5 -- CmmLint: checking the correctness of Cmm statements and expressions
7 -----------------------------------------------------------------------------
13 #include "HsVersions.h"
25 -- -----------------------------------------------------------------------------
26 -- Exported entry points:
28 cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
29 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
31 cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
32 cmmLintTop top = runCmmLint $ lintCmmTop top
34 runCmmLint :: CmmLint a -> Maybe SDoc
37 Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
40 lintCmmTop (CmmProc _ lbl _ blocks)
41 = addLintInfo (text "in proc " <> pprCLabel lbl) $
42 mapM_ lintCmmBlock blocks
46 lintCmmBlock (BasicBlock id stmts)
47 = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
48 mapM_ lintCmmStmt stmts
50 -- -----------------------------------------------------------------------------
53 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
54 -- byte/word mismatches.
56 lintCmmExpr :: CmmExpr -> CmmLint MachRep
57 lintCmmExpr (CmmLoad expr rep) = do
59 when (machRepByteWidth rep >= wORD_SIZE) $
60 cmmCheckWordAddress expr
62 lintCmmExpr expr@(CmmMachOp op args) = do
63 mapM_ lintCmmExpr args
64 if map cmmExprRep args == machOpArgReps op
65 then cmmCheckMachOp op args
66 else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
67 lintCmmExpr (CmmRegOff reg offset)
68 = lintCmmExpr (CmmMachOp (MO_Add rep)
69 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
70 where rep = cmmRegRep reg
71 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
73 = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
75 return (cmmExprRep expr)
77 -- Check for some common byte/word mismatches (eg. Sp + 1)
78 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
79 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
80 = cmmLintDubiousWordOffset (CmmMachOp op args)
81 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
82 = cmmCheckMachOp op [reg, lit]
83 cmmCheckMachOp op@(MO_U_Conv from to) args
84 | isFloatingRep from || isFloatingRep to
85 = cmmLintErr (text "unsigned conversion from/to floating rep: "
86 <> ppr (CmmMachOp op args))
87 cmmCheckMachOp op args
88 = return (resultRepOfMachOp op)
90 isWordOffsetReg (CmmGlobal Sp) = True
91 isWordOffsetReg (CmmGlobal Hp) = True
92 isWordOffsetReg _ = False
94 isOffsetOp (MO_Add _) = True
95 isOffsetOp (MO_Sub _) = True
98 -- This expression should be an address from which a word can be loaded:
99 -- check for funny-looking sub-word offsets.
100 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
101 | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
102 = cmmLintDubiousWordOffset e
103 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
104 | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
105 = cmmLintDubiousWordOffset e
106 cmmCheckWordAddress _
110 lintCmmStmt :: CmmStmt -> CmmLint ()
111 lintCmmStmt stmt@(CmmAssign reg expr) = do
112 erep <- lintCmmExpr expr
113 if (erep == cmmRegRep reg)
115 else cmmLintAssignErr stmt
116 lintCmmStmt (CmmStore l r) = do
120 lintCmmStmt (CmmCall _target _res args _) = mapM_ (lintCmmExpr.fst) args
121 lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
122 lintCmmStmt (CmmSwitch e _branches) = do
123 erep <- lintCmmExpr e
126 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
127 lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
128 lintCmmStmt _other = return ()
130 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
131 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
134 -- -----------------------------------------------------------------------------
137 -- just a basic error monad:
139 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
141 instance Monad CmmLint where
142 CmmLint m >>= k = CmmLint $ case m of
144 Right a -> unCL (k a)
145 return a = CmmLint (Right a)
147 cmmLintErr :: SDoc -> CmmLint a
148 cmmLintErr msg = CmmLint (Left msg)
150 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
151 addLintInfo info thing = CmmLint $
153 Left err -> Left (hang info 2 err)
156 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
157 cmmLintMachOpErr expr argsRep opExpectsRep
158 = cmmLintErr (text "in MachOp application: " $$
159 nest 2 (pprExpr expr) $$
160 (text "op is expecting: " <+> ppr opExpectsRep) $$
161 (text "arguments provide: " <+> ppr argsRep))
163 cmmLintAssignErr :: CmmStmt -> CmmLint a
164 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
165 nest 2 (pprStmt stmt))
167 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
168 cmmLintDubiousWordOffset expr
169 = cmmLintErr (text "offset is not a multiple of words: " $$
170 nest 2 (pprExpr expr))