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