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