compiler/cmm/CmmLint.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2004-2006
   4 --
   5 -- CmmLint: checking the correctness of Cmm statements and expressions
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CmmLint (
  10   cmmLint, cmmLintTop
  11   ) where
  12
  13 #include "HsVersions.h"
  14
  15 import Cmm
  16 import CLabel
  17 import MachOp
  18 import Outputable
  19 import PprCmm
  20 import Unique
  21 import Constants
  22
  23 import Control.Monad
  24
  25 -- -----------------------------------------------------------------------------
  26 -- Exported entry points:
  27
  28 cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
  29 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
  30
  31 cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
  32 cmmLintTop top = runCmmLint $ lintCmmTop top
  33
  34 runCmmLint :: CmmLint a -> Maybe SDoc
  35 runCmmLint l =
  36    case unCL l of
  37         Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
  38         Right _  -> Nothing
  39
  40 lintCmmTop (CmmProc _ lbl _ blocks)
  41   = addLintInfo (text "in proc " <> pprCLabel lbl) $
  42         mapM_ lintCmmBlock blocks
  43 lintCmmTop _other
  44   = return ()
  45
  46 lintCmmBlock (BasicBlock id stmts)
  47   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
  48         mapM_ lintCmmStmt stmts
  49
  50 -- -----------------------------------------------------------------------------
  51 -- lintCmmExpr
  52
  53 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
  54 -- byte/word mismatches.
  55
  56 lintCmmExpr :: CmmExpr -> CmmLint MachRep
  57 lintCmmExpr (CmmLoad expr rep) = do
  58   lintCmmExpr expr
  59   when (machRepByteWidth rep >= wORD_SIZE) $
  60      cmmCheckWordAddress expr
  61   return rep
  62 lintCmmExpr expr@(CmmMachOp op args) = do
  63   mapM_ lintCmmExpr args
  64   if map cmmExprRep args == machOpArgReps op
  65         then cmmCheckMachOp op args
  66         else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
  67 lintCmmExpr (CmmRegOff reg offset)
  68   = lintCmmExpr (CmmMachOp (MO_Add rep)
  69                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
  70   where rep = cmmRegRep reg
  71 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
  72   | isFloatingRep rep
  73   = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
  74 lintCmmExpr expr =
  75   return (cmmExprRep expr)
  76
  77 -- Check for some common byte/word mismatches (eg. Sp + 1)
  78 cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
  79   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  80   = cmmLintDubiousWordOffset (CmmMachOp op args)
  81 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
  82   = cmmCheckMachOp op [reg, lit]
  83 cmmCheckMachOp op@(MO_U_Conv from to) args
  84   | isFloatingRep from || isFloatingRep to
  85   = cmmLintErr (text "unsigned conversion from/to floating rep: "
  86                 <> ppr (CmmMachOp op args))
  87 cmmCheckMachOp op args
  88   = return (resultRepOfMachOp op)
  89
  90 isWordOffsetReg (CmmGlobal Sp) = True
  91 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
  92 --isWordOffsetReg (CmmGlobal Hp) = True
  93 isWordOffsetReg _ = False
  94
  95 isOffsetOp (MO_Add _) = True
  96 isOffsetOp (MO_Sub _) = True
  97 isOffsetOp _ = False
  98
  99 -- This expression should be an address from which a word can be loaded:
 100 -- check for funny-looking sub-word offsets.
 101 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 102   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 103   = cmmLintDubiousWordOffset e
 104 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 105   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 106   = cmmLintDubiousWordOffset e
 107 cmmCheckWordAddress _
 108   = return ()
 109
 110 -- No warnings for unaligned arithmetic with the node register,
 111 -- which is used to extract fields from tagged constructor closures.
 112 notNodeReg (CmmReg reg) | reg == nodeReg = False
 113 notNodeReg _                             = True
 114
 115 lintCmmStmt :: CmmStmt -> CmmLint ()
 116 lintCmmStmt stmt@(CmmAssign reg expr) = do
 117   erep <- lintCmmExpr expr
 118   if (erep == cmmRegRep reg)
 119         then return ()
 120         else cmmLintAssignErr stmt
 121 lintCmmStmt (CmmStore l r) = do
 122   lintCmmExpr l
 123   lintCmmExpr r
 124   return ()
 125 lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args
 126 lintCmmStmt (CmmCondBranch e _id)   = lintCmmExpr e >> checkCond e >> return ()
 127 lintCmmStmt (CmmSwitch e _branches) = do
 128   erep <- lintCmmExpr e
 129   if (erep == wordRep)
 130     then return ()
 131     else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
 132 lintCmmStmt (CmmJump e _args)       = lintCmmExpr e >> return ()
 133 lintCmmStmt _other                  = return ()
 134
 135 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 136 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 137                                     (ppr expr))
 138
 139 -- -----------------------------------------------------------------------------
 140 -- CmmLint monad
 141
 142 -- just a basic error monad:
 143
 144 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 145
 146 instance Monad CmmLint where
 147   CmmLint m >>= k = CmmLint $ case m of
 148                                 Left e -> Left e
 149                                 Right a -> unCL (k a)
 150   return a = CmmLint (Right a)
 151
 152 cmmLintErr :: SDoc -> CmmLint a
 153 cmmLintErr msg = CmmLint (Left msg)
 154
 155 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 156 addLintInfo info thing = CmmLint $
 157    case unCL thing of
 158         Left err -> Left (hang info 2 err)
 159         Right a  -> Right a
 160
 161 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
 162 cmmLintMachOpErr expr argsRep opExpectsRep
 163      = cmmLintErr (text "in MachOp application: " $$
 164                                         nest 2 (pprExpr expr) $$
 165                                         (text "op is expecting: " <+> ppr opExpectsRep) $$
 166                                         (text "arguments provide: " <+> ppr argsRep))
 167
 168 cmmLintAssignErr :: CmmStmt -> CmmLint a
 169 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
 170                                         nest 2 (pprStmt stmt))
 171
 172 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 173 cmmLintDubiousWordOffset expr
 174    = cmmLintErr (text "offset is not a multiple of words: " $$
 175                         nest 2 (pprExpr expr))