ghc/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 expr =
  72   return (cmmExprRep expr)
  73
  74 -- Check for some common byte/word mismatches (eg. Sp + 1)
  75 cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
  76   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  77   = cmmLintDubiousWordOffset (CmmMachOp op args)
  78 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
  79   = cmmCheckMachOp op [reg, lit]
  80 cmmCheckMachOp op args
  81   = return (resultRepOfMachOp op)
  82
  83 isWordOffsetReg (CmmGlobal Sp) = True
  84 isWordOffsetReg (CmmGlobal Hp) = True
  85 isWordOffsetReg _ = False
  86
  87 isOffsetOp (MO_Add _) = True
  88 isOffsetOp (MO_Sub _) = True
  89 isOffsetOp _ = False
  90
  91 -- This expression should be an address from which a word can be loaded:
  92 -- check for funny-looking sub-word offsets.
  93 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
  94   | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  95   = cmmLintDubiousWordOffset e
  96 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
  97   | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
  98   = cmmLintDubiousWordOffset e
  99 cmmCheckWordAddress _
 100   = return ()
 101
 102
 103 lintCmmStmt :: CmmStmt -> CmmLint ()
 104 lintCmmStmt stmt@(CmmAssign reg expr) = do
 105   erep <- lintCmmExpr expr
 106   if (erep == cmmRegRep reg)
 107         then return ()
 108         else cmmLintAssignErr stmt
 109 lintCmmStmt (CmmStore l r) = do
 110   lintCmmExpr l
 111   lintCmmExpr r
 112   return ()
 113 lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
 114 lintCmmStmt (CmmCondBranch e _id)   = lintCmmExpr e >> return ()
 115 lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
 116 lintCmmStmt (CmmJump e _args)       = lintCmmExpr e >> return ()
 117 lintCmmStmt _other                  = return ()
 118
 119 -- -----------------------------------------------------------------------------
 120 -- CmmLint monad
 121
 122 -- just a basic error monad:
 123
 124 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 125
 126 instance Monad CmmLint where
 127   CmmLint m >>= k = CmmLint $ case m of
 128                                 Left e -> Left e
 129                                 Right a -> unCL (k a)
 130   return a = CmmLint (Right a)
 131
 132 cmmLintErr :: SDoc -> CmmLint a
 133 cmmLintErr msg = CmmLint (Left msg)
 134
 135 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 136 addLintInfo info thing = CmmLint $
 137    case unCL thing of
 138         Left err -> Left (hang info 2 err)
 139         Right a  -> Right a
 140
 141 cmmLintMachOpErr :: CmmExpr -> CmmLint a
 142 cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$
 143                                         nest 2 (pprExpr expr))
 144
 145 cmmLintAssignErr :: CmmStmt -> CmmLint a
 146 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
 147                                         nest 2 (pprStmt stmt))
 148
 149 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 150 cmmLintDubiousWordOffset expr
 151    = cmmLintErr (text "offset is not a multiple of words: " $$
 152                         nest 2 (pprExpr expr))