CmmLint.hs 7.95 KB
Newer Older
1
2
-----------------------------------------------------------------------------
--
Simon Marlow's avatar
Simon Marlow committed
3
-- (c) The University of Glasgow 2004-2006
4
--
Simon Marlow's avatar
Simon Marlow committed
5
-- CmmLint: checking the correctness of Cmm statements and expressions
6
7
8
--
-----------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
9
10
11
12
13
14
15
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

16
17
18
19
module CmmLint (
  cmmLint, cmmLintTop
  ) where

20
import BlockId
21
import OldCmm
Simon Marlow's avatar
Simon Marlow committed
22
import CLabel
23
import Outputable
24
import OldPprCmm()
Simon Marlow's avatar
Simon Marlow committed
25
import Constants
26
import FastString
27
import Platform
28

Ian Lynagh's avatar
Ian Lynagh committed
29
import Data.Maybe
30
31
32
33

-- -----------------------------------------------------------------------------
-- Exported entry points:

34
cmmLint :: (PlatformOutputable d, PlatformOutputable h)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
35
        => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
36
cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
37

38
cmmLintTop :: (PlatformOutputable d, PlatformOutputable h)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
39
           => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
40
cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
41

42
43
44
runCmmLint :: PlatformOutputable a
           => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint platform l p =
45
   case unCL (l p) of
46
47
48
49
50
   Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
                           nest 2 err,
                           ptext $ sLit ("Program was:"),
                           nest 2 (pprPlatform platform p)])
   Right _  -> Nothing
51

52
53
54
lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
  = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
55
        let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
56
	in  mapM_ (lintCmmBlock platform labels) blocks
57

58
lintCmmDecl _ (CmmData {})
59
60
  = return ()

61
62
lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock platform labels (BasicBlock id stmts)
63
  = addLintInfo (text "in basic block " <> ppr id) $
64
	mapM_ (lintCmmStmt platform labels) stmts
65
66
67
68
69
70
71

-- -----------------------------------------------------------------------------
-- lintCmmExpr

-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.

72
73
74
lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
lintCmmExpr platform (CmmLoad expr rep) = do
  _ <- lintCmmExpr platform expr
75
76
77
78
  -- Disabled, if we have the inlining phase before the lint phase,
  -- we can have funny offsets due to pointer tagging. -- EZY
  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
  --   cmmCheckWordAddress expr
79
  return rep
80
81
lintCmmExpr platform expr@(CmmMachOp op args) = do
  tys <- mapM (lintCmmExpr platform) args
82
83
  if map (typeWidth . cmmExprType) args == machOpArgReps op
  	then cmmCheckMachOp op args tys
84
85
86
	else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op)
lintCmmExpr platform (CmmRegOff reg offset)
  = lintCmmExpr platform (CmmMachOp (MO_Add rep)
87
		[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
88
  where rep = typeWidth (cmmRegType reg)
89
lintCmmExpr _ expr =
90
  return (cmmExprType expr)
91
92

-- Check for some common byte/word mismatches (eg. Sp + 1)
93
94
95
96
97
cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
  = cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
  = return (machOpResultType op tys)
98

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
99
isOffsetOp :: MachOp -> Bool
100
101
102
103
104
105
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
isOffsetOp _ = False

-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
106
107
_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint ()
_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
Simon Marlow's avatar
Simon Marlow committed
108
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
109
110
  = cmmLintDubiousWordOffset platform e
_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
Simon Marlow's avatar
Simon Marlow committed
111
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
112
113
  = cmmLintDubiousWordOffset platform e
_cmmCheckWordAddress _ _
114
115
  = return ()

Simon Marlow's avatar
Simon Marlow committed
116
117
-- No warnings for unaligned arithmetic with the node register,
-- which is used to extract fields from tagged constructor closures.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
118
notNodeReg :: CmmExpr -> Bool
Simon Marlow's avatar
Simon Marlow committed
119
120
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _                             = True
121

122
123
lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
lintCmmStmt platform labels = lint
124
125
126
    where lint (CmmNop) = return ()
          lint (CmmComment {}) = return ()
          lint stmt@(CmmAssign reg expr) = do
127
            erep <- lintCmmExpr platform expr
128
129
	    let reg_ty = cmmRegType reg
            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
130
                then return ()
131
                else cmmLintAssignErr platform stmt erep reg_ty
132
          lint (CmmStore l r) = do
133
134
            _ <- lintCmmExpr platform l
            _ <- lintCmmExpr platform r
135
            return ()
136
          lint (CmmCall target _res args _) =
137
138
              lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
139
140
          lint (CmmSwitch e branches) = do
            mapM_ checkTarget $ catMaybes branches
141
            erep <- lintCmmExpr platform e
142
            if (erep `cmmEqType_ignoring_ptrhood` bWord)
143
              then return ()
144
              else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
145
                               text " :: " <> ppr erep)
146
          lint (CmmJump e) = lintCmmExpr platform e >> return ()
147
          lint (CmmReturn ress) = mapM_ (lintCmmExpr platform . hintlessCmm) ress
148
          lint (CmmBranch id)    = checkTarget id
149
          checkTarget id = if setMember id labels then return ()
150
151
                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)

152
153
154
lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
lintTarget _        (CmmPrim {})    = return ()
155

156

157
158
159
160
161
162
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond platform expr
    = cmmLintErr (hang (text "expression is not a conditional:") 2
                       (pprPlatform platform expr))
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
-- -----------------------------------------------------------------------------
-- CmmLint monad

-- just a basic error monad:

newtype CmmLint a = CmmLint { unCL :: Either SDoc a }

instance Monad CmmLint where
  CmmLint m >>= k = CmmLint $ case m of 
				Left e -> Left e
				Right a -> unCL (k a)
  return a = CmmLint (Right a)

cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (Left msg)

addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo info thing = CmmLint $ 
   case unCL thing of
	Left err -> Left (hang info 2 err)
	Right a  -> Right a

186
187
cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr platform expr argsRep opExpectsRep
188
     = cmmLintErr (text "in MachOp application: " $$ 
189
					nest 2 (pprPlatform platform expr) $$
190
191
				        (text "op is expecting: " <+> ppr opExpectsRep) $$
					(text "arguments provide: " <+> ppr argsRep))
192

193
194
cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr platform stmt e_ty r_ty
195
  = cmmLintErr (text "in assignment: " $$ 
196
		nest 2 (vcat [pprPlatform platform stmt, 
197
198
199
200
			      text "Reg ty:" <+> ppr r_ty,
			      text "Rhs ty:" <+> ppr e_ty]))
			 
					
201

202
203
cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a
cmmLintDubiousWordOffset platform expr
204
   = cmmLintErr (text "offset is not a multiple of words: " $$
205
			nest 2 (pprPlatform platform expr))