Snapshot of codegen refactoring to share with simonpj
[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 :: (Outputable d, Outputable h)
34 => Platform -> GenCmmPgm d h (ListGraph CmmStmt) -> Maybe SDoc
35 cmmLint platform tops = runCmmLint platform (mapM_ lintCmmTop) tops
36
37 cmmLintTop :: (Outputable d, Outputable h)
38 => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
39 cmmLintTop platform top = runCmmLint platform lintCmmTop 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 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
52 lintCmmTop (CmmProc _ lbl (ListGraph blocks))
53 = addLintInfo (text "in proc " <> pprCLabel lbl) $
54 let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
55 in mapM_ (lintCmmBlock labels) blocks
56
57 lintCmmTop (CmmData {})
58 = return ()
59
60 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
61 lintCmmBlock labels (BasicBlock id stmts)
62 = addLintInfo (text "in basic block " <> ppr id) $
63 mapM_ (lintCmmStmt 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 :: CmmExpr -> CmmLint CmmType
72 lintCmmExpr (CmmLoad expr rep) = do
73 _ <- lintCmmExpr 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 expr@(CmmMachOp op args) = do
80 tys <- mapM lintCmmExpr args
81 if map (typeWidth . cmmExprType) args == machOpArgReps op
82 then cmmCheckMachOp op args tys
83 else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
84 lintCmmExpr (CmmRegOff reg offset)
85 = lintCmmExpr (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 :: CmmExpr -> CmmLint ()
106 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
107 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
108 = cmmLintDubiousWordOffset e
109 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
110 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
111 = cmmLintDubiousWordOffset 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 :: BlockSet -> CmmStmt -> CmmLint ()
122 lintCmmStmt labels = lint
123 where lint (CmmNop) = return ()
124 lint (CmmComment {}) = return ()
125 lint stmt@(CmmAssign reg expr) = do
126 erep <- lintCmmExpr expr
127 let reg_ty = cmmRegType reg
128 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
129 then return ()
130 else cmmLintAssignErr stmt erep reg_ty
131 lint (CmmStore l r) = do
132 _ <- lintCmmExpr l
133 _ <- lintCmmExpr r
134 return ()
135 lint (CmmCall target _res args _ _) =
136 lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
137 lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
138 lint (CmmSwitch e branches) = do
139 mapM_ checkTarget $ catMaybes branches
140 erep <- lintCmmExpr e
141 if (erep `cmmEqType_ignoring_ptrhood` bWord)
142 then return ()
143 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
144 text " :: " <> ppr erep)
145 lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
146 lint (CmmReturn ress) = mapM_ (lintCmmExpr . 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 :: CmmCallTarget -> CmmLint ()
152 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
153 lintTarget (CmmPrim {}) = return ()
154
155
156 checkCond :: 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 expr = cmmLintErr (hang (text "expression is not a conditional:") 2
160 (ppr expr))
161
162 -- -----------------------------------------------------------------------------
163 -- CmmLint monad
164
165 -- just a basic error monad:
166
167 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
168
169 instance Monad CmmLint where
170 CmmLint m >>= k = CmmLint $ case m of
171 Left e -> Left e
172 Right a -> unCL (k a)
173 return a = CmmLint (Right a)
174
175 cmmLintErr :: SDoc -> CmmLint a
176 cmmLintErr msg = CmmLint (Left msg)
177
178 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
179 addLintInfo info thing = CmmLint $
180 case unCL thing of
181 Left err -> Left (hang info 2 err)
182 Right a -> Right a
183
184 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
185 cmmLintMachOpErr expr argsRep opExpectsRep
186 = cmmLintErr (text "in MachOp application: " $$
187 nest 2 (ppr expr) $$
188 (text "op is expecting: " <+> ppr opExpectsRep) $$
189 (text "arguments provide: " <+> ppr argsRep))
190
191 cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
192 cmmLintAssignErr stmt e_ty r_ty
193 = cmmLintErr (text "in assignment: " $$
194 nest 2 (vcat [ppr stmt,
195 text "Reg ty:" <+> ppr r_ty,
196 text "Rhs ty:" <+> ppr e_ty]))
197
198
199
200 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
201 cmmLintDubiousWordOffset expr
202 = cmmLintErr (text "offset is not a multiple of words: " $$
203 nest 2 (ppr expr))