X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLint.hs;h=8824de1796d33ec7e631059eda57f3a0c8962563;hp=fbfb14c1653d42d9bdaa941c3650ede3f028e9bd;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index fbfb14c..8824de1 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -1,8 +1,14 @@ +-- 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 + ----------------------------------------------------------------------------- -- --- CmmLint: checking the correctness of Cmm statements and expressions +-- (c) The University of Glasgow 2004-2006 -- --- (c) The University of Glasgow 2004 +-- CmmLint: checking the correctness of Cmm statements and expressions -- ----------------------------------------------------------------------------- @@ -10,42 +16,46 @@ module CmmLint ( cmmLint, cmmLintTop ) where -#include "HsVersions.h" - import Cmm -import CLabel ( pprCLabel ) +import CLabel import MachOp +import Maybe import Outputable import PprCmm -import Unique ( getUnique ) -import Constants ( wORD_SIZE ) +import Unique +import Constants +import FastString -import Monad ( when ) +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 @@ -63,7 +73,7 @@ lintCmmExpr expr@(CmmMachOp op args) = do mapM_ lintCmmExpr args if map cmmExprRep args == machOpArgReps op then cmmCheckMachOp op args - else cmmLintMachOpErr expr + else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op) lintCmmExpr (CmmRegOff reg offset) = lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) @@ -75,53 +85,85 @@ lintCmmExpr expr = 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 >> return () -lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return () -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)) -- ----------------------------------------------------------------------------- -- CmmLint monad @@ -145,9 +187,12 @@ addLintInfo info thing = CmmLint $ Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: CmmExpr -> CmmLint a -cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$ - nest 2 (pprExpr expr)) +cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a +cmmLintMachOpErr expr argsRep opExpectsRep + = cmmLintErr (text "in MachOp application: " $$ + nest 2 (pprExpr expr) $$ + (text "op is expecting: " <+> ppr opExpectsRep) $$ + (text "arguments provide: " <+> ppr argsRep)) cmmLintAssignErr :: CmmStmt -> CmmLint a cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$