[commit: ghc] master: Allow a longer demand signature than arity (848f595)
git at git.haskell.org
git at git.haskell.org
Tue Apr 8 16:38:18 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/848f595266268f578480ceb4ab1ce4938611c97e/ghc
>---------------------------------------------------------------
commit 848f595266268f578480ceb4ab1ce4938611c97e
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Apr 8 16:20:11 2014 +0100
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.
>---------------------------------------------------------------
848f595266268f578480ceb4ab1ce4938611c97e
compiler/coreSyn/CoreLint.lhs | 15 +++++++++------
compiler/simplCore/SimplUtils.lhs | 5 ++---
compiler/stranal/DmdAnal.lhs | 18 +++++++++++++-----
3 files changed, 24 insertions(+), 14 deletions(-)
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 836164e..b5c7985 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 ad12d7e..bde7b6b 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 3294371..72137c7 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,16 +646,24 @@ 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.
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This example comes from shootout/binary_trees:
More information about the ghc-commits
mailing list