X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLint.hs;h=32fead337ea8319048049d0a37f5159391dc3655;hp=bf10135b5fce749cc62b98bb075f7bf4851f2b39;hb=HEAD;hpb=5572f26db9b94f3d802c4cacfae11084aa3eebe0 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index bf10135..32fead3 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -w #-} -- 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 @@ -17,44 +16,48 @@ module CmmLint ( cmmLint, cmmLintTop ) where -import Cmm +import BlockId +import OldCmm import CLabel -import MachOp -import Maybe import Outputable -import PprCmm -import Unique +import OldPprCmm() import Constants import FastString -import Control.Monad +import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops +cmmLint :: (Outputable d, Outputable h) + => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops -cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop top = runCmmLint $ lintCmmTop top +cmmLintTop :: (Outputable d, Outputable h) + => 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) - Right _ -> Nothing +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)) +lintCmmTop (CmmProc _ lbl (ListGraph blocks)) = addLintInfo (text "in proc " <> pprCLabel lbl) $ - let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks + let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks in mapM_ (lintCmmBlock labels) blocks lintCmmTop (CmmData {}) = return () +lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint () lintCmmBlock labels (BasicBlock id stmts) - = addLintInfo (text "in basic block " <> ppr (getUnique id)) $ + = addLintInfo (text "in basic block " <> ppr id) $ mapM_ (lintCmmStmt labels) stmts -- ----------------------------------------------------------------------------- @@ -63,62 +66,53 @@ lintCmmBlock labels (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 { })), 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 --- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures. ---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 _)]) +_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]) +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress _ +_cmmCheckWordAddress _ = 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 @@ -128,12 +122,13 @@ lintCmmStmt labels = lint lint (CmmComment {}) = return () lint stmt@(CmmAssign reg expr) = do erep <- lintCmmExpr expr - if (erep == cmmRegRep reg) + let reg_ty = cmmRegType reg + if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () - else cmmLintAssignErr stmt + else cmmLintAssignErr stmt erep reg_ty lint (CmmStore l r) = do - lintCmmExpr l - lintCmmExpr r + _ <- lintCmmExpr l + _ <- lintCmmExpr r return () lint (CmmCall target _res args _ _) = lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args @@ -141,13 +136,14 @@ lintCmmStmt labels = lint lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches erep <- lintCmmExpr e - if (erep == wordRep) + if (erep `cmmEqType_ignoring_ptrhood` bWord) then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e) + 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 elemBlockSet id labels then return () + checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) lintTarget :: CmmCallTarget -> CmmLint () @@ -155,7 +151,9 @@ 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)) @@ -181,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))