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