Merge remote branch 'origin/master' into monad-comp
[ghc.git] / compiler / cmm / CmmLint.hs
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
5 -- for details
6
7 -----------------------------------------------------------------------------
8 --
9 -- (c) The University of Glasgow 2004-2006
10 --
11 -- CmmLint: checking the correctness of Cmm statements and expressions
12 --
13 -----------------------------------------------------------------------------
14
15 module CmmLint (
16 cmmLint, cmmLintTop
17 ) where
18
19 import BlockId
20 import OldCmm
21 import CLabel
22 import Outputable
23 import OldPprCmm()
24 import Constants
25 import FastString
26
27 import Data.Maybe
28
29 -- -----------------------------------------------------------------------------
30 -- Exported entry points:
31
32 cmmLint :: (Outputable d, Outputable h)
33 => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
34 cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
35
36 cmmLintTop :: (Outputable d, Outputable h)
37 => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
38 cmmLintTop top = runCmmLint lintCmmTop top
39
40 runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
41 runCmmLint l p =
42 case unCL (l p) of
43 Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
44 nest 2 err,
45 ptext $ sLit ("Program was:"),
46 nest 2 (ppr p)])
47 Right _ -> Nothing
48
49 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
50 lintCmmTop (CmmProc _ lbl (ListGraph blocks))
51 = addLintInfo (text "in proc " <> pprCLabel lbl) $
52 let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
53 in mapM_ (lintCmmBlock labels) blocks
54
55 lintCmmTop (CmmData {})
56 = return ()
57
58 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
59 lintCmmBlock labels (BasicBlock id stmts)
60 = addLintInfo (text "in basic block " <> ppr id) $
61 mapM_ (lintCmmStmt labels) stmts
62
63 -- -----------------------------------------------------------------------------
64 -- lintCmmExpr
65
66 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
67 -- byte/word mismatches.
68
69 lintCmmExpr :: CmmExpr -> CmmLint CmmType
70 lintCmmExpr (CmmLoad expr rep) = do
71 _ <- lintCmmExpr expr
72 -- Disabled, if we have the inlining phase before the lint phase,
73 -- we can have funny offsets due to pointer tagging. -- EZY
74 -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
75 -- cmmCheckWordAddress expr
76 return rep
77 lintCmmExpr expr@(CmmMachOp op args) = do
78 tys <- mapM lintCmmExpr args
79 if map (typeWidth . cmmExprType) args == machOpArgReps op
80 then cmmCheckMachOp op args tys
81 else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
82 lintCmmExpr (CmmRegOff reg offset)
83 = lintCmmExpr (CmmMachOp (MO_Add rep)
84 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
85 where rep = typeWidth (cmmRegType reg)
86 lintCmmExpr expr =
87 return (cmmExprType expr)
88
89 -- Check for some common byte/word mismatches (eg. Sp + 1)
90 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
91 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
92 = cmmCheckMachOp op [reg, lit] tys
93 cmmCheckMachOp op _ tys
94 = return (machOpResultType op tys)
95
96 isOffsetOp :: MachOp -> Bool
97 isOffsetOp (MO_Add _) = True
98 isOffsetOp (MO_Sub _) = True
99 isOffsetOp _ = False
100
101 -- This expression should be an address from which a word can be loaded:
102 -- check for funny-looking sub-word offsets.
103 _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
104 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
105 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
106 = cmmLintDubiousWordOffset e
107 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
108 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
109 = cmmLintDubiousWordOffset e
110 _cmmCheckWordAddress _
111 = return ()
112
113 -- No warnings for unaligned arithmetic with the node register,
114 -- which is used to extract fields from tagged constructor closures.
115 notNodeReg :: CmmExpr -> Bool
116 notNodeReg (CmmReg reg) | reg == nodeReg = False
117 notNodeReg _ = True
118
119 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
120 lintCmmStmt labels = lint
121 where lint (CmmNop) = return ()
122 lint (CmmComment {}) = return ()
123 lint stmt@(CmmAssign reg expr) = do
124 erep <- lintCmmExpr expr
125 let reg_ty = cmmRegType reg
126 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
127 then return ()
128 else cmmLintAssignErr stmt erep reg_ty
129 lint (CmmStore l r) = do
130 _ <- lintCmmExpr l
131 _ <- lintCmmExpr r
132 return ()
133 lint (CmmCall target _res args _ _) =
134 lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
135 lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
136 lint (CmmSwitch e branches) = do
137 mapM_ checkTarget $ catMaybes branches
138 erep <- lintCmmExpr e
139 if (erep `cmmEqType_ignoring_ptrhood` bWord)
140 then return ()
141 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
142 text " :: " <> ppr erep)
143 lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
144 lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
145 lint (CmmBranch id) = checkTarget id
146 checkTarget id = if setMember id labels then return ()
147 else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
148
149 lintTarget :: CmmCallTarget -> CmmLint ()
150 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
151 lintTarget (CmmPrim {}) = return ()
152
153
154 checkCond :: CmmExpr -> CmmLint ()
155 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
156 checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
157 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
158 (ppr expr))
159
160 -- -----------------------------------------------------------------------------
161 -- CmmLint monad
162
163 -- just a basic error monad:
164
165 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
166
167 instance Monad CmmLint where
168 CmmLint m >>= k = CmmLint $ case m of
169 Left e -> Left e
170 Right a -> unCL (k a)
171 return a = CmmLint (Right a)
172
173 cmmLintErr :: SDoc -> CmmLint a
174 cmmLintErr msg = CmmLint (Left msg)
175
176 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
177 addLintInfo info thing = CmmLint $
178 case unCL thing of
179 Left err -> Left (hang info 2 err)
180 Right a -> Right a
181
182 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
183 cmmLintMachOpErr expr argsRep opExpectsRep
184 = cmmLintErr (text "in MachOp application: " $$
185 nest 2 (ppr expr) $$
186 (text "op is expecting: " <+> ppr opExpectsRep) $$
187 (text "arguments provide: " <+> ppr argsRep))
188
189 cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
190 cmmLintAssignErr stmt e_ty r_ty
191 = cmmLintErr (text "in assignment: " $$
192 nest 2 (vcat [ppr stmt,
193 text "Reg ty:" <+> ppr r_ty,
194 text "Rhs ty:" <+> ppr e_ty]))
195
196
197
198 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
199 cmmLintDubiousWordOffset expr
200 = cmmLintErr (text "offset is not a multiple of words: " $$
201 nest 2 (ppr expr))