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