CmmLint.hs 7.33 KB
Newer Older
1 2 3
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
4
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
5 6
-- for details

7 8
-----------------------------------------------------------------------------
--
Simon Marlow's avatar
Simon Marlow committed
9
-- (c) The University of Glasgow 2004-2006
10
--
Simon Marlow's avatar
Simon Marlow committed
11
-- CmmLint: checking the correctness of Cmm statements and expressions
12 13 14 15 16 17 18
--
-----------------------------------------------------------------------------

module CmmLint (
  cmmLint, cmmLintTop
  ) where

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

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

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

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

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

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

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
57
lintCmmDecl (CmmData {})
58 59
  = return ()

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
60
lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
61
lintCmmBlock labels (BasicBlock id stmts)
62
  = addLintInfo (text "in basic block " <> ppr id) $
63
	mapM_ (lintCmmStmt labels) stmts
64 65 66 67 68 69 70

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

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

71
lintCmmExpr :: CmmExpr -> CmmLint CmmType
72
lintCmmExpr (CmmLoad expr rep) = do
73
  _ <- lintCmmExpr expr
74 75 76 77
  -- 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
78 79
  return rep
lintCmmExpr expr@(CmmMachOp op args) = do
80 81 82 83
  tys <- mapM lintCmmExpr args
  if map (typeWidth . cmmExprType) args == machOpArgReps op
  	then cmmCheckMachOp op args tys
	else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
84
lintCmmExpr (CmmRegOff reg offset)
85
  = lintCmmExpr (CmmMachOp (MO_Add rep)
86
		[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
87
  where rep = typeWidth (cmmRegType reg)
88
lintCmmExpr expr = 
89
  return (cmmExprType expr)
90 91

-- Check for some common byte/word mismatches (eg. Sp + 1)
92 93 94 95 96
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)
97

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
98
isOffsetOp :: MachOp -> Bool
99 100 101 102 103 104
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.
105 106
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
Simon Marlow's avatar
Simon Marlow committed
107
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
108
  = cmmLintDubiousWordOffset e
109
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
Simon Marlow's avatar
Simon Marlow committed
110
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
111
  = cmmLintDubiousWordOffset e
112
_cmmCheckWordAddress _
113 114
  = return ()

Simon Marlow's avatar
Simon Marlow committed
115 116
-- 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
117
notNodeReg :: CmmExpr -> Bool
Simon Marlow's avatar
Simon Marlow committed
118 119
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _                             = True
120

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

lintTarget :: CmmCallTarget -> CmmLint ()
lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
lintTarget (CmmPrim {})    = return ()

155

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
156
checkCond :: CmmExpr -> CmmLint ()
157
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
158
checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
159 160 161
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
				    (ppr expr))

162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
-- -----------------------------------------------------------------------------
-- 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

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

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

cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
   = cmmLintErr (text "offset is not a multiple of words: " $$
203
			nest 2 (ppr expr))