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