1 -- The above warning supression flag is a temporary kludge.
2 -- While working on this module you are encouraged to remove it and fix
3 -- any warnings in the module. See
4 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
7 -----------------------------------------------------------------------------
9 -- (c) The University of Glasgow 2004-2006
11 -- CmmLint: checking the correctness of Cmm statements and expressions
13 -----------------------------------------------------------------------------
32 -- -----------------------------------------------------------------------------
33 -- Exported entry points:
35 cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
36 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
38 cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
39 cmmLintTop top = runCmmLint $ lintCmmTop top
41 runCmmLint :: CmmLint a -> Maybe SDoc
44 Left err -> Just (ptext (sLit "Cmm lint error:") $$ nest 2 err)
47 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
48 lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
49 = addLintInfo (text "in proc " <> pprCLabel lbl) $
50 let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
51 in mapM_ (lintCmmBlock labels) blocks
53 lintCmmTop (CmmData {})
56 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
57 lintCmmBlock labels (BasicBlock id stmts)
58 = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
59 mapM_ (lintCmmStmt labels) stmts
61 -- -----------------------------------------------------------------------------
64 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
65 -- byte/word mismatches.
67 lintCmmExpr :: CmmExpr -> CmmLint MachRep
68 lintCmmExpr (CmmLoad expr rep) = do
70 when (machRepByteWidth rep >= wORD_SIZE) $
71 cmmCheckWordAddress expr
73 lintCmmExpr expr@(CmmMachOp op args) = do
74 mapM_ lintCmmExpr args
75 if map cmmExprRep args == machOpArgReps op
76 then cmmCheckMachOp op args
77 else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
78 lintCmmExpr (CmmRegOff reg offset)
79 = lintCmmExpr (CmmMachOp (MO_Add rep)
80 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
81 where rep = cmmRegRep reg
82 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
84 = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
86 return (cmmExprRep expr)
88 -- Check for some common byte/word mismatches (eg. Sp + 1)
89 cmmCheckMachOp :: MachOp -> [CmmExpr] -> CmmLint MachRep
90 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
91 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
92 = cmmLintDubiousWordOffset (CmmMachOp op args)
93 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)]
94 = cmmCheckMachOp op [reg, lit]
95 cmmCheckMachOp op@(MO_U_Conv from to) args
96 | isFloatingRep from || isFloatingRep to
97 = cmmLintErr (text "unsigned conversion from/to floating rep: "
98 <> ppr (CmmMachOp op args))
99 cmmCheckMachOp op _args
100 = return (resultRepOfMachOp op)
102 isWordOffsetReg :: CmmReg -> Bool
103 isWordOffsetReg (CmmGlobal Sp) = True
104 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
105 --isWordOffsetReg (CmmGlobal Hp) = True
106 isWordOffsetReg _ = False
108 isOffsetOp :: MachOp -> Bool
109 isOffsetOp (MO_Add _) = True
110 isOffsetOp (MO_Sub _) = True
113 -- This expression should be an address from which a word can be loaded:
114 -- check for funny-looking sub-word offsets.
115 cmmCheckWordAddress :: CmmExpr -> CmmLint ()
116 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
117 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
118 = cmmLintDubiousWordOffset e
119 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
120 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
121 = cmmLintDubiousWordOffset e
122 cmmCheckWordAddress _
125 -- No warnings for unaligned arithmetic with the node register,
126 -- which is used to extract fields from tagged constructor closures.
127 notNodeReg :: CmmExpr -> Bool
128 notNodeReg (CmmReg reg) | reg == nodeReg = False
131 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
132 lintCmmStmt labels = lint
133 where lint (CmmNop) = return ()
134 lint (CmmComment {}) = return ()
135 lint stmt@(CmmAssign reg expr) = do
136 erep <- lintCmmExpr expr
137 if (erep == cmmRegRep reg)
139 else cmmLintAssignErr stmt
140 lint (CmmStore l r) = do
144 lint (CmmCall target _res args _ _) =
145 lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
146 lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
147 lint (CmmSwitch e branches) = do
148 mapM_ checkTarget $ catMaybes branches
149 erep <- lintCmmExpr e
152 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
153 lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
154 lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) ress
155 lint (CmmBranch id) = checkTarget id
156 checkTarget id = if elemBlockSet id labels then return ()
157 else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
159 lintTarget :: CmmCallTarget -> CmmLint ()
160 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
161 lintTarget (CmmPrim {}) = return ()
164 checkCond :: CmmExpr -> CmmLint ()
165 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
166 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
169 -- -----------------------------------------------------------------------------
172 -- just a basic error monad:
174 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
176 instance Monad CmmLint where
177 CmmLint m >>= k = CmmLint $ case m of
179 Right a -> unCL (k a)
180 return a = CmmLint (Right a)
182 cmmLintErr :: SDoc -> CmmLint a
183 cmmLintErr msg = CmmLint (Left msg)
185 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
186 addLintInfo info thing = CmmLint $
188 Left err -> Left (hang info 2 err)
191 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
192 cmmLintMachOpErr expr argsRep opExpectsRep
193 = cmmLintErr (text "in MachOp application: " $$
194 nest 2 (pprExpr expr) $$
195 (text "op is expecting: " <+> ppr opExpectsRep) $$
196 (text "arguments provide: " <+> ppr argsRep))
198 cmmLintAssignErr :: CmmStmt -> CmmLint a
199 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
200 nest 2 (pprStmt stmt))
202 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
203 cmmLintDubiousWordOffset expr
204 = cmmLintErr (text "offset is not a multiple of words: " $$
205 nest 2 (pprExpr expr))