compiler/cmm/CmmLint.hs

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