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