X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=345fb733c7dfaefcc3054d4f349fbe5077af3c6a;hp=395c72a4466feb7881ab39c66df7cc466d10c00b;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hpb=f0bea9fa4679c458ec8d6838fa3e38df2101d935 diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 395c72a..345fb73 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -7,17 +7,10 @@ A ``lint'' pass to check for Core correctness \begin{code} -{-# 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module CoreLint ( lintCoreBindings, lintUnfolding, - showPass, endPass + showPass, endPass, endPassIf, endIteration ) where #include "HsVersions.h" @@ -46,6 +39,7 @@ import StaticFlags import ListSetOps import DynFlags import Outputable +import FastString import Util import Data.Maybe \end{code} @@ -62,7 +56,17 @@ and do Core Lint when necessary. \begin{code} endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] -endPass dflags pass_name dump_flag binds +endPass = dumpAndLint dumpIfSet_core + +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endPassIf cond = dumpAndLint (dumpIf_core cond) + +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endIteration = dumpAndLint dumpIfSet_dyn + +dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) + -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +dumpAndLint dump dflags pass_name dump_flag binds = do -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated @@ -70,7 +74,7 @@ endPass dflags pass_name dump_flag binds (text " Result size =" <+> int (coreBindsSize binds)) -- Report verbosely, if required - dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds) + dump dflags dump_flag pass_name (pprCoreBindings binds) -- Type check lintCoreBindings dflags pass_name binds @@ -166,7 +170,7 @@ Now the inner case look as though it has incompatible branches. \begin{code} lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () -lintCoreBindings dflags whoDunnit binds +lintCoreBindings dflags _whoDunnit _binds | not (dopt Opt_DoCoreLinting dflags) = return () @@ -225,6 +229,7 @@ lintUnfolding locn vars expr Check a core binding, returning the list of variables bound. \begin{code} +lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs @@ -299,7 +304,7 @@ lintCoreExpr (Cast expr co) ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) ; return to_ty } -lintCoreExpr (Note other_note expr) +lintCoreExpr (Note _ expr) = lintCoreExpr expr lintCoreExpr (Let (NonRec bndr rhs) body) @@ -375,7 +380,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = where pass_var f = f var -lintCoreExpr e@(Type ty) +lintCoreExpr e@(Type _) = addErrL (mkStrangeTyMsg e) \end{code} @@ -400,7 +405,7 @@ lintCoreArgs ty (a : args) = do { res <- lintCoreArg ty a ; lintCoreArgs res args } -lintCoreArg fun_ty a@(Type arg_ty) = +lintCoreArg fun_ty (Type arg_ty) = do { arg_ty <- lintTy arg_ty ; lintTyApp fun_ty arg_ty } @@ -428,6 +433,7 @@ lintTyApp ty arg_ty ; checkKinds tyvar arg_ty ; return (substTyWith [tyvar] [arg_ty] body) } +checkKinds :: Var -> Type -> LintM () checkKinds tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give @@ -458,7 +464,7 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- the simplifer correctly eliminates case that can't -- possibly match. -checkCaseAlts e ty [] +checkCaseAlts e _ [] = addErrL (mkNullAltsMsg e) checkCaseAlts e ty alts = @@ -471,14 +477,14 @@ checkCaseAlts e ty alts = -- Check that successive alternatives have increasing tags increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag other = True + increasing_tag _ = True non_deflt (DEFAULT, _, _) = False - non_deflt alt = True + non_deflt _ = True is_infinite_ty = case splitTyConApp_maybe ty of - Nothing -> False - Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon + Nothing -> False + Just (tycon, _) -> isPrimTyCon tycon \end{code} \begin{code} @@ -492,11 +498,11 @@ lintCoreAlt :: OutType -- Type of scrutinee -> CoreAlt -> LintM () -lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) = +lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = do { checkL (null args) (mkDefaultArgsMsg args) ; checkAltExpr rhs alt_ty } -lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) = do { checkL (null args) (mkDefaultArgsMsg args) ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) ; checkAltExpr rhs alt_ty } @@ -519,9 +525,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) { -- Check the pattern -- Scrutinee type must be a tycon applicn; checked by caller -- This code is remarkably compact considering what it does! - -- NB: args must be in scope here so that the lintCoreArgs line works. - -- NB: relies on existential type args coming *after* ordinary type args - + -- NB: args must be in scope here so that the lintCoreArgs + -- line works. + -- NB: relies on existential type args coming *after* + -- ordinary type args ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args) ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } @@ -628,7 +635,7 @@ Here we substitute 'ty' for 'a' in 'body', on the fly. -} instance Monad LintM where - return x = LintM (\ loc subst errs -> (Just x, errs)) + return x = LintM (\ _ _ errs -> (Just x, errs)) fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc)) m >>= k = LintM (\ loc subst errs -> let (res, errs') = unLintM m loc subst errs in @@ -658,7 +665,7 @@ initL m \begin{code} checkL :: Bool -> Message -> LintM () -checkL True msg = return () +checkL True _ = return () checkL False msg = addErrL msg addErrL :: Message -> LintM a @@ -692,10 +699,10 @@ addInScopeVars vars m updateTvSubst :: TvSubst -> LintM a -> LintM a updateTvSubst subst' m = - LintM (\ loc subst errs -> unLintM m loc subst' errs) + LintM (\ loc _ errs -> unLintM m loc subst' errs) getTvSubst :: LintM TvSubst -getTvSubst = LintM (\ loc subst errs -> (Just subst, errs)) +getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) applySubst :: Type -> LintM Type applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) } @@ -753,6 +760,8 @@ checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg %************************************************************************ \begin{code} +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + dumpLoc (RhsOf v) = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v])) @@ -768,10 +777,10 @@ dumpLoc (BodyOfLetRec bs@(_:_)) dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) -dumpLoc (CaseAlt (con, args, rhs)) +dumpLoc (CaseAlt (con, args, _)) = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) -dumpLoc (CasePat (con, args, rhs)) +dumpLoc (CasePat (con, args, _)) = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) dumpLoc (ImportedUnfolding locn) @@ -784,7 +793,7 @@ pp_binders bs = sep (punctuate comma (map pp_binder bs)) pp_binder :: Var -> SDoc pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] \end{code} \begin{code} @@ -813,6 +822,7 @@ mkScrutMsg var var_ty scrut_ty subst text "Scrutinee type:" <+> ppr scrut_ty, hsep [ptext SLIT("Current TV subst"), ppr subst]] +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e @@ -893,7 +903,7 @@ mkRhsMsg binder ty hsep [ptext SLIT("Rhs type:"), ppr ty]] mkRhsPrimMsg :: Id -> CoreExpr -> Message -mkRhsPrimMsg binder rhs +mkRhsPrimMsg binder _rhs = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), ppr binder], hsep [ptext SLIT("Binder's type:"), ppr (idType binder)] @@ -924,16 +934,19 @@ mkUnboxedTupleMsg binder = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder], hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]] +mkCastErr :: Type -> Type -> Message mkCastErr from_ty expr_ty = vcat [ptext SLIT("From-type of Cast differs from type of enclosed expression"), ptext SLIT("From-type:") <+> ppr from_ty, ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty ] +dupVars :: [[Var]] -> Message dupVars vars = hang (ptext SLIT("Duplicate variables brought into scope")) 2 (ppr vars) +mkStrangeTyMsg :: CoreExpr -> Message mkStrangeTyMsg e = ptext SLIT("Type where expression expected:") <+> ppr e \end{code}