summaryrefslogtreecommitdiff
path: root/compiler/cmm/CmmLint.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm/CmmLint.hs')
-rw-r--r--compiler/cmm/CmmLint.hs222
1 files changed, 121 insertions, 101 deletions
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 01ebac6254..2e24dd7f82 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -1,67 +1,70 @@
-----------------------------------------------------------------------------
--
--- (c) The University of Glasgow 2004-2006
+-- (c) The University of Glasgow 2011
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
+{-# LANGUAGE GADTs #-}
module CmmLint (
- cmmLint, cmmLintTop
+ cmmLint, cmmLintGraph
) where
+import Hoopl
+import Cmm
+import CmmUtils
+import PprCmm ()
import BlockId
-import OldCmm
-import CLabel
+import FastString
import Outputable
-import OldPprCmm()
import Constants
-import FastString
-import Platform
import Data.Maybe
+-- Things to check:
+-- - invariant on CmmBlock in CmmExpr (see comment there)
+-- - check for branches to blocks that don't exist
+-- - check types
+
-- -----------------------------------------------------------------------------
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
- => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
+ => GenCmmGroup d h CmmGraph -> Maybe SDoc
+cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
-cmmLintTop :: (Outputable d, Outputable h)
- => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
+cmmLintGraph :: CmmGraph -> Maybe SDoc
+cmmLintGraph g = runCmmLint lintCmmGraph g
-runCmmLint :: Outputable a
- => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint _ l p =
+runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint l p =
case unCL (l p) of
- Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
- nest 2 err,
- ptext $ sLit ("Program was:"),
- nest 2 (ppr p)])
- Right _ -> Nothing
-
-lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
- = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
- let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
- in mapM_ (lintCmmBlock platform labels) blocks
-
-lintCmmDecl _ (CmmData {})
+ Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
+ nest 2 err,
+ ptext $ sLit ("Program was:"),
+ nest 2 (ppr p)])
+ Right _ -> Nothing
+
+lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl (CmmProc _ lbl g)
+ = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
+lintCmmDecl (CmmData {})
= return ()
-lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
-lintCmmBlock platform labels (BasicBlock id stmts)
- = addLintInfo (text "in basic block " <> ppr id) $
- mapM_ (lintCmmStmt platform labels) stmts
+
+lintCmmGraph :: CmmGraph -> CmmLint ()
+lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
+ where
+ blocks = toBlockList g
+ labels = setFromList (map entryLabel blocks)
+
+
+lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
+lintCmmBlock labels block
+ = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
+ let (_, middle, last) = blockSplit block
+ mapM_ lintCmmMiddle (blockToList middle)
+ lintCmmLast labels last
-- -----------------------------------------------------------------------------
-- lintCmmExpr
@@ -69,24 +72,24 @@ lintCmmBlock platform labels (BasicBlock id stmts)
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
-lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
-lintCmmExpr platform (CmmLoad expr rep) = do
- _ <- lintCmmExpr platform expr
+lintCmmExpr :: CmmExpr -> CmmLint CmmType
+lintCmmExpr (CmmLoad expr rep) = do
+ _ <- lintCmmExpr expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- cmmCheckWordAddress expr
return rep
-lintCmmExpr platform expr@(CmmMachOp op args) = do
- tys <- mapM (lintCmmExpr platform) args
+lintCmmExpr expr@(CmmMachOp op args) = do
+ tys <- mapM lintCmmExpr args
if map (typeWidth . cmmExprType) args == machOpArgReps op
- then cmmCheckMachOp op args tys
- else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
-lintCmmExpr platform (CmmRegOff reg offset)
- = lintCmmExpr platform (CmmMachOp (MO_Add rep)
- [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
+ then cmmCheckMachOp op args tys
+ else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
+lintCmmExpr (CmmRegOff reg offset)
+ = lintCmmExpr (CmmMachOp (MO_Add rep)
+ [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
where rep = typeWidth (cmmRegType reg)
-lintCmmExpr _ expr =
+lintCmmExpr expr =
return (cmmExprType expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
@@ -119,43 +122,61 @@ notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
-lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
-lintCmmStmt platform labels = lint
- where lint (CmmNop) = return ()
- lint (CmmComment {}) = return ()
- lint stmt@(CmmAssign reg expr) = do
- erep <- lintCmmExpr platform expr
- let reg_ty = cmmRegType reg
+lintCmmMiddle :: CmmNode O O -> CmmLint ()
+lintCmmMiddle node = case node of
+ CmmComment _ -> return ()
+
+ CmmAssign reg expr -> do
+ erep <- lintCmmExpr expr
+ let reg_ty = cmmRegType reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
- else cmmLintAssignErr stmt erep reg_ty
- lint (CmmStore l r) = do
- _ <- lintCmmExpr platform l
- _ <- lintCmmExpr platform r
+ else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
+
+ CmmStore l r -> do
+ _ <- lintCmmExpr l
+ _ <- lintCmmExpr r
return ()
- lint (CmmCall target _res args _) =
- do lintTarget platform labels target
- mapM_ (lintCmmExpr platform . hintlessCmm) args
- lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e
- lint (CmmSwitch e branches) = do
+
+ CmmUnsafeForeignCall target _formals actuals -> do
+ lintTarget target
+ mapM_ lintCmmExpr actuals
+
+
+lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
+lintCmmLast labels node = case node of
+ CmmBranch id -> checkTarget id
+
+ CmmCondBranch e t f -> do
+ mapM_ checkTarget [t,f]
+ _ <- lintCmmExpr e
+ checkCond e
+
+ CmmSwitch e branches -> do
mapM_ checkTarget $ catMaybes branches
- erep <- lintCmmExpr platform e
+ erep <- lintCmmExpr e
if (erep `cmmEqType_ignoring_ptrhood` bWord)
then return ()
- else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
- text " :: " <> ppr erep)
- lint (CmmJump e _) = lintCmmExpr platform e >> return ()
- lint (CmmReturn) = return ()
- lint (CmmBranch id) = checkTarget id
- checkTarget id = if setMember id labels then return ()
- else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-
-lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint ()
-lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e
- return ()
-lintTarget _ _ (CmmPrim _ Nothing) = return ()
-lintTarget platform labels (CmmPrim _ (Just stmts))
- = mapM_ (lintCmmStmt platform labels) stmts
+ else cmmLintErr (text "switch scrutinee is not a word: " <>
+ ppr e <> text " :: " <> ppr erep)
+
+ CmmCall { cml_target = target, cml_cont = cont } -> do
+ _ <- lintCmmExpr target
+ maybe (return ()) checkTarget cont
+
+ CmmForeignCall tgt _ args succ _ _ -> do
+ lintTarget tgt
+ mapM_ lintCmmExpr args
+ checkTarget succ
+ where
+ checkTarget id
+ | setMember id labels = return ()
+ | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+
+lintTarget :: ForeignTarget -> CmmLint ()
+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
+lintTarget (PrimTarget {}) = return ()
checkCond :: CmmExpr -> CmmLint ()
@@ -163,7 +184,7 @@ checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
- (ppr expr))
+ (ppr expr))
-- -----------------------------------------------------------------------------
-- CmmLint monad
@@ -173,37 +194,36 @@ checkCond expr
newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
instance Monad CmmLint where
- CmmLint m >>= k = CmmLint $ case m of
- Left e -> Left e
- Right a -> unCL (k a)
+ CmmLint m >>= k = CmmLint $ case m of
+ Left e -> Left e
+ Right a -> unCL (k a)
return a = CmmLint (Right a)
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (Left msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $
+addLintInfo info thing = CmmLint $
case unCL thing of
- Left err -> Left (hang info 2 err)
- Right a -> Right a
+ Left err -> Left (hang info 2 err)
+ Right a -> Right a
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
- = cmmLintErr (text "in MachOp application: " $$
- nest 2 (ppr expr) $$
- (text "op is expecting: " <+> ppr opExpectsRep) $$
- (text "arguments provide: " <+> ppr argsRep))
+ = cmmLintErr (text "in MachOp application: " $$
+ nest 2 (ppr expr) $$
+ (text "op is expecting: " <+> ppr opExpectsRep) $$
+ (text "arguments provide: " <+> ppr argsRep))
-cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
+cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr stmt e_ty r_ty
- = cmmLintErr (text "in assignment: " $$
- nest 2 (vcat [ppr stmt,
- text "Reg ty:" <+> ppr r_ty,
- text "Rhs ty:" <+> ppr e_ty]))
-
-
+ = cmmLintErr (text "in assignment: " $$
+ nest 2 (vcat [ppr stmt,
+ text "Reg ty:" <+> ppr r_ty,
+ text "Rhs ty:" <+> ppr e_ty]))
+
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
- nest 2 (ppr expr))
+ nest 2 (ppr expr))
View Lorry Controller Status