compiler/cmm/CmmLint.hs

   1 -- The above warning supression flag is a temporary kludge.
   2 -- While working on this module you are encouraged to remove it and fix
   3 -- any warnings in the module. See
   4 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   5 -- for details
   6
   7 -----------------------------------------------------------------------------
   8 --
   9 -- (c) The University of Glasgow 2004-2006
  10 --
  11 -- CmmLint: checking the correctness of Cmm statements and expressions
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module CmmLint (
  16   cmmLint, cmmLintTop
  17   ) where
  18
  19 import BlockId
  20 import Cmm
  21 import CLabel
  22 import Maybe
  23 import Outputable
  24 import PprCmm
  25 import Unique
  26 import Constants
  27 import FastString
  28
  29 import Control.Monad
  30
  31 -- -----------------------------------------------------------------------------
  32 -- Exported entry points:
  33
  34 cmmLint :: (Outputable d, Outputable h)
  35         => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
  36 cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
  37
  38 cmmLintTop :: (Outputable d, Outputable h)
  39            => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
  40 cmmLintTop top = runCmmLint lintCmmTop top
  41
  42 runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
  43 runCmmLint l p =
  44    case unCL (l p) of
  45         Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
  46                                 nest 2 err,
  47                                 ptext $ sLit ("Program was:"),
  48                                 nest 2 (ppr p)])
  49         Right _  -> Nothing
  50
  51 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
  52 lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
  53   = addLintInfo (text "in proc " <> pprCLabel lbl) $
  54         let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
  55         in  mapM_ (lintCmmBlock labels) blocks
  56
  57 lintCmmTop (CmmData {})
  58   = return ()
  59
  60 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
  61 lintCmmBlock labels (BasicBlock id stmts)
  62   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
  63         mapM_ (lintCmmStmt labels) stmts
  64
  65 -- -----------------------------------------------------------------------------
  66 -- lintCmmExpr
  67
  68 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
  69 -- byte/word mismatches.
  70
  71 lintCmmExpr :: CmmExpr -> CmmLint CmmType
  72 lintCmmExpr (CmmLoad expr rep) = do
  73   lintCmmExpr expr
  74   when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
  75      cmmCheckWordAddress expr
  76   return rep
  77 lintCmmExpr expr@(CmmMachOp op args) = do
  78   tys <- mapM lintCmmExpr args
  79   if map (typeWidth . cmmExprType) args == machOpArgReps op
  80         then cmmCheckMachOp op args tys
  81         else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
  82 lintCmmExpr (CmmRegOff reg offset)
  83   = lintCmmExpr (CmmMachOp (MO_Add rep)
  84                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
  85   where rep = typeWidth (cmmRegType reg)
  86 lintCmmExpr expr =
  87   return (cmmExprType expr)
  88
  89 -- Check for some common byte/word mismatches (eg. Sp + 1)
  90 cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
  91 cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)] _
  92   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  93   = cmmLintDubiousWordOffset (CmmMachOp op args)
  94 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
  95   = cmmCheckMachOp op [reg, lit] tys
  96 cmmCheckMachOp op _ tys
  97   = return (machOpResultType op tys)
  98
  99 isWordOffsetReg  :: CmmReg -> Bool
 100 isWordOffsetReg (CmmGlobal Sp) = True
 101 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
 102 --isWordOffsetReg (CmmGlobal Hp) = True
 103 isWordOffsetReg _ = False
 104
 105 isOffsetOp :: MachOp -> Bool
 106 isOffsetOp (MO_Add _) = True
 107 isOffsetOp (MO_Sub _) = True
 108 isOffsetOp _ = False
 109
 110 -- This expression should be an address from which a word can be loaded:
 111 -- check for funny-looking sub-word offsets.
 112 cmmCheckWordAddress :: CmmExpr -> CmmLint ()
 113 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 114   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 115   = cmmLintDubiousWordOffset e
 116 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 117   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 118   = cmmLintDubiousWordOffset e
 119 cmmCheckWordAddress _
 120   = return ()
 121
 122 -- No warnings for unaligned arithmetic with the node register,
 123 -- which is used to extract fields from tagged constructor closures.
 124 notNodeReg :: CmmExpr -> Bool
 125 notNodeReg (CmmReg reg) | reg == nodeReg = False
 126 notNodeReg _                             = True
 127
 128 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
 129 lintCmmStmt labels = lint
 130     where lint (CmmNop) = return ()
 131           lint (CmmComment {}) = return ()
 132           lint stmt@(CmmAssign reg expr) = do
 133             erep <- lintCmmExpr expr
 134             let reg_ty = cmmRegType reg
 135             if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
 136                 then return ()
 137                 else cmmLintAssignErr stmt erep reg_ty
 138           lint (CmmStore l r) = do
 139             lintCmmExpr l
 140             lintCmmExpr r
 141             return ()
 142           lint (CmmCall target _res args _ _) =
 143               lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
 144           lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
 145           lint (CmmSwitch e branches) = do
 146             mapM_ checkTarget $ catMaybes branches
 147             erep <- lintCmmExpr e
 148             if (erep `cmmEqType_ignoring_ptrhood` bWord)
 149               then return ()
 150               else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
 151                                text " :: " <> ppr erep)
 152           lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
 153           lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
 154           lint (CmmBranch id)    = checkTarget id
 155           checkTarget id = if elemBlockSet id labels then return ()
 156                            else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 157
 158 lintTarget :: CmmCallTarget -> CmmLint ()
 159 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
 160 lintTarget (CmmPrim {})    = return ()
 161
 162
 163 checkCond :: CmmExpr -> CmmLint ()
 164 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 165 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 166                                     (ppr expr))
 167
 168 -- -----------------------------------------------------------------------------
 169 -- CmmLint monad
 170
 171 -- just a basic error monad:
 172
 173 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 174
 175 instance Monad CmmLint where
 176   CmmLint m >>= k = CmmLint $ case m of
 177                                 Left e -> Left e
 178                                 Right a -> unCL (k a)
 179   return a = CmmLint (Right a)
 180
 181 cmmLintErr :: SDoc -> CmmLint a
 182 cmmLintErr msg = CmmLint (Left msg)
 183
 184 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 185 addLintInfo info thing = CmmLint $
 186    case unCL thing of
 187         Left err -> Left (hang info 2 err)
 188         Right a  -> Right a
 189
 190 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
 191 cmmLintMachOpErr expr argsRep opExpectsRep
 192      = cmmLintErr (text "in MachOp application: " $$
 193                                         nest 2 (pprExpr expr) $$
 194                                         (text "op is expecting: " <+> ppr opExpectsRep) $$
 195                                         (text "arguments provide: " <+> ppr argsRep))
 196
 197 cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
 198 cmmLintAssignErr stmt e_ty r_ty
 199   = cmmLintErr (text "in assignment: " $$
 200                 nest 2 (vcat [pprStmt stmt,
 201                               text "Reg ty:" <+> ppr r_ty,
 202                               text "Rhs ty:" <+> ppr e_ty]))
 203
 204
 205
 206 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 207 cmmLintDubiousWordOffset expr
 208    = cmmLintErr (text "offset is not a multiple of words: " $$
 209                         nest 2 (pprExpr expr))