Merge branch 'master' of http://darcs.haskell.org//ghc
[ghc.git] / compiler / cmm / CmmLint.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2004-2006
4 --
5 -- CmmLint: checking the correctness of Cmm statements and expressions
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module CmmLint (
17 cmmLint, cmmLintTop
18 ) where
19
20 import BlockId
21 import OldCmm
22 import CLabel
23 import Outputable
24 import OldPprCmm()
25 import Constants
26 import FastString
27 import Platform
28
29 import Data.Maybe
30
31 -- -----------------------------------------------------------------------------
32 -- Exported entry points:
33
34 cmmLint :: (PlatformOutputable d, PlatformOutputable h)
35 => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
36 cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
37
38 cmmLintTop :: (PlatformOutputable d, PlatformOutputable h)
39 => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
40 cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
41
42 runCmmLint :: PlatformOutputable a
43 => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
44 runCmmLint platform l p =
45 case unCL (l p) of
46 Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
47 nest 2 err,
48 ptext $ sLit ("Program was:"),
49 nest 2 (pprPlatform platform p)])
50 Right _ -> Nothing
51
52 lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
53 lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
54 = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
55 let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
56 in mapM_ (lintCmmBlock platform labels) blocks
57
58 lintCmmDecl _ (CmmData {})
59 = return ()
60
61 lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
62 lintCmmBlock platform labels (BasicBlock id stmts)
63 = addLintInfo (text "in basic block " <> ppr id) $
64 mapM_ (lintCmmStmt platform labels) stmts
65
66 -- -----------------------------------------------------------------------------
67 -- lintCmmExpr
68
69 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
70 -- byte/word mismatches.
71
72 lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
73 lintCmmExpr platform (CmmLoad expr rep) = do
74 _ <- lintCmmExpr platform expr
75 -- Disabled, if we have the inlining phase before the lint phase,
76 -- we can have funny offsets due to pointer tagging. -- EZY
77 -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
78 -- cmmCheckWordAddress expr
79 return rep
80 lintCmmExpr platform expr@(CmmMachOp op args) = do
81 tys <- mapM (lintCmmExpr platform) args
82 if map (typeWidth . cmmExprType) args == machOpArgReps op
83 then cmmCheckMachOp op args tys
84 else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op)
85 lintCmmExpr platform (CmmRegOff reg offset)
86 = lintCmmExpr platform (CmmMachOp (MO_Add rep)
87 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
88 where rep = typeWidth (cmmRegType reg)
89 lintCmmExpr _ expr =
90 return (cmmExprType expr)
91
92 -- Check for some common byte/word mismatches (eg. Sp + 1)
93 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
94 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
95 = cmmCheckMachOp op [reg, lit] tys
96 cmmCheckMachOp op _ tys
97 = return (machOpResultType op tys)
98
99 isOffsetOp :: MachOp -> Bool
100 isOffsetOp (MO_Add _) = True
101 isOffsetOp (MO_Sub _) = True
102 isOffsetOp _ = False
103
104 -- This expression should be an address from which a word can be loaded:
105 -- check for funny-looking sub-word offsets.
106 _cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint ()
107 _cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
108 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
109 = cmmLintDubiousWordOffset platform e
110 _cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
111 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
112 = cmmLintDubiousWordOffset platform e
113 _cmmCheckWordAddress _ _
114 = return ()
115
116 -- No warnings for unaligned arithmetic with the node register,
117 -- which is used to extract fields from tagged constructor closures.
118 notNodeReg :: CmmExpr -> Bool
119 notNodeReg (CmmReg reg) | reg == nodeReg = False
120 notNodeReg _ = True
121
122 lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
123 lintCmmStmt platform labels = lint
124 where lint (CmmNop) = return ()
125 lint (CmmComment {}) = return ()
126 lint stmt@(CmmAssign reg expr) = do
127 erep <- lintCmmExpr platform expr
128 let reg_ty = cmmRegType reg
129 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
130 then return ()
131 else cmmLintAssignErr platform stmt erep reg_ty
132 lint (CmmStore l r) = do
133 _ <- lintCmmExpr platform l
134 _ <- lintCmmExpr platform r
135 return ()
136 lint (CmmCall target _res args _) =
137 lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
138 lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
139 lint (CmmSwitch e branches) = do
140 mapM_ checkTarget $ catMaybes branches
141 erep <- lintCmmExpr platform e
142 if (erep `cmmEqType_ignoring_ptrhood` bWord)
143 then return ()
144 else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
145 text " :: " <> ppr erep)
146 lint (CmmJump e args) = lintCmmExpr platform e >> mapM_ (lintCmmExpr platform . hintlessCmm) args
147 lint (CmmReturn ress) = mapM_ (lintCmmExpr platform . hintlessCmm) ress
148 lint (CmmBranch id) = checkTarget id
149 checkTarget id = if setMember id labels then return ()
150 else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
151
152 lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
153 lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
154 lintTarget _ (CmmPrim {}) = return ()
155
156
157 checkCond :: Platform -> CmmExpr -> CmmLint ()
158 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
159 checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
160 checkCond platform expr
161 = cmmLintErr (hang (text "expression is not a conditional:") 2
162 (pprPlatform platform expr))
163
164 -- -----------------------------------------------------------------------------
165 -- CmmLint monad
166
167 -- just a basic error monad:
168
169 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
170
171 instance Monad CmmLint where
172 CmmLint m >>= k = CmmLint $ case m of
173 Left e -> Left e
174 Right a -> unCL (k a)
175 return a = CmmLint (Right a)
176
177 cmmLintErr :: SDoc -> CmmLint a
178 cmmLintErr msg = CmmLint (Left msg)
179
180 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
181 addLintInfo info thing = CmmLint $
182 case unCL thing of
183 Left err -> Left (hang info 2 err)
184 Right a -> Right a
185
186 cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a
187 cmmLintMachOpErr platform expr argsRep opExpectsRep
188 = cmmLintErr (text "in MachOp application: " $$
189 nest 2 (pprPlatform platform expr) $$
190 (text "op is expecting: " <+> ppr opExpectsRep) $$
191 (text "arguments provide: " <+> ppr argsRep))
192
193 cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a
194 cmmLintAssignErr platform stmt e_ty r_ty
195 = cmmLintErr (text "in assignment: " $$
196 nest 2 (vcat [pprPlatform platform stmt,
197 text "Reg ty:" <+> ppr r_ty,
198 text "Rhs ty:" <+> ppr e_ty]))
199
200
201
202 cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a
203 cmmLintDubiousWordOffset platform expr
204 = cmmLintErr (text "offset is not a multiple of words: " $$
205 nest 2 (pprPlatform platform expr))