never executed always true always false
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2011
4 --
5 -- CmmLint: checking the correctness of Cmm statements and expressions
6 --
7 -----------------------------------------------------------------------------
8 {-# LANGUAGE DeriveFunctor #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE GADTs #-}
11 module GHC.Cmm.Lint (
12 cmmLint, cmmLintGraph
13 ) where
14
15 import GHC.Prelude
16
17 import GHC.Platform
18 import GHC.Platform.Regs (callerSaves)
19 import GHC.Cmm.Dataflow.Block
20 import GHC.Cmm.Dataflow.Collections
21 import GHC.Cmm.Dataflow.Graph
22 import GHC.Cmm.Dataflow.Label
23 import GHC.Cmm
24 import GHC.Cmm.Utils
25 import GHC.Cmm.Liveness
26 import GHC.Cmm.Switch (switchTargetsToList)
27 import GHC.Cmm.Ppr () -- For Outputable instances
28 import GHC.Utils.Outputable
29
30 import Control.Monad (ap, unless)
31
32 -- Things to check:
33 -- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
34 -- - check for branches to blocks that don't exist
35 -- - check types
36
37 -- -----------------------------------------------------------------------------
38 -- Exported entry points:
39
40 cmmLint :: (OutputableP Platform d, OutputableP Platform h)
41 => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
42 cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
43
44 cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
45 cmmLintGraph platform g = runCmmLint platform lintCmmGraph g
46
47 runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
48 runCmmLint platform l p =
49 case unCL (l p) platform of
50 Left err -> Just (vcat [text "Cmm lint error:",
51 nest 2 err,
52 text "Program was:",
53 nest 2 (pdoc platform p)])
54 Right _ -> Nothing
55
56 lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
57 lintCmmDecl (CmmProc _ lbl _ g)
58 = do
59 platform <- getPlatform
60 addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g
61 lintCmmDecl (CmmData {})
62 = return ()
63
64
65 lintCmmGraph :: CmmGraph -> CmmLint ()
66 lintCmmGraph g = do
67 platform <- getPlatform
68 let
69 blocks = toBlockList g
70 labels = setFromList (map entryLabel blocks)
71 cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks
72 -- cmmLiveness throws an error if there are registers
73 -- live on entry to the graph (i.e. undefined
74 -- variables)
75
76
77 lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
78 lintCmmBlock labels block
79 = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
80 let (_, middle, last) = blockSplit block
81 mapM_ lintCmmMiddle (blockToList middle)
82 lintCmmLast labels last
83
84 -- -----------------------------------------------------------------------------
85 -- lintCmmExpr
86
87 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
88 -- byte/word mismatches.
89
90 lintCmmExpr :: CmmExpr -> CmmLint CmmType
91 lintCmmExpr (CmmLoad expr rep) = do
92 _ <- lintCmmExpr expr
93 -- Disabled, if we have the inlining phase before the lint phase,
94 -- we can have funny offsets due to pointer tagging. -- EZY
95 -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
96 -- cmmCheckWordAddress expr
97 return rep
98 lintCmmExpr expr@(CmmMachOp op args) = do
99 platform <- getPlatform
100 tys <- mapM lintCmmExpr args
101 if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
102 then cmmCheckMachOp op args tys
103 else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
104 lintCmmExpr (CmmRegOff reg offset)
105 = do platform <- getPlatform
106 let rep = typeWidth (cmmRegType platform reg)
107 lintCmmExpr (CmmMachOp (MO_Add rep)
108 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
109 lintCmmExpr expr =
110 do platform <- getPlatform
111 return (cmmExprType platform expr)
112
113 -- Check for some common byte/word mismatches (eg. Sp + 1)
114 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
115 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
116 = cmmCheckMachOp op [reg, lit] tys
117 cmmCheckMachOp op _ tys
118 = do platform <- getPlatform
119 return (machOpResultType platform op tys)
120
121 {-
122 isOffsetOp :: MachOp -> Bool
123 isOffsetOp (MO_Add _) = True
124 isOffsetOp (MO_Sub _) = True
125 isOffsetOp _ = False
126
127 -- This expression should be an address from which a word can be loaded:
128 -- check for funny-looking sub-word offsets.
129 _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
130 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
131 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
132 = cmmLintDubiousWordOffset e
133 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
134 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
135 = cmmLintDubiousWordOffset e
136 _cmmCheckWordAddress _
137 = return ()
138
139 -- No warnings for unaligned arithmetic with the node register,
140 -- which is used to extract fields from tagged constructor closures.
141 notNodeReg :: CmmExpr -> Bool
142 notNodeReg (CmmReg reg) | reg == nodeReg = False
143 notNodeReg _ = True
144 -}
145
146 lintCmmMiddle :: CmmNode O O -> CmmLint ()
147 lintCmmMiddle node = case node of
148 CmmComment _ -> return ()
149 CmmTick _ -> return ()
150 CmmUnwind{} -> return ()
151
152 CmmAssign reg expr -> do
153 platform <- getPlatform
154 erep <- lintCmmExpr expr
155 let reg_ty = cmmRegType platform reg
156 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
157 then return ()
158 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
159
160 CmmStore l r -> do
161 _ <- lintCmmExpr l
162 _ <- lintCmmExpr r
163 return ()
164
165 CmmUnsafeForeignCall target _formals actuals -> do
166 lintTarget target
167 let lintArg expr = do
168 -- Arguments can't mention caller-saved
169 -- registers. See Note [Register parameter passing].
170 mayNotMentionCallerSavedRegs (text "foreign call argument") expr
171 lintCmmExpr expr
172
173 mapM_ lintArg actuals
174
175
176 lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
177 lintCmmLast labels node = case node of
178 CmmBranch id -> checkTarget id
179
180 CmmCondBranch e t f _ -> do
181 platform <- getPlatform
182 mapM_ checkTarget [t,f]
183 _ <- lintCmmExpr e
184 checkCond platform e
185
186 CmmSwitch e ids -> do
187 platform <- getPlatform
188 mapM_ checkTarget $ switchTargetsToList ids
189 erep <- lintCmmExpr e
190 unless (isWordAny erep) $
191 cmmLintErr (text "switch scrutinee is not a word (of any size): " <>
192 pdoc platform e <> text " :: " <> ppr erep)
193
194 CmmCall { cml_target = target, cml_cont = cont } -> do
195 _ <- lintCmmExpr target
196 maybe (return ()) checkTarget cont
197
198 CmmForeignCall tgt _ args succ _ _ _ -> do
199 lintTarget tgt
200 let lintArg expr = do
201 -- Arguments can't mention caller-saved
202 -- registers. See Note [Register
203 -- parameter passing].
204 -- N.B. This won't catch local registers
205 -- which the NCG's register allocator later
206 -- places in caller-saved registers.
207 mayNotMentionCallerSavedRegs (text "foreign call argument") expr
208 lintCmmExpr expr
209 mapM_ lintArg args
210 checkTarget succ
211 where
212 checkTarget id
213 | setMember id labels = return ()
214 | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
215
216 lintTarget :: ForeignTarget -> CmmLint ()
217 lintTarget (ForeignTarget e _) = do
218 mayNotMentionCallerSavedRegs (text "foreign target") e
219 _ <- lintCmmExpr e
220 return ()
221 lintTarget (PrimTarget {}) = return ()
222
223 -- | As noted in Note [Register parameter passing], the arguments and
224 -- 'ForeignTarget' of a foreign call mustn't mention
225 -- caller-saved registers.
226 mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP Platform a)
227 => SDoc -> a -> CmmLint ()
228 mayNotMentionCallerSavedRegs what thing = do
229 platform <- getPlatform
230 let badRegs = filter (callerSaves platform)
231 $ foldRegsUsed platform (flip (:)) [] thing
232 unless (null badRegs)
233 $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing)
234
235 checkCond :: Platform -> CmmExpr -> CmmLint ()
236 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
237 checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
238 checkCond platform expr
239 = cmmLintErr (hang (text "expression is not a conditional:") 2
240 (pdoc platform expr))
241
242 -- -----------------------------------------------------------------------------
243 -- CmmLint monad
244
245 -- just a basic error monad:
246
247 newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }
248 deriving (Functor)
249
250 instance Applicative CmmLint where
251 pure a = CmmLint (\_ -> Right a)
252 (<*>) = ap
253
254 instance Monad CmmLint where
255 CmmLint m >>= k = CmmLint $ \platform ->
256 case m platform of
257 Left e -> Left e
258 Right a -> unCL (k a) platform
259
260 getPlatform :: CmmLint Platform
261 getPlatform = CmmLint $ \platform -> Right platform
262
263 cmmLintErr :: SDoc -> CmmLint a
264 cmmLintErr msg = CmmLint (\_ -> Left msg)
265
266 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
267 addLintInfo info thing = CmmLint $ \platform ->
268 case unCL thing platform of
269 Left err -> Left (hang info 2 err)
270 Right a -> Right a
271
272 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
273 cmmLintMachOpErr expr argsRep opExpectsRep
274 = do
275 platform <- getPlatform
276 cmmLintErr (text "in MachOp application: " $$
277 nest 2 (pdoc platform expr) $$
278 (text "op is expecting: " <+> ppr opExpectsRep) $$
279 (text "arguments provide: " <+> ppr argsRep))
280
281 cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
282 cmmLintAssignErr stmt e_ty r_ty
283 = do
284 platform <- getPlatform
285 cmmLintErr (text "in assignment: " $$
286 nest 2 (vcat [pdoc platform stmt,
287 text "Reg ty:" <+> ppr r_ty,
288 text "Rhs ty:" <+> ppr e_ty]))
289
290
291 {-
292 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
293 cmmLintDubiousWordOffset expr
294 = cmmLintErr (text "offset is not a multiple of words: " $$
295 nest 2 (ppr expr))
296 -}
297