From 848f595266268f578480ceb4ab1ce4938611c97e Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 8 Apr 2014 16:20:11 +0100 Subject: Allow a longer demand signature than arity See Note [Demand analysis for trivial right-hand sides] in DmdAnal. This allows a function with arity 2 to have a DmdSig with 3 args; which in turn had a knock-on effect, which showed up in the test for Trac #8963. In fact it seems entirely reasonable, so this patch removes the WARN and CoreLint checks that were complaining. --- compiler/coreSyn/CoreLint.lhs | 15 +++++++++------ compiler/simplCore/SimplUtils.lhs | 5 ++--- compiler/stranal/DmdAnal.lhs | 20 ++++++++++++++------ 3 files changed, 25 insertions(+), 15 deletions(-) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 836164e0ce..b5c79855f2 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -19,7 +19,6 @@ module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where #include "HsVersions.h" -import Demand import CoreSyn import CoreFVs import CoreUtils @@ -239,9 +238,13 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check whether arity and demand type are consistent (only if demand analysis -- already happened) - ; checkL (case dmdTy of - StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) - (mkArityMsg binder) + -- + -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] + -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. + -- ; let dmdTy = idStrictness binder + -- ; checkL (case dmdTy of + -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) + -- (mkArityMsg binder) ; lintIdUnfolding binder binder_ty (idUnfolding binder) } @@ -249,7 +252,6 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- the unfolding is a SimplifiableCoreExpr. Give up for now. where binder_ty = idType binder - dmdTy = idStrictness binder bndr_vars = varSetElems (idFreeVars binder) -- If you edit this function, you may need to update the GHC formalism @@ -1421,6 +1423,7 @@ mkKindErrMsg tyvar arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] +{- Not needed now mkArityMsg :: Id -> MsgDoc mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has"), @@ -1433,7 +1436,7 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder - +-} mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr co from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index ad12d7ec82..bde7b6bacc 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1195,9 +1195,9 @@ tryEtaExpandRhs env bndr rhs = do { dflags <- getDynFlags ; (new_arity, new_rhs) <- try_expand dflags - ; WARN( new_arity < old_arity || new_arity < _dmd_arity, + ; WARN( new_arity < old_arity, (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity - <+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) ) + <+> ppr new_arity) $$ ppr new_rhs) ) -- Note [Arity decrease] return (new_arity, new_rhs) } where @@ -1217,7 +1217,6 @@ tryEtaExpandRhs env bndr rhs manifest_arity = manifestArity rhs old_arity = idArity bndr - _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr \end{code} Note [Eta-expanding at let bindings] diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 3294371964..72137c7b4b 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -593,7 +593,7 @@ dmdAnalRhs :: TopLevelFlag -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. dmdAnalRhs top_lvl rec_flag env id rhs - | Just fn <- unpackTrivial rhs -- See Note [Trivial right-hand sides] + | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides] , let fn_str = getStrictness env fn = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs) @@ -638,7 +638,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs unpackTrivial :: CoreExpr -> Maybe Id -- Returns (Just v) if the arg is really equal to v, modulo -- casts, type applications etc --- See Note [Trivial right-hand sides] +-- See Note [Demand analysis for trivial right-hand sides] unpackTrivial (Var v) = Just v unpackTrivial (Cast e _) = unpackTrivial e unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e @@ -646,15 +646,23 @@ unpackTrivial (App e a) | isTypeArg a = unpackTrivial e unpackTrivial _ = Nothing \end{code} -Note [Trivial right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider foo = plusInt |> co where plusInt is an arity-2 function with known strictness. Clearly we want plusInt's strictness to propagate to foo! But because it has -no manifest lambdas, it won't do so automatically. So we have a +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T, so we *can't* eta-expand. So we have a special case for right-hand sides that are "trivial", namely variables, -casts, type applications, and the like. +casts, type applications, and the like. + +Note that this can mean that 'foo' has an arity that is smaller than that +indicated by its demand info. e.g. if co :: (Int->Int->Int) ~ T, then +foo's arity will be zero (see Note [exprArity invariant] in CoreArity), +but its demand signature will be that of plusInt. A small example is the +test case of Trac #8963. + Note [Product demands for function body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- cgit v1.2.1