CmmLint.hs 8.11 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
              do lintTarget platform labels target
                 mapM_ (lintCmmExpr platform . hintlessCmm) args
139
          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
140 141
          lint (CmmSwitch e branches) = do
            mapM_ checkTarget $ catMaybes branches
142
            erep <- lintCmmExpr platform e
143
            if (erep `cmmEqType_ignoring_ptrhood` bWord)
144
              then return ()
145
              else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
146
                               text " :: " <> ppr erep)
147
          lint (CmmJump e _) = lintCmmExpr platform e >> return ()
dterei's avatar
dterei committed
148 149
          lint (CmmReturn) = return ()
          lint (CmmBranch id) = checkTarget id
150
          checkTarget id = if setMember id labels then return ()
151 152
                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)

153 154 155 156 157 158
lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint ()
lintTarget platform _      (CmmCallee e _) = do _ <- lintCmmExpr platform e
                                                return ()
lintTarget _        _      (CmmPrim _ Nothing) = return ()
lintTarget platform labels (CmmPrim _ (Just stmts))
    = mapM_ (lintCmmStmt platform labels) stmts
159

160

161 162 163 164 165 166
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))
167

168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
-- -----------------------------------------------------------------------------
-- 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

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

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

206 207
cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a
cmmLintDubiousWordOffset platform expr
208
   = cmmLintErr (text "offset is not a multiple of words: " $$
209
			nest 2 (pprPlatform platform expr))