compiler/cmm/CmmLint.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 -----------------------------------------------------------------------------
   9 --
  10 -- (c) The University of Glasgow 2004-2006
  11 --
  12 -- CmmLint: checking the correctness of Cmm statements and expressions
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module CmmLint (
  17   cmmLint, cmmLintTop
  18   ) where
  19
  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 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  op args@[CmmReg reg, CmmLit (CmmInt i _)]
  89   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  90   = cmmLintDubiousWordOffset (CmmMachOp op args)
  91 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)]
  92   = cmmCheckMachOp op [reg, lit]
  93 cmmCheckMachOp op@(MO_U_Conv from to) args
  94   | isFloatingRep from || isFloatingRep to
  95   = cmmLintErr (text "unsigned conversion from/to floating rep: "
  96                 <> ppr (CmmMachOp op args))
  97 cmmCheckMachOp op _args
  98   = return (resultRepOfMachOp op)
  99
 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 (MO_Add _) = True
 106 isOffsetOp (MO_Sub _) = True
 107 isOffsetOp _ = False
 108
 109 -- This expression should be an address from which a word can be loaded:
 110 -- check for funny-looking sub-word offsets.
 111 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 112   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 113   = cmmLintDubiousWordOffset e
 114 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 115   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 116   = cmmLintDubiousWordOffset e
 117 cmmCheckWordAddress _
 118   = return ()
 119
 120 -- No warnings for unaligned arithmetic with the node register,
 121 -- which is used to extract fields from tagged constructor closures.
 122 notNodeReg (CmmReg reg) | reg == nodeReg = False
 123 notNodeReg _                             = True
 124
 125 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
 126 lintCmmStmt labels = lint
 127     where lint (CmmNop) = return ()
 128           lint (CmmComment {}) = return ()
 129           lint stmt@(CmmAssign reg expr) = do
 130             erep <- lintCmmExpr expr
 131             if (erep == cmmRegRep reg)
 132                 then return ()
 133                 else cmmLintAssignErr stmt
 134           lint (CmmStore l r) = do
 135             lintCmmExpr l
 136             lintCmmExpr r
 137             return ()
 138           lint (CmmCall target _res args _ _) =
 139               lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
 140           lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
 141           lint (CmmSwitch e branches) = do
 142             mapM_ checkTarget $ catMaybes branches
 143             erep <- lintCmmExpr e
 144             if (erep == wordRep)
 145               then return ()
 146               else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
 147           lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
 148           lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) ress
 149           lint (CmmBranch id)    = checkTarget id
 150           checkTarget id = if elemBlockSet id labels then return ()
 151                            else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 152
 153 lintTarget :: CmmCallTarget -> CmmLint ()
 154 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
 155 lintTarget (CmmPrim {})    = return ()
 156
 157
 158 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 159 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 160                                     (ppr expr))
 161
 162 -- -----------------------------------------------------------------------------
 163 -- CmmLint monad
 164
 165 -- just a basic error monad:
 166
 167 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 168
 169 instance Monad CmmLint where
 170   CmmLint m >>= k = CmmLint $ case m of
 171                                 Left e -> Left e
 172                                 Right a -> unCL (k a)
 173   return a = CmmLint (Right a)
 174
 175 cmmLintErr :: SDoc -> CmmLint a
 176 cmmLintErr msg = CmmLint (Left msg)
 177
 178 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 179 addLintInfo info thing = CmmLint $
 180    case unCL thing of
 181         Left err -> Left (hang info 2 err)
 182         Right a  -> Right a
 183
 184 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
 185 cmmLintMachOpErr expr argsRep opExpectsRep
 186      = cmmLintErr (text "in MachOp application: " $$
 187                                         nest 2 (pprExpr expr) $$
 188                                         (text "op is expecting: " <+> ppr opExpectsRep) $$
 189                                         (text "arguments provide: " <+> ppr argsRep))
 190
 191 cmmLintAssignErr :: CmmStmt -> CmmLint a
 192 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
 193                                         nest 2 (pprStmt stmt))
 194
 195 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 196 cmmLintDubiousWordOffset expr
 197    = cmmLintErr (text "offset is not a multiple of words: " $$
 198                         nest 2 (pprExpr expr))