compiler/cmm/CmmLint.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- CmmLint: checking the correctness of Cmm statements and expressions
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CmmLint (
  10   cmmLint, cmmLintTop
  11   ) where
  12
  13 #include "HsVersions.h"
  14
  15 import Cmm
  16 import CLabel           ( pprCLabel )
  17 import MachOp
  18 import Outputable
  19 import PprCmm
  20 import Unique           ( getUnique )
  21 import Constants        ( wORD_SIZE )
  22
  23 import Monad            ( when )
  24
  25 -- -----------------------------------------------------------------------------
  26 -- Exported entry points:
  27
  28 cmmLint :: Cmm -> Maybe SDoc
  29 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
  30
  31 cmmLintTop :: CmmTop -> 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 _info lbl _args 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
  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 isWordOffsetReg (CmmGlobal Hp) = True
  92 isWordOffsetReg _ = False
  93
  94 isOffsetOp (MO_Add _) = True
  95 isOffsetOp (MO_Sub _) = True
  96 isOffsetOp _ = False
  97
  98 -- This expression should be an address from which a word can be loaded:
  99 -- check for funny-looking sub-word offsets.
 100 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 101   | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
 102   = cmmLintDubiousWordOffset e
 103 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 104   | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
 105   = cmmLintDubiousWordOffset e
 106 cmmCheckWordAddress _
 107   = return ()
 108
 109
 110 lintCmmStmt :: CmmStmt -> CmmLint ()
 111 lintCmmStmt stmt@(CmmAssign reg expr) = do
 112   erep <- lintCmmExpr expr
 113   if (erep == cmmRegRep reg)
 114         then return ()
 115         else cmmLintAssignErr stmt
 116 lintCmmStmt (CmmStore l r) = do
 117   lintCmmExpr l
 118   lintCmmExpr r
 119   return ()
 120 lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
 121 lintCmmStmt (CmmCondBranch e _id)   = lintCmmExpr e >> checkCond e >> return ()
 122 lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
 123 lintCmmStmt (CmmJump e _args)       = lintCmmExpr e >> return ()
 124 lintCmmStmt _other                  = return ()
 125
 126 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 127 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 128                                     (ppr expr))
 129
 130 -- -----------------------------------------------------------------------------
 131 -- CmmLint monad
 132
 133 -- just a basic error monad:
 134
 135 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 136
 137 instance Monad CmmLint where
 138   CmmLint m >>= k = CmmLint $ case m of
 139                                 Left e -> Left e
 140                                 Right a -> unCL (k a)
 141   return a = CmmLint (Right a)
 142
 143 cmmLintErr :: SDoc -> CmmLint a
 144 cmmLintErr msg = CmmLint (Left msg)
 145
 146 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 147 addLintInfo info thing = CmmLint $
 148    case unCL thing of
 149         Left err -> Left (hang info 2 err)
 150         Right a  -> Right a
 151
 152 cmmLintMachOpErr :: CmmExpr -> CmmLint a
 153 cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$
 154                                         nest 2 (pprExpr expr))
 155
 156 cmmLintAssignErr :: CmmStmt -> CmmLint a
 157 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
 158                                         nest 2 (pprStmt stmt))
 159
 160 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 161 cmmLintDubiousWordOffset expr
 162    = cmmLintErr (text "offset is not a multiple of words: " $$
 163                         nest 2 (pprExpr expr))