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