X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=7a5fac49facef798073648699e356af082f6e55f;hb=2fb8e343ac2b9dcb5c2476648cf3e30ec6637afd;hp=59c52da46a6f691e1082163a6dbf9bf86b3f6313;hpb=054b55029dbf8b7d76ac917e4e2ac937785cb90b;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 59c52da..7a5fac4 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -1,3 +1,4 @@ + % % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -9,11 +10,12 @@ A ``lint'' pass to check for Core correctness module CoreLint ( lintCoreBindings, lintUnfolding, - showPass, endPass + showPass, endPass, endPassIf, endIteration ) where #include "HsVersions.h" +import NewDemand import CoreSyn import CoreFVs import CoreUtils @@ -25,6 +27,7 @@ import Var import VarEnv import VarSet import Name +import Id import PprCore import ErrUtils import SrcLoc @@ -33,13 +36,11 @@ import Coercion import TyCon import BasicTypes import StaticFlags +import ListSetOps import DynFlags import Outputable - -#ifdef DEBUG -import Util ( notNull ) -#endif - +import FastString +import Util import Data.Maybe \end{code} @@ -55,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 @@ -63,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 @@ -159,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 () @@ -172,18 +183,19 @@ lintCoreBindings dflags whoDunnit binds -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something -- into use 'unexpectedly' - lint_binds binds = addInScopeVars (bindersOfBinds binds) $ + lint_binds binds = addLoc TopLevelBindings $ + addInScopeVars (bindersOfBinds binds) $ mapM lint_bind binds - lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs - lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) + lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs + lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) display bad_news = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), bad_news, - ptext SLIT("*** Offending Program ***"), + ptext (sLit "*** Offending Program ***"), pprCoreBindings binds, - ptext SLIT("*** End of Offense ***") + ptext (sLit "*** End of Offense ***") ] \end{code} @@ -217,7 +229,8 @@ lintUnfolding locn vars expr Check a core binding, returning the list of variables bound. \begin{code} -lintSingleBinding rec_flag (binder,rhs) +lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () +lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs do { ty <- lintCoreExpr rhs @@ -228,14 +241,26 @@ lintSingleBinding rec_flag (binder,rhs) ; checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) + -- Check that if the binder is top-level or recursive, it's not demanded + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) + (mkStrictMsg binder) -- Check whether binder's specialisations contain any out-of-scope variables - ; mapM_ (checkBndrIdInScope binder) bndr_vars } + ; mapM_ (checkBndrIdInScope binder) bndr_vars + + -- Check whether arity and demand type are consistent (only if demand analysis + -- already happened) + ; checkL (case maybeDmdTy of + Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs + Nothing -> True) + (mkArityMsg binder) } -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - where - binder_ty = idType binder - bndr_vars = varSetElems (idFreeVars binder) + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + where + binder_ty = idType binder + maybeDmdTy = idNewStrictness_maybe binder + bndr_vars = varSetElems (idFreeVars binder) lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () \end{code} @@ -257,7 +282,7 @@ lintCoreExpr :: CoreExpr -> LintM OutType lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) - (ptext SLIT("Illegal one-tuple")) + (ptext (sLit "Illegal one-tuple")) ; var' <- lookupIdInScope var ; return (idType var') } @@ -279,17 +304,17 @@ 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) - = do { lintSingleBinding NonRecursive (bndr,rhs) + = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) ; addLoc (BodyOfLetRec [bndr]) (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> - do { mapM (lintSingleBinding Recursive) pairs + do { mapM (lintSingleBinding NotTopLevel Recursive) pairs ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } where bndrs = map fst pairs @@ -338,6 +363,18 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = do { scrut_ty <- lintCoreExpr scrut ; alt_ty <- lintTy alt_ty ; var_ty <- lintTy (idType var) + + ; let mb_tc_app = splitTyConApp_maybe (idType var) + ; case mb_tc_app of + Just (tycon, _) + | debugIsOn && + isAlgTyCon tycon && + null (tyConDataCons tycon) -> + pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate ; subst <- getTvSubst @@ -349,13 +386,13 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = else lintAndScopeId var ; scope $ \_ -> do { -- Check the alternatives - checkCaseAlts e scrut_ty alts - ; mapM (lintCoreAlt scrut_ty alt_ty) alts + mapM (lintCoreAlt scrut_ty alt_ty) alts + ; checkCaseAlts e scrut_ty alts ; return alt_ty } } where pass_var f = f var -lintCoreExpr e@(Type ty) +lintCoreExpr e@(Type _) = addErrL (mkStrangeTyMsg e) \end{code} @@ -380,7 +417,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 } @@ -408,6 +445,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 @@ -438,7 +476,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 = @@ -451,14 +489,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} @@ -472,11 +510,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 } @@ -499,9 +537,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) } @@ -562,7 +601,7 @@ lintAndScopeIds ids linterF lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a lintAndScopeId id linterF = do { ty <- lintTy (idType id) - ; let id' = setIdType id ty + ; let id' = Var.setIdType id ty ; addInScopeVars [id'] $ (linterF id') } @@ -608,7 +647,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 @@ -624,6 +663,7 @@ data LintLocInfo | CasePat CoreAlt -- *Pattern* of the case alternative | AnExpr CoreExpr -- Some expression | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings \end{code} @@ -637,7 +677,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 @@ -651,7 +691,7 @@ addErr subst errs_so_far msg locs (loc, cxt1) = dumpLoc (head locs) cxts = [snd (dumpLoc loc) | loc <- locs] context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ - ptext SLIT("Substitution:") <+> ppr subst + ptext (sLit "Substitution:") <+> ppr subst | otherwise = cxt1 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) @@ -661,15 +701,20 @@ addLoc extra_loc m = LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars vars m = - LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) +addInScopeVars vars m + | null dups + = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) + | otherwise + = addErrL (dupVars dups) + where + (_, dups) = removeDups compare vars 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) } @@ -691,7 +736,7 @@ lookupIdInScope id Nothing -> do { addErrL out_of_scope ; return id } } where - out_of_scope = ppr id <+> ptext SLIT("is out of scope") + out_of_scope = ppr id <+> ptext (sLit "is out of scope") oneTupleDataConId :: Id -- Should not happen @@ -701,11 +746,11 @@ checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id = checkInScope msg id where - msg = ptext SLIT("is out of scope inside info for") <+> + msg = ptext (sLit "is out of scope inside info for") <+> ppr binder checkTyVarInScope :: TyVar -> LintM () -checkTyVarInScope tv = checkInScope (ptext SLIT("is out of scope")) tv +checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var = @@ -727,36 +772,40 @@ 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])) + = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v])) dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)) + = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b)) dumpLoc (BodyOfLetRec []) - = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders"))) + = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders"))) dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)) + = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders 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) - = (locn, brackets (ptext SLIT("in an imported unfolding"))) + = (locn, brackets (ptext (sLit "in an imported unfolding"))) +dumpLoc TopLevelBindings + = (noSrcLoc, empty) pp_binders :: [Var] -> SDoc 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} @@ -783,8 +832,9 @@ mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, - hsep [ptext SLIT("Current TV subst"), ppr subst]] + 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 @@ -828,60 +878,87 @@ mkNewTyDataConAltMsg scrut_ty alt mkAppMsg :: Type -> Type -> CoreExpr -> Message mkAppMsg fun_ty arg_ty arg - = vcat [ptext SLIT("Argument value doesn't match argument type:"), - hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty), - hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty), - hang (ptext SLIT("Arg:")) 4 (ppr arg)] + = vcat [ptext (sLit "Argument value doesn't match argument type:"), + hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), + hang (ptext (sLit "Arg:")) 4 (ppr arg)] mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message mkNonFunAppMsg fun_ty arg_ty arg - = vcat [ptext SLIT("Non-function type in function position"), - hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty), - hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty), - hang (ptext SLIT("Arg:")) 4 (ppr arg)] + = vcat [ptext (sLit "Non-function type in function position"), + hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), + hang (ptext (sLit "Arg:")) 4 (ppr arg)] mkKindErrMsg :: TyVar -> Type -> Message mkKindErrMsg tyvar arg_ty - = vcat [ptext SLIT("Kinds don't match in type application:"), - hang (ptext SLIT("Type variable:")) + = vcat [ptext (sLit "Kinds don't match in type application:"), + hang (ptext (sLit "Type variable:")) 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext SLIT("Arg type:")) + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] mkTyAppMsg :: Type -> Type -> Message mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", - hang (ptext SLIT("Exp type:")) + hang (ptext (sLit "Exp type:")) 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (ptext SLIT("Arg type:")) + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] mkRhsMsg :: Id -> Type -> Message mkRhsMsg binder ty = vcat - [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), + [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], - hsep [ptext SLIT("Rhs type:"), ppr ty]] + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], + hsep [ptext (sLit "Rhs type:"), ppr ty]] mkRhsPrimMsg :: Id -> CoreExpr -> Message -mkRhsPrimMsg binder rhs - = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), +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)] + ] + +mkStrictMsg :: Id -> Message +mkStrictMsg binder + = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType binder)] + hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)] ] +mkArityMsg :: Id -> Message +mkArityMsg binder + = vcat [hsep [ptext (sLit "Demand type has "), + ppr (dmdTypeDepth dmd_ty), + ptext (sLit " arguments, rhs has "), + ppr (idArity binder), + ptext (sLit "arguments, "), + ppr binder], + hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] + + ] + where (StrictSig dmd_ty) = idNewStrictness binder + mkUnboxedTupleMsg :: Id -> Message mkUnboxedTupleMsg binder - = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType 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 + = 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 + = ptext (sLit "Type where expression expected:") <+> ppr e \end{code}