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 Cmm
  20 import CLabel
  21 import MachOp
  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 :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
  35 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
  36
  37 cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
  38 cmmLintTop top = runCmmLint $ lintCmmTop top
  39
  40 runCmmLint :: CmmLint a -> Maybe SDoc
  41 runCmmLint l =
  42    case unCL l of
  43         Left err -> Just (ptext (sLit "Cmm lint error:") $$ nest 2 err)
  44         Right _  -> Nothing
  45
  46 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
  47 lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
  48   = addLintInfo (text "in proc " <> pprCLabel lbl) $
  49         let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
  50         in  mapM_ (lintCmmBlock labels) blocks
  51
  52 lintCmmTop (CmmData {})
  53   = return ()
  54
  55 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
  56 lintCmmBlock labels (BasicBlock id stmts)
  57   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
  58         mapM_ (lintCmmStmt labels) stmts
  59
  60 -- -----------------------------------------------------------------------------
  61 -- lintCmmExpr
  62
  63 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
  64 -- byte/word mismatches.
  65
  66 lintCmmExpr :: CmmExpr -> CmmLint MachRep
  67 lintCmmExpr (CmmLoad expr rep) = do
  68   lintCmmExpr expr
  69   when (machRepByteWidth rep >= wORD_SIZE) $
  70      cmmCheckWordAddress expr
  71   return rep
  72 lintCmmExpr expr@(CmmMachOp op args) = do
  73   mapM_ lintCmmExpr args
  74   if map cmmExprRep args == machOpArgReps op
  75         then cmmCheckMachOp op args
  76         else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
  77 lintCmmExpr (CmmRegOff reg offset)
  78   = lintCmmExpr (CmmMachOp (MO_Add rep)
  79                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
  80   where rep = cmmRegRep reg
  81 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
  82   | isFloatingRep rep
  83   = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
  84 lintCmmExpr expr =
  85   return (cmmExprRep expr)
  86
  87 -- Check for some common byte/word mismatches (eg. Sp + 1)
  88 cmmCheckMachOp   :: MachOp -> [CmmExpr] -> CmmLint MachRep
  89 cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
  90   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  91   = cmmLintDubiousWordOffset (CmmMachOp op args)
  92 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)]
  93   = cmmCheckMachOp op [reg, lit]
  94 cmmCheckMachOp op@(MO_U_Conv from to) args
  95   | isFloatingRep from || isFloatingRep to
  96   = cmmLintErr (text "unsigned conversion from/to floating rep: "
  97                 <> ppr (CmmMachOp op args))
  98 cmmCheckMachOp op _args
  99   = return (resultRepOfMachOp op)
 100
 101 isWordOffsetReg  :: CmmReg -> Bool
 102 isWordOffsetReg (CmmGlobal Sp) = True
 103 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
 104 --isWordOffsetReg (CmmGlobal Hp) = True
 105 isWordOffsetReg _ = False
 106
 107 isOffsetOp :: MachOp -> Bool
 108 isOffsetOp (MO_Add _) = True
 109 isOffsetOp (MO_Sub _) = True
 110 isOffsetOp _ = False
 111
 112 -- This expression should be an address from which a word can be loaded:
 113 -- check for funny-looking sub-word offsets.
 114 cmmCheckWordAddress :: CmmExpr -> CmmLint ()
 115 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 116   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 117   = cmmLintDubiousWordOffset e
 118 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 119   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 120   = cmmLintDubiousWordOffset e
 121 cmmCheckWordAddress _
 122   = return ()
 123
 124 -- No warnings for unaligned arithmetic with the node register,
 125 -- which is used to extract fields from tagged constructor closures.
 126 notNodeReg :: CmmExpr -> Bool
 127 notNodeReg (CmmReg reg) | reg == nodeReg = False
 128 notNodeReg _                             = True
 129
 130 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
 131 lintCmmStmt labels = lint
 132     where lint (CmmNop) = return ()
 133           lint (CmmComment {}) = return ()
 134           lint stmt@(CmmAssign reg expr) = do
 135             erep <- lintCmmExpr expr
 136             if (erep == cmmRegRep reg)
 137                 then return ()
 138                 else cmmLintAssignErr stmt
 139           lint (CmmStore l r) = do
 140             lintCmmExpr l
 141             lintCmmExpr r
 142             return ()
 143           lint (CmmCall target _res args _ _) =
 144               lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
 145           lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
 146           lint (CmmSwitch e branches) = do
 147             mapM_ checkTarget $ catMaybes branches
 148             erep <- lintCmmExpr e
 149             if (erep == wordRep)
 150               then return ()
 151               else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
 152           lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
 153           lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) 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 -> [MachRep] -> [MachRep] -> 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 -> CmmLint a
 198 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
 199                                         nest 2 (pprStmt stmt))
 200
 201 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 202 cmmLintDubiousWordOffset expr
 203    = cmmLintErr (text "offset is not a multiple of words: " $$
 204                         nest 2 (pprExpr expr))