Move code
[ghc-hetmet.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))