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))