Commit 50b8745f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Extend eta reduction to work with casted arguments

See Trac #4201, and 
Note [Eta reduction with casted arguments]

Thanks to Louis Wasserman for suggesting this, and
implementing an early version of the patch
parent d108044b
......@@ -1231,18 +1231,55 @@ There are some particularly delicate points here:
These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
Alas.
Note [Eta reduction with casted arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
(\(x:t3). f (x |> g)) :: t3 -> t2
where
f :: t1 -> t2
g :: t3 ~ t1
This should be eta-reduced to
f |> (sym g -> t2)
So we need to accumulate a coercion, pushing it inward (past
variable arguments only) thus:
f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x
f (x:t) |> co --> (f |> (t -> co)) x
f @ a |> co --> (f |> (forall a.co)) @ a
f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2)
These are the equations for ok_arg.
It's true that we could also hope to eta reduce these:
(\xy. (f x |> g) y)
(\xy. (f x y) |> g)
But the simplifier pushes those casts outwards, so we don't
need to address that here.
\begin{code}
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs body
= go (reverse bndrs) body
= go (reverse bndrs) body (IdCo (exprType body))
where
incoming_arity = count isId bndrs
go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
go [] fun | ok_fun fun = Just fun -- Success!
go _ _ = Nothing -- Failure!
go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
-> CoreExpr -- Of type tr
-> CoercionI -- Of type tr ~ ts
-> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
-- See Note [Eta reduction with casted arguments]
-- for why we have an accumulating coercion
go [] fun co
| ok_fun fun = Just (mkCoerceI co fun)
go (b : bs) (App fun arg) co
| Just co' <- ok_arg b arg co
= go bs fun co'
-- Note [Eta reduction conditions]
go _ _ _ = Nothing -- Failure!
---------------
-- Note [Eta reduction conditions]
ok_fun (App fun (Type ty))
| not (any (`elemVarSet` tyVarsOfType ty) bndrs)
= ok_fun fun
......@@ -1251,17 +1288,37 @@ tryEtaReduce bndrs body
&& (ok_fun_id fun_id || all ok_lam bndrs)
ok_fun _fun = False
---------------
ok_fun_id fun = fun_arity fun >= incoming_arity
---------------
fun_arity fun -- See Note [Arity care]
| isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
| otherwise = idArity fun
---------------
ok_lam v = isTyCoVar v || isDictId v
ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
---------------
ok_arg :: Var -- Of type bndr_t
-> CoreExpr -- Of type arg_t
-> CoercionI -- Of kind (t1~t2)
-> Maybe CoercionI -- Of type (arg_t -> t1 ~ bndr_t -> t2)
-- (and similarly for tyvars, coercion args)
-- See Note [Eta reduction with casted arguments]
ok_arg bndr (Type ty) co
| Just tv <- getTyVar_maybe ty
, bndr == tv = Just (mkForAllTyCoI tv co)
ok_arg bndr (Var v) co
| bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co)
ok_arg bndr (Cast (Var v) co_arg) co
| bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg _ _ _ = Nothing
\end{code}
%************************************************************************
%* *
\subsection{Determining non-updatable right-hand-sides}
......
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