put CmmReturnInfo into a CmmCall (and related types)
[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 module CmmLint (
10 cmmLint, cmmLintTop
11 ) where
12
13 #include "HsVersions.h"
14
15 import Cmm
16 import CLabel
17 import MachOp
18 import Outputable
19 import PprCmm
20 import Unique
21 import Constants
22
23 import Control.Monad
24
25 -- -----------------------------------------------------------------------------
26 -- Exported entry points:
27
28 cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
29 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
30
31 cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
32 cmmLintTop top = runCmmLint $ lintCmmTop top
33
34 runCmmLint :: CmmLint a -> Maybe SDoc
35 runCmmLint l =
36 case unCL l of
37 Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
38 Right _ -> Nothing
39
40 lintCmmTop (CmmProc _ lbl _ blocks)
41 = addLintInfo (text "in proc " <> pprCLabel lbl) $
42 mapM_ lintCmmBlock blocks
43 lintCmmTop _other
44 = return ()
45
46 lintCmmBlock (BasicBlock id stmts)
47 = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
48 mapM_ lintCmmStmt stmts
49
50 -- -----------------------------------------------------------------------------
51 -- lintCmmExpr
52
53 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
54 -- byte/word mismatches.
55
56 lintCmmExpr :: CmmExpr -> CmmLint MachRep
57 lintCmmExpr (CmmLoad expr rep) = do
58 lintCmmExpr expr
59 when (machRepByteWidth rep >= wORD_SIZE) $
60 cmmCheckWordAddress expr
61 return rep
62 lintCmmExpr expr@(CmmMachOp op args) = do
63 mapM_ lintCmmExpr args
64 if map cmmExprRep args == machOpArgReps op
65 then cmmCheckMachOp op args
66 else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
67 lintCmmExpr (CmmRegOff reg offset)
68 = lintCmmExpr (CmmMachOp (MO_Add rep)
69 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
70 where rep = cmmRegRep reg
71 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
72 | isFloatingRep rep
73 = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
74 lintCmmExpr expr =
75 return (cmmExprRep expr)
76
77 -- Check for some common byte/word mismatches (eg. Sp + 1)
78 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
79 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
80 = cmmLintDubiousWordOffset (CmmMachOp op args)
81 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
82 = cmmCheckMachOp op [reg, lit]
83 cmmCheckMachOp op@(MO_U_Conv from to) args
84 | isFloatingRep from || isFloatingRep to
85 = cmmLintErr (text "unsigned conversion from/to floating rep: "
86 <> ppr (CmmMachOp op args))
87 cmmCheckMachOp op args
88 = return (resultRepOfMachOp op)
89
90 isWordOffsetReg (CmmGlobal Sp) = True
91 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
92 --isWordOffsetReg (CmmGlobal Hp) = True
93 isWordOffsetReg _ = False
94
95 isOffsetOp (MO_Add _) = True
96 isOffsetOp (MO_Sub _) = True
97 isOffsetOp _ = False
98
99 -- This expression should be an address from which a word can be loaded:
100 -- check for funny-looking sub-word offsets.
101 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
102 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
103 = cmmLintDubiousWordOffset e
104 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
105 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
106 = cmmLintDubiousWordOffset e
107 cmmCheckWordAddress _
108 = return ()
109
110 -- No warnings for unaligned arithmetic with the node register,
111 -- which is used to extract fields from tagged constructor closures.
112 notNodeReg (CmmReg reg) | reg == nodeReg = False
113 notNodeReg _ = True
114
115 lintCmmStmt :: CmmStmt -> CmmLint ()
116 lintCmmStmt stmt@(CmmAssign reg expr) = do
117 erep <- lintCmmExpr expr
118 if (erep == cmmRegRep reg)
119 then return ()
120 else cmmLintAssignErr stmt
121 lintCmmStmt (CmmStore l r) = do
122 lintCmmExpr l
123 lintCmmExpr r
124 return ()
125 lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args
126 lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
127 lintCmmStmt (CmmSwitch e _branches) = do
128 erep <- lintCmmExpr e
129 if (erep == wordRep)
130 then return ()
131 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
132 lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
133 lintCmmStmt _other = return ()
134
135 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
136 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
137 (ppr expr))
138
139 -- -----------------------------------------------------------------------------
140 -- CmmLint monad
141
142 -- just a basic error monad:
143
144 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
145
146 instance Monad CmmLint where
147 CmmLint m >>= k = CmmLint $ case m of
148 Left e -> Left e
149 Right a -> unCL (k a)
150 return a = CmmLint (Right a)
151
152 cmmLintErr :: SDoc -> CmmLint a
153 cmmLintErr msg = CmmLint (Left msg)
154
155 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
156 addLintInfo info thing = CmmLint $
157 case unCL thing of
158 Left err -> Left (hang info 2 err)
159 Right a -> Right a
160
161 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
162 cmmLintMachOpErr expr argsRep opExpectsRep
163 = cmmLintErr (text "in MachOp application: " $$
164 nest 2 (pprExpr expr) $$
165 (text "op is expecting: " <+> ppr opExpectsRep) $$
166 (text "arguments provide: " <+> ppr argsRep))
167
168 cmmLintAssignErr :: CmmStmt -> CmmLint a
169 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
170 nest 2 (pprStmt stmt))
171
172 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
173 cmmLintDubiousWordOffset expr
174 = cmmLintErr (text "offset is not a multiple of words: " $$
175 nest 2 (pprExpr expr))