From 49d454d8f8f0e1a83369ec12f8aafc1dcf80aea9 Mon Sep 17 00:00:00 2001 From: Kirsten Chevalier Date: Mon, 29 Jan 2007 22:55:33 +0000 Subject: [PATCH] Two new warnings: arity differing from demand type, and strict IDs at top level I added two new Core Lint checks in lintSingleBinding: 1. Check that the id's arity is equal to the number of arguments in its demand type, if it has a demand type at all (i.e., if demand analysis already happened). 2. Check that top-level or recursive binders aren't demanded. --- compiler/basicTypes/Id.lhs | 16 +++++++++++- compiler/coreSyn/CoreLint.lhs | 56 +++++++++++++++++++++++++++++++++-------- 2 files changed, 60 insertions(+), 12 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 549a58b..61a39f1 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -25,7 +25,7 @@ module Id ( zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, -- Predicates - isImplicitId, isDeadBinder, isDictId, + isImplicitId, isDeadBinder, isDictId, isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, isClassOpId_maybe, @@ -368,6 +368,20 @@ setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id zapIdNewStrictness :: Id -> Id zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id +\end{code} + +This predicate says whether the id has a strict demand placed on it or +has a type such that it can always be evaluated strictly (e.g., an +unlifted type, but see the comment for isStrictType). We need to +check separately whether has a so-called "strict type" because if +the demand for hasn't been computed yet but has a strict +type, we still want (isStrictId ) to be True. +\begin{code} +isStrictId :: Id -> Bool +isStrictId id + = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + (isStrictDmd (idNewDemandInfo id)) || + (isStrictType (idType id)) --------------------------------- -- WORKER ID diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 59c52da..2139e9c 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -14,6 +14,7 @@ module CoreLint ( #include "HsVersions.h" +import NewDemand import CoreSyn import CoreFVs import CoreUtils @@ -25,6 +26,7 @@ import Var import VarEnv import VarSet import Name +import Id import PprCore import ErrUtils import SrcLoc @@ -175,8 +177,8 @@ lintCoreBindings dflags whoDunnit binds lint_binds binds = 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 ++ " ***"), @@ -217,7 +219,7 @@ lintUnfolding locn vars expr Check a core binding, returning the list of variables bound. \begin{code} -lintSingleBinding rec_flag (binder,rhs) +lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs do { ty <- lintCoreExpr rhs @@ -228,14 +230,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} @@ -283,13 +297,13 @@ lintCoreExpr (Note other_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 @@ -562,7 +576,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') } @@ -871,6 +885,26 @@ mkRhsPrimMsg binder rhs 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 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], -- 1.7.10.4