Honour -dsuppress-uniques more thoroughly
[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 CmmSwitch (switchTargetsToList)
18 import PprCmm ()
19 import Outputable
20 import DynFlags
21
22 import Control.Monad (liftM, ap)
23
24 -- Things to check:
25 -- - invariant on CmmBlock in CmmExpr (see comment there)
26 -- - check for branches to blocks that don't exist
27 -- - check types
28
29 -- -----------------------------------------------------------------------------
30 -- Exported entry points:
31
32 cmmLint :: (Outputable d, Outputable h)
33 => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
34 cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
35
36 cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
37 cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
38
39 runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
40 runCmmLint dflags l p =
41 case unCL (l p) dflags of
42 Left err -> Just (vcat [text "Cmm lint error:",
43 nest 2 err,
44 text "Program was:",
45 nest 2 (ppr p)])
46 Right _ -> Nothing
47
48 lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
49 lintCmmDecl dflags (CmmProc _ lbl _ g)
50 = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
51 lintCmmDecl _ (CmmData {})
52 = return ()
53
54
55 lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
56 lintCmmGraph dflags g =
57 cmmLocalLiveness dflags 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 :: LabelSet -> 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 dflags <- getDynFlags
89 tys <- mapM lintCmmExpr args
90 if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
91 then cmmCheckMachOp op args tys
92 else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
93 lintCmmExpr (CmmRegOff reg offset)
94 = do dflags <- getDynFlags
95 let rep = typeWidth (cmmRegType dflags reg)
96 lintCmmExpr (CmmMachOp (MO_Add rep)
97 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
98 lintCmmExpr expr =
99 do dflags <- getDynFlags
100 return (cmmExprType dflags expr)
101
102 -- Check for some common byte/word mismatches (eg. Sp + 1)
103 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
104 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
105 = cmmCheckMachOp op [reg, lit] tys
106 cmmCheckMachOp op _ tys
107 = do dflags <- getDynFlags
108 return (machOpResultType dflags op tys)
109
110 {-
111 isOffsetOp :: MachOp -> Bool
112 isOffsetOp (MO_Add _) = True
113 isOffsetOp (MO_Sub _) = True
114 isOffsetOp _ = False
115
116 -- This expression should be an address from which a word can be loaded:
117 -- check for funny-looking sub-word offsets.
118 _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
119 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
120 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
121 = cmmLintDubiousWordOffset e
122 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
123 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
124 = cmmLintDubiousWordOffset e
125 _cmmCheckWordAddress _
126 = return ()
127
128 -- No warnings for unaligned arithmetic with the node register,
129 -- which is used to extract fields from tagged constructor closures.
130 notNodeReg :: CmmExpr -> Bool
131 notNodeReg (CmmReg reg) | reg == nodeReg = False
132 notNodeReg _ = True
133 -}
134
135 lintCmmMiddle :: CmmNode O O -> CmmLint ()
136 lintCmmMiddle node = case node of
137 CmmComment _ -> return ()
138 CmmTick _ -> return ()
139 CmmUnwind{} -> return ()
140
141 CmmAssign reg expr -> do
142 dflags <- getDynFlags
143 erep <- lintCmmExpr expr
144 let reg_ty = cmmRegType dflags reg
145 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
146 then return ()
147 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
148
149 CmmStore l r -> do
150 _ <- lintCmmExpr l
151 _ <- lintCmmExpr r
152 return ()
153
154 CmmUnsafeForeignCall target _formals actuals -> do
155 lintTarget target
156 mapM_ lintCmmExpr actuals
157
158
159 lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
160 lintCmmLast labels node = case node of
161 CmmBranch id -> checkTarget id
162
163 CmmCondBranch e t f _ -> do
164 dflags <- getDynFlags
165 mapM_ checkTarget [t,f]
166 _ <- lintCmmExpr e
167 checkCond dflags e
168
169 CmmSwitch e ids -> do
170 dflags <- getDynFlags
171 mapM_ checkTarget $ switchTargetsToList ids
172 erep <- lintCmmExpr e
173 if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
174 then return ()
175 else cmmLintErr (text "switch scrutinee is not a word: " <>
176 ppr e <> text " :: " <> ppr erep)
177
178 CmmCall { cml_target = target, cml_cont = cont } -> do
179 _ <- lintCmmExpr target
180 maybe (return ()) checkTarget cont
181
182 CmmForeignCall tgt _ args succ _ _ _ -> do
183 lintTarget tgt
184 mapM_ lintCmmExpr args
185 checkTarget succ
186 where
187 checkTarget id
188 | setMember id labels = return ()
189 | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
190
191
192 lintTarget :: ForeignTarget -> CmmLint ()
193 lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
194 lintTarget (PrimTarget {}) = return ()
195
196
197 checkCond :: DynFlags -> CmmExpr -> CmmLint ()
198 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
199 checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
200 checkCond _ expr
201 = cmmLintErr (hang (text "expression is not a conditional:") 2
202 (ppr expr))
203
204 -- -----------------------------------------------------------------------------
205 -- CmmLint monad
206
207 -- just a basic error monad:
208
209 newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
210
211 instance Functor CmmLint where
212 fmap = liftM
213
214 instance Applicative CmmLint where
215 pure a = CmmLint (\_ -> Right a)
216 (<*>) = ap
217
218 instance Monad CmmLint where
219 CmmLint m >>= k = CmmLint $ \dflags ->
220 case m dflags of
221 Left e -> Left e
222 Right a -> unCL (k a) dflags
223
224 instance HasDynFlags CmmLint where
225 getDynFlags = CmmLint (\dflags -> Right dflags)
226
227 cmmLintErr :: SDoc -> CmmLint a
228 cmmLintErr msg = CmmLint (\_ -> Left msg)
229
230 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
231 addLintInfo info thing = CmmLint $ \dflags ->
232 case unCL thing dflags of
233 Left err -> Left (hang info 2 err)
234 Right a -> Right a
235
236 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
237 cmmLintMachOpErr expr argsRep opExpectsRep
238 = cmmLintErr (text "in MachOp application: " $$
239 nest 2 (ppr expr) $$
240 (text "op is expecting: " <+> ppr opExpectsRep) $$
241 (text "arguments provide: " <+> ppr argsRep))
242
243 cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
244 cmmLintAssignErr stmt e_ty r_ty
245 = cmmLintErr (text "in assignment: " $$
246 nest 2 (vcat [ppr stmt,
247 text "Reg ty:" <+> ppr r_ty,
248 text "Rhs ty:" <+> ppr e_ty]))
249
250
251 {-
252 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
253 cmmLintDubiousWordOffset expr
254 = cmmLintErr (text "offset is not a multiple of words: " $$
255 nest 2 (ppr expr))
256 -}
257