Make lint check for undefined variables in Cmm
[ghc.git] / compiler / cmm / CmmLint.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2011
4 --
5 -- CmmLint: checking the correctness of Cmm statements and expressions
6 --
7 -----------------------------------------------------------------------------
8 {-# LANGUAGE GADTs #-}
9 module CmmLint (
10 cmmLint, cmmLintGraph
11 ) where
12
13 import Hoopl
14 import Cmm
15 import CmmUtils
16 import CmmLive
17 import PprCmm ()
18 import BlockId
19 import FastString
20 import Outputable
21 import Constants
22
23 import Data.Maybe
24
25 -- Things to check:
26 -- - invariant on CmmBlock in CmmExpr (see comment there)
27 -- - check for branches to blocks that don't exist
28 -- - check types
29
30 -- -----------------------------------------------------------------------------
31 -- Exported entry points:
32
33 cmmLint :: (Outputable d, Outputable h)
34 => GenCmmGroup d h CmmGraph -> Maybe SDoc
35 cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
36
37 cmmLintGraph :: CmmGraph -> Maybe SDoc
38 cmmLintGraph g = runCmmLint lintCmmGraph g
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 lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
50 lintCmmDecl (CmmProc _ lbl g)
51 = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
52 lintCmmDecl (CmmData {})
53 = return ()
54
55
56 lintCmmGraph :: CmmGraph -> CmmLint ()
57 lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks
58 -- cmmLiveness throws an error if there are registers
59 -- live on entry to the graph (i.e. undefined
60 -- variables)
61 where
62 blocks = toBlockList g
63 labels = setFromList (map entryLabel blocks)
64
65
66 lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
67 lintCmmBlock labels block
68 = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
69 let (_, middle, last) = blockSplit block
70 mapM_ lintCmmMiddle (blockToList middle)
71 lintCmmLast labels last
72
73 -- -----------------------------------------------------------------------------
74 -- lintCmmExpr
75
76 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
77 -- byte/word mismatches.
78
79 lintCmmExpr :: CmmExpr -> CmmLint CmmType
80 lintCmmExpr (CmmLoad expr rep) = do
81 _ <- lintCmmExpr expr
82 -- Disabled, if we have the inlining phase before the lint phase,
83 -- we can have funny offsets due to pointer tagging. -- EZY
84 -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
85 -- cmmCheckWordAddress expr
86 return rep
87 lintCmmExpr expr@(CmmMachOp op args) = do
88 tys <- mapM lintCmmExpr args
89 if map (typeWidth . cmmExprType) args == machOpArgReps op
90 then cmmCheckMachOp op args tys
91 else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
92 lintCmmExpr (CmmRegOff reg offset)
93 = lintCmmExpr (CmmMachOp (MO_Add rep)
94 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
95 where rep = typeWidth (cmmRegType reg)
96 lintCmmExpr expr =
97 return (cmmExprType expr)
98
99 -- Check for some common byte/word mismatches (eg. Sp + 1)
100 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
101 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
102 = cmmCheckMachOp op [reg, lit] tys
103 cmmCheckMachOp op _ tys
104 = return (machOpResultType op tys)
105
106 isOffsetOp :: MachOp -> Bool
107 isOffsetOp (MO_Add _) = True
108 isOffsetOp (MO_Sub _) = True
109 isOffsetOp _ = False
110
111 -- This expression should be an address from which a word can be loaded:
112 -- check for funny-looking sub-word offsets.
113 _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
114 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
115 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
116 = cmmLintDubiousWordOffset e
117 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
118 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
119 = cmmLintDubiousWordOffset e
120 _cmmCheckWordAddress _
121 = return ()
122
123 -- No warnings for unaligned arithmetic with the node register,
124 -- which is used to extract fields from tagged constructor closures.
125 notNodeReg :: CmmExpr -> Bool
126 notNodeReg (CmmReg reg) | reg == nodeReg = False
127 notNodeReg _ = True
128
129 lintCmmMiddle :: CmmNode O O -> CmmLint ()
130 lintCmmMiddle node = case node of
131 CmmComment _ -> return ()
132
133 CmmAssign reg expr -> do
134 erep <- lintCmmExpr expr
135 let reg_ty = cmmRegType reg
136 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
137 then return ()
138 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
139
140 CmmStore l r -> do
141 _ <- lintCmmExpr l
142 _ <- lintCmmExpr r
143 return ()
144
145 CmmUnsafeForeignCall target _formals actuals -> do
146 lintTarget target
147 mapM_ lintCmmExpr actuals
148
149
150 lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
151 lintCmmLast labels node = case node of
152 CmmBranch id -> checkTarget id
153
154 CmmCondBranch e t f -> do
155 mapM_ checkTarget [t,f]
156 _ <- lintCmmExpr e
157 checkCond e
158
159 CmmSwitch e branches -> do
160 mapM_ checkTarget $ catMaybes branches
161 erep <- lintCmmExpr e
162 if (erep `cmmEqType_ignoring_ptrhood` bWord)
163 then return ()
164 else cmmLintErr (text "switch scrutinee is not a word: " <>
165 ppr e <> text " :: " <> ppr erep)
166
167 CmmCall { cml_target = target, cml_cont = cont } -> do
168 _ <- lintCmmExpr target
169 maybe (return ()) checkTarget cont
170
171 CmmForeignCall tgt _ args succ _ _ -> do
172 lintTarget tgt
173 mapM_ lintCmmExpr args
174 checkTarget succ
175 where
176 checkTarget id
177 | setMember id labels = return ()
178 | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
179
180
181 lintTarget :: ForeignTarget -> CmmLint ()
182 lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
183 lintTarget (PrimTarget {}) = return ()
184
185
186 checkCond :: CmmExpr -> CmmLint ()
187 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
188 checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
189 checkCond expr
190 = cmmLintErr (hang (text "expression is not a conditional:") 2
191 (ppr expr))
192
193 -- -----------------------------------------------------------------------------
194 -- CmmLint monad
195
196 -- just a basic error monad:
197
198 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
199
200 instance Monad CmmLint where
201 CmmLint m >>= k = CmmLint $ case m of
202 Left e -> Left e
203 Right a -> unCL (k a)
204 return a = CmmLint (Right a)
205
206 cmmLintErr :: SDoc -> CmmLint a
207 cmmLintErr msg = CmmLint (Left msg)
208
209 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
210 addLintInfo info thing = CmmLint $
211 case unCL thing of
212 Left err -> Left (hang info 2 err)
213 Right a -> Right a
214
215 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
216 cmmLintMachOpErr expr argsRep opExpectsRep
217 = cmmLintErr (text "in MachOp application: " $$
218 nest 2 (ppr expr) $$
219 (text "op is expecting: " <+> ppr opExpectsRep) $$
220 (text "arguments provide: " <+> ppr argsRep))
221
222 cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
223 cmmLintAssignErr stmt e_ty r_ty
224 = cmmLintErr (text "in assignment: " $$
225 nest 2 (vcat [ppr stmt,
226 text "Reg ty:" <+> ppr r_ty,
227 text "Rhs ty:" <+> ppr e_ty]))
228
229
230 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
231 cmmLintDubiousWordOffset expr
232 = cmmLintErr (text "offset is not a multiple of words: " $$
233 nest 2 (ppr expr))