Make Applicative a superclass of Monad
[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, CPP #-}
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 #if __GLASGOW_HASKELL__ < 709
26 import Control.Applicative (Applicative(..))
27 #endif
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 [ptext $ sLit ("Cmm lint error:"),
48 nest 2 err,
49 ptext $ sLit ("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 :: BlockSet -> 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
144 CmmAssign reg expr -> do
145 dflags <- getDynFlags
146 erep <- lintCmmExpr expr
147 let reg_ty = cmmRegType dflags reg
148 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
149 then return ()
150 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
151
152 CmmStore l r -> do
153 _ <- lintCmmExpr l
154 _ <- lintCmmExpr r
155 return ()
156
157 CmmUnsafeForeignCall target _formals actuals -> do
158 lintTarget target
159 mapM_ lintCmmExpr actuals
160
161
162 lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
163 lintCmmLast labels node = case node of
164 CmmBranch id -> checkTarget id
165
166 CmmCondBranch e t f -> do
167 dflags <- getDynFlags
168 mapM_ checkTarget [t,f]
169 _ <- lintCmmExpr e
170 checkCond dflags e
171
172 CmmSwitch e branches -> do
173 dflags <- getDynFlags
174 mapM_ checkTarget $ catMaybes branches
175 erep <- lintCmmExpr e
176 if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
177 then return ()
178 else cmmLintErr (text "switch scrutinee is not a word: " <>
179 ppr e <> text " :: " <> ppr erep)
180
181 CmmCall { cml_target = target, cml_cont = cont } -> do
182 _ <- lintCmmExpr target
183 maybe (return ()) checkTarget cont
184
185 CmmForeignCall tgt _ args succ _ _ _ -> do
186 lintTarget tgt
187 mapM_ lintCmmExpr args
188 checkTarget succ
189 where
190 checkTarget id
191 | setMember id labels = return ()
192 | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
193
194
195 lintTarget :: ForeignTarget -> CmmLint ()
196 lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
197 lintTarget (PrimTarget {}) = return ()
198
199
200 checkCond :: DynFlags -> CmmExpr -> CmmLint ()
201 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
202 checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
203 checkCond _ expr
204 = cmmLintErr (hang (text "expression is not a conditional:") 2
205 (ppr expr))
206
207 -- -----------------------------------------------------------------------------
208 -- CmmLint monad
209
210 -- just a basic error monad:
211
212 newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
213
214 instance Functor CmmLint where
215 fmap = liftM
216
217 instance Applicative CmmLint where
218 pure = return
219 (<*>) = ap
220
221 instance Monad CmmLint where
222 CmmLint m >>= k = CmmLint $ \dflags ->
223 case m dflags of
224 Left e -> Left e
225 Right a -> unCL (k a) dflags
226 return a = CmmLint (\_ -> Right a)
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