+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2006
cmmLint, cmmLintTop
) where
-#include "HsVersions.h"
-
+import BlockId
import Cmm
import CLabel
import MachOp
+import Maybe
import Outputable
import PprCmm
import Unique
import Constants
+import FastString
import Control.Monad
-- -----------------------------------------------------------------------------
-- Exported entry points:
-cmmLint :: Cmm -> Maybe SDoc
+cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
-cmmLintTop :: CmmTop -> Maybe SDoc
+cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop top = runCmmLint $ lintCmmTop top
runCmmLint :: CmmLint a -> Maybe SDoc
runCmmLint l =
case unCL l of
- Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
+ Left err -> Just (ptext (sLit "Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
-lintCmmTop (CmmProc _info lbl _args blocks)
+lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
+lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel lbl) $
- mapM_ lintCmmBlock blocks
-lintCmmTop _other
+ let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
+ in mapM_ (lintCmmBlock labels) blocks
+
+lintCmmTop (CmmData {})
= return ()
-lintCmmBlock (BasicBlock id stmts)
+lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
+lintCmmBlock labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr (getUnique id)) $
- mapM_ lintCmmStmt stmts
+ mapM_ (lintCmmStmt labels) stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
return (cmmExprRep expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp :: MachOp -> [CmmExpr] -> CmmLint MachRep
cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
| isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset (CmmMachOp op args)
-cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)]
= cmmCheckMachOp op [reg, lit]
cmmCheckMachOp op@(MO_U_Conv from to) args
| isFloatingRep from || isFloatingRep to
= cmmLintErr (text "unsigned conversion from/to floating rep: "
<> ppr (CmmMachOp op args))
-cmmCheckMachOp op args
+cmmCheckMachOp op _args
= return (resultRepOfMachOp op)
+isWordOffsetReg :: CmmReg -> Bool
isWordOffsetReg (CmmGlobal Sp) = True
-isWordOffsetReg (CmmGlobal Hp) = True
+-- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
+--isWordOffsetReg (CmmGlobal Hp) = True
isWordOffsetReg _ = False
+isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
+cmmCheckWordAddress :: CmmExpr -> CmmLint ()
cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
- | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
- | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress _
= return ()
-
-lintCmmStmt :: CmmStmt -> CmmLint ()
-lintCmmStmt stmt@(CmmAssign reg expr) = do
- erep <- lintCmmExpr expr
- if (erep == cmmRegRep reg)
- then return ()
- else cmmLintAssignErr stmt
-lintCmmStmt (CmmStore l r) = do
- lintCmmExpr l
- lintCmmExpr r
- return ()
-lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
-lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
-lintCmmStmt (CmmSwitch e _branches) = do
- erep <- lintCmmExpr e
- if (erep == wordRep)
- then return ()
- else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
-lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
-lintCmmStmt _other = return ()
-
+-- No warnings for unaligned arithmetic with the node register,
+-- which is used to extract fields from tagged constructor closures.
+notNodeReg :: CmmExpr -> Bool
+notNodeReg (CmmReg reg) | reg == nodeReg = False
+notNodeReg _ = True
+
+lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
+lintCmmStmt labels = lint
+ where lint (CmmNop) = return ()
+ lint (CmmComment {}) = return ()
+ lint stmt@(CmmAssign reg expr) = do
+ erep <- lintCmmExpr expr
+ if (erep == cmmRegRep reg)
+ then return ()
+ else cmmLintAssignErr stmt
+ lint (CmmStore l r) = do
+ lintCmmExpr l
+ lintCmmExpr r
+ return ()
+ lint (CmmCall target _res args _ _) =
+ lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
+ lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
+ lint (CmmSwitch e branches) = do
+ mapM_ checkTarget $ catMaybes branches
+ erep <- lintCmmExpr e
+ if (erep == wordRep)
+ then return ()
+ else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
+ lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
+ lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) ress
+ lint (CmmBranch id) = checkTarget id
+ checkTarget id = if elemBlockSet id labels then return ()
+ else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+lintTarget :: CmmCallTarget -> CmmLint ()
+lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
+lintTarget (CmmPrim {}) = return ()
+
+
+checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
projects / ghc-hetmet.git / blobdiff