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