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