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