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 -----------------------------------------------------------------------------
31 -- -----------------------------------------------------------------------------
32 -- Exported entry points:
34 cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
35 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
37 cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
38 cmmLintTop top = runCmmLint $ lintCmmTop top
40 runCmmLint :: CmmLint a -> Maybe SDoc
43 Left err -> Just (ptext (sLit "Cmm lint error:") $$ nest 2 err)
46 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
47 lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
48 = addLintInfo (text "in proc " <> pprCLabel lbl) $
49 let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
50 in mapM_ (lintCmmBlock labels) blocks
52 lintCmmTop (CmmData {})
55 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
56 lintCmmBlock labels (BasicBlock id stmts)
57 = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
58 mapM_ (lintCmmStmt labels) stmts
60 -- -----------------------------------------------------------------------------
63 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
64 -- byte/word mismatches.
66 lintCmmExpr :: CmmExpr -> CmmLint MachRep
67 lintCmmExpr (CmmLoad expr rep) = do
69 when (machRepByteWidth rep >= wORD_SIZE) $
70 cmmCheckWordAddress expr
72 lintCmmExpr expr@(CmmMachOp op args) = do
73 mapM_ lintCmmExpr args
74 if map cmmExprRep args == machOpArgReps op
75 then cmmCheckMachOp op args
76 else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
77 lintCmmExpr (CmmRegOff reg offset)
78 = lintCmmExpr (CmmMachOp (MO_Add rep)
79 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
80 where rep = cmmRegRep reg
81 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
83 = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
85 return (cmmExprRep expr)
87 -- Check for some common byte/word mismatches (eg. Sp + 1)
88 cmmCheckMachOp :: MachOp -> [CmmExpr] -> CmmLint MachRep
89 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
90 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
91 = cmmLintDubiousWordOffset (CmmMachOp op args)
92 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)]
93 = cmmCheckMachOp op [reg, lit]
94 cmmCheckMachOp op@(MO_U_Conv from to) args
95 | isFloatingRep from || isFloatingRep to
96 = cmmLintErr (text "unsigned conversion from/to floating rep: "
97 <> ppr (CmmMachOp op args))
98 cmmCheckMachOp op _args
99 = return (resultRepOfMachOp op)
101 isWordOffsetReg :: CmmReg -> Bool
102 isWordOffsetReg (CmmGlobal Sp) = True
103 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
104 --isWordOffsetReg (CmmGlobal Hp) = True
105 isWordOffsetReg _ = False
107 isOffsetOp :: MachOp -> Bool
108 isOffsetOp (MO_Add _) = True
109 isOffsetOp (MO_Sub _) = True
112 -- This expression should be an address from which a word can be loaded:
113 -- check for funny-looking sub-word offsets.
114 cmmCheckWordAddress :: CmmExpr -> CmmLint ()
115 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
116 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
117 = cmmLintDubiousWordOffset e
118 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
119 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
120 = cmmLintDubiousWordOffset e
121 cmmCheckWordAddress _
124 -- No warnings for unaligned arithmetic with the node register,
125 -- which is used to extract fields from tagged constructor closures.
126 notNodeReg :: CmmExpr -> Bool
127 notNodeReg (CmmReg reg) | reg == nodeReg = False
130 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
131 lintCmmStmt labels = lint
132 where lint (CmmNop) = return ()
133 lint (CmmComment {}) = return ()
134 lint stmt@(CmmAssign reg expr) = do
135 erep <- lintCmmExpr expr
136 if (erep == cmmRegRep reg)
138 else cmmLintAssignErr stmt
139 lint (CmmStore l r) = do
143 lint (CmmCall target _res args _ _) =
144 lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
145 lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
146 lint (CmmSwitch e branches) = do
147 mapM_ checkTarget $ catMaybes branches
148 erep <- lintCmmExpr e
151 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
152 lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
153 lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) ress
154 lint (CmmBranch id) = checkTarget id
155 checkTarget id = if elemBlockSet id labels then return ()
156 else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
158 lintTarget :: CmmCallTarget -> CmmLint ()
159 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
160 lintTarget (CmmPrim {}) = return ()
163 checkCond :: CmmExpr -> CmmLint ()
164 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
165 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
168 -- -----------------------------------------------------------------------------
171 -- just a basic error monad:
173 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
175 instance Monad CmmLint where
176 CmmLint m >>= k = CmmLint $ case m of
178 Right a -> unCL (k a)
179 return a = CmmLint (Right a)
181 cmmLintErr :: SDoc -> CmmLint a
182 cmmLintErr msg = CmmLint (Left msg)
184 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
185 addLintInfo info thing = CmmLint $
187 Left err -> Left (hang info 2 err)
190 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
191 cmmLintMachOpErr expr argsRep opExpectsRep
192 = cmmLintErr (text "in MachOp application: " $$
193 nest 2 (pprExpr expr) $$
194 (text "op is expecting: " <+> ppr opExpectsRep) $$
195 (text "arguments provide: " <+> ppr argsRep))
197 cmmLintAssignErr :: CmmStmt -> CmmLint a
198 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
199 nest 2 (pprStmt stmt))
201 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
202 cmmLintDubiousWordOffset expr
203 = cmmLintErr (text "offset is not a multiple of words: " $$
204 nest 2 (pprExpr expr))