X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLint.hs;h=32fead337ea8319048049d0a37f5159391dc3655;hp=875876fbdd03dbd2eedea61e5d7bc78e0f5e93ea;hb=HEAD;hpb=4f6f4a294f00d559b4f024255d11eb1da9bfe036 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 875876f..32fead3 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -1,3 +1,9 @@ +-- 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 @@ -10,42 +16,49 @@ module CmmLint ( cmmLint, cmmLintTop ) where -#include "HsVersions.h" - -import Cmm +import BlockId +import OldCmm import CLabel -import MachOp import Outputable -import PprCmm -import Unique +import OldPprCmm() import Constants +import FastString -import Control.Monad +import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: Cmm -> Maybe SDoc -cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops - -cmmLintTop :: CmmTop -> 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) - Right _ -> Nothing - -lintCmmTop (CmmProc _info lbl _args blocks) +cmmLint :: (Outputable d, Outputable h) + => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops + +cmmLintTop :: (Outputable d, Outputable h) + => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop top = runCmmLint lintCmmTop top + +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 + +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 -> setInsert (blockId b) s) setEmpty blocks + in mapM_ (lintCmmBlock labels) blocks + +lintCmmTop (CmmData {}) = return () -lintCmmBlock (BasicBlock id stmts) - = addLintInfo (text "in basic block " <> ppr (getUnique id)) $ - mapM_ lintCmmStmt stmts +lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint () +lintCmmBlock labels (BasicBlock id stmts) + = addLintInfo (text "in basic block " <> ppr id) $ + mapM_ (lintCmmStmt labels) stmts -- ----------------------------------------------------------------------------- -- lintCmmExpr @@ -53,81 +66,94 @@ lintCmmBlock (BasicBlock id stmts) -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking -- byte/word mismatches. -lintCmmExpr :: CmmExpr -> CmmLint MachRep +lintCmmExpr :: CmmExpr -> CmmLint CmmType lintCmmExpr (CmmLoad expr rep) = do - lintCmmExpr expr - when (machRepByteWidth rep >= wORD_SIZE) $ - cmmCheckWordAddress expr + _ <- 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 expr@(CmmMachOp op args) = do - mapM_ lintCmmExpr args - if map cmmExprRep args == machOpArgReps op - then cmmCheckMachOp op args - else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op) + 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 (CmmRegOff reg offset) - = lintCmmExpr (CmmMachOp (MO_Add rep) + = lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = cmmRegRep reg -lintCmmExpr lit@(CmmLit (CmmInt _ rep)) - | isFloatingRep rep - = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit) + where rep = typeWidth (cmmRegType reg) lintCmmExpr expr = - return (cmmExprRep expr) + return (cmmExprType expr) -- Check for some common byte/word mismatches (eg. Sp + 1) -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 [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 - = return (resultRepOfMachOp op) - -isWordOffsetReg (CmmGlobal Sp) = True -isWordOffsetReg (CmmGlobal Hp) = True -isWordOffsetReg _ = False +cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType +cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys + = cmmCheckMachOp op [reg, lit] tys +cmmCheckMachOp op _ tys + = return (machOpResultType op tys) +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 e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) + | 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 +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress _ +_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 + 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 l + _ <- lintCmmExpr r + return () + lint (CmmCall target _res args _ _) = + lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) 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 `cmmEqType_ignoring_ptrhood` bWord) + then return () + else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> + text " :: " <> ppr erep) + lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args + lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress + lint (CmmBranch id) = checkTarget id + checkTarget id = if setMember 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 (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)) @@ -153,18 +179,23 @@ addLintInfo info thing = CmmLint $ Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a cmmLintMachOpErr expr argsRep opExpectsRep = cmmLintErr (text "in MachOp application: " $$ - nest 2 (pprExpr expr) $$ + nest 2 (ppr expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) -cmmLintAssignErr :: CmmStmt -> CmmLint a -cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$ - nest 2 (pprStmt stmt)) +cmmLintAssignErr :: CmmStmt -> 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])) + + cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (pprExpr expr)) + nest 2 (ppr expr))