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