Commit b8abb31f authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Fix Trac #5475: another bug in exprArity

As usual it was to do with the handling of bottoms,
but this time it wasn't terribly subtle; I was using
andArityType (which is designed for case branches) as
a cheap short cut for the arity trimming needed with
a cast.  That did the Wrong Thing for bottoming
expressions.  Sigh.
parent f647fd53
......@@ -139,15 +139,15 @@ Note [exprArity invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~
exprArity has the following invariant:
* If typeArity (exprType e) = n,
(1) If typeArity (exprType e) = n,
then manifestArity (etaExpand e n) = n
That is, etaExpand can always expand as much as typeArity says
So the case analysis in etaExpand and in typeArity must match
* exprArity e <= typeArity (exprType e)
(2) exprArity e <= typeArity (exprType e)
* Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n
(3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n
That is, if exprArity says "the arity is n" then etaExpand really
can get "n" manifest lambdas to the top.
......@@ -561,12 +561,17 @@ type CheapFun = CoreExpr -> Maybe Type -> Bool
arityType :: CheapFun -> CoreExpr -> ArityType
arityType cheap_fn (Cast e co)
= arityType cheap_fn e
`andArityType` ATop (typeArity (pSnd (coercionKind co)))
-- See Note [exprArity invariant]; must be true of
= case arityType cheap_fn e of
ATop os -> ATop (take co_arity os)
ABot n -> ABot (n `min` co_arity)
where
co_arity = length (typeArity (pSnd (coercionKind co)))
-- See Note [exprArity invariant] (2); must be true of
-- arityType too, since that is how we compute the arity
-- of variables, and they in turn affect result of exprArity
-- Trac #5441 is a nice demo
-- However, do make sure that ATop -> ATop and ABot -> ABot!
-- Casts don't affect that part. Getting this wrong provoked #5475
arityType _ (Var v)
| Just strict_sig <- idStrictness_maybe v
......
......@@ -1181,7 +1181,7 @@ findArity dicts_cheap bndr rhs old_arity
init_cheap_app :: CheapAppFun
init_cheap_app fn n_val_args
| fn == bndr = True
| fn == bndr = True -- On the first pass, this binder gets infinite arity
| otherwise = isCheapApp fn n_val_args
mk_cheap_fn :: Bool -> CheapAppFun -> CheapFun
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment