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 #include "HsVersions.h"
  21
  22 import Cmm
  23 import CLabel
  24 import MachOp
  25 import Maybe
  26 import Outputable
  27 import PprCmm
  28 import Unique
  29 import Constants
  30
  31 import Control.Monad
  32
  33 -- -----------------------------------------------------------------------------
  34 -- Exported entry points:
  35
  36 cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
  37 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
  38
  39 cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
  40 cmmLintTop top = runCmmLint $ lintCmmTop top
  41
  42 runCmmLint :: CmmLint a -> Maybe SDoc
  43 runCmmLint l =
  44    case unCL l of
  45         Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
  46         Right _  -> Nothing
  47
  48 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
  49 lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
  50   = addLintInfo (text "in proc " <> pprCLabel lbl) $
  51         let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
  52         in  mapM_ (lintCmmBlock labels) blocks
  53
  54 lintCmmTop (CmmData {})
  55   = return ()
  56
  57 lintCmmBlock labels (BasicBlock id stmts)
  58   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
  59         mapM_ (lintCmmStmt labels) stmts
  60
  61 -- -----------------------------------------------------------------------------
  62 -- lintCmmExpr
  63
  64 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
  65 -- byte/word mismatches.
  66
  67 lintCmmExpr :: CmmExpr -> CmmLint MachRep
  68 lintCmmExpr (CmmLoad expr rep) = do
  69   lintCmmExpr expr
  70   when (machRepByteWidth rep >= wORD_SIZE) $
  71      cmmCheckWordAddress expr
  72   return rep
  73 lintCmmExpr expr@(CmmMachOp op args) = do
  74   mapM_ lintCmmExpr args
  75   if map cmmExprRep args == machOpArgReps op
  76         then cmmCheckMachOp op args
  77         else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
  78 lintCmmExpr (CmmRegOff reg offset)
  79   = lintCmmExpr (CmmMachOp (MO_Add rep)
  80                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
  81   where rep = cmmRegRep reg
  82 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
  83   | isFloatingRep rep
  84   = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
  85 lintCmmExpr expr =
  86   return (cmmExprRep expr)
  87
  88 -- Check for some common byte/word mismatches (eg. Sp + 1)
  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 (CmmGlobal Sp) = True
 102 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
 103 --isWordOffsetReg (CmmGlobal Hp) = True
 104 isWordOffsetReg _ = False
 105
 106 isOffsetOp (MO_Add _) = True
 107 isOffsetOp (MO_Sub _) = True
 108 isOffsetOp _ = False
 109
 110 -- This expression should be an address from which a word can be loaded:
 111 -- check for funny-looking sub-word offsets.
 112 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 113   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 114   = cmmLintDubiousWordOffset e
 115 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 116   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
 117   = cmmLintDubiousWordOffset e
 118 cmmCheckWordAddress _
 119   = return ()
 120
 121 -- No warnings for unaligned arithmetic with the node register,
 122 -- which is used to extract fields from tagged constructor closures.
 123 notNodeReg (CmmReg reg) | reg == nodeReg = False
 124 notNodeReg _                             = True
 125
 126 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
 127 lintCmmStmt labels = lint
 128     where lint (CmmNop) = return ()
 129           lint (CmmComment {}) = return ()
 130           lint stmt@(CmmAssign reg expr) = do
 131             erep <- lintCmmExpr expr
 132             if (erep == cmmRegRep reg)
 133                 then return ()
 134                 else cmmLintAssignErr stmt
 135           lint (CmmStore l r) = do
 136             lintCmmExpr l
 137             lintCmmExpr r
 138             return ()
 139           lint (CmmCall target _res args _ _) =
 140               lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
 141           lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
 142           lint (CmmSwitch e branches) = do
 143             mapM_ checkTarget $ catMaybes branches
 144             erep <- lintCmmExpr e
 145             if (erep == wordRep)
 146               then return ()
 147               else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
 148           lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
 149           lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
 150           lint (CmmBranch id)    = checkTarget id
 151           checkTarget id = if elemBlockSet id labels then return ()
 152                            else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 153
 154 lintTarget :: CmmCallTarget -> CmmLint ()
 155 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
 156 lintTarget (CmmPrim {})    = return ()
 157
 158
 159 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 160 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 161                                     (ppr expr))
 162
 163 -- -----------------------------------------------------------------------------
 164 -- CmmLint monad
 165
 166 -- just a basic error monad:
 167
 168 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 169
 170 instance Monad CmmLint where
 171   CmmLint m >>= k = CmmLint $ case m of
 172                                 Left e -> Left e
 173                                 Right a -> unCL (k a)
 174   return a = CmmLint (Right a)
 175
 176 cmmLintErr :: SDoc -> CmmLint a
 177 cmmLintErr msg = CmmLint (Left msg)
 178
 179 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 180 addLintInfo info thing = CmmLint $
 181    case unCL thing of
 182         Left err -> Left (hang info 2 err)
 183         Right a  -> Right a
 184
 185 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
 186 cmmLintMachOpErr expr argsRep opExpectsRep
 187      = cmmLintErr (text "in MachOp application: " $$
 188                                         nest 2 (pprExpr expr) $$
 189                                         (text "op is expecting: " <+> ppr opExpectsRep) $$
 190                                         (text "arguments provide: " <+> ppr argsRep))
 191
 192 cmmLintAssignErr :: CmmStmt -> CmmLint a
 193 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
 194                                         nest 2 (pprStmt stmt))
 195
 196 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 197 cmmLintDubiousWordOffset expr
 198    = cmmLintErr (text "offset is not a multiple of words: " $$
 199                         nest 2 (pprExpr expr))