Commit a27b2985 authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Use exprIsLambda_maybe in match

when matching a lambda in the template against an expression. When
matching, look through coercions (only for value lambdas for now), and
look through currently active unfoldings, if these are undersaturated,
i.e. produce a lambda.

This replaces the existing, somewhat fishy eta-expansion.
parent 377672ae
......@@ -40,7 +40,7 @@ module CoreSubst (
-- ** Simple expression optimiser
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
exprIsConApp_maybe, exprIsLiteral_maybe
exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
) where
#include "HsVersions.h"
......@@ -1300,4 +1300,78 @@ exprIsLiteral_maybe env@(_, id_unf) e
Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
-> exprIsLiteral_maybe env rhs
_ -> Nothing
\end{code}
\end{code}
Note [exprIsLiteral_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~
This function will, given an expression `e`, try to turn it into the form
`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
casts (using the Push rule), and it unfoldes function calls if the unfolding
has a greater arity than arguments are present.
Currently, it is used in Rules.match, and is required to make
"map coerce = coerce" match.
\begin{code}
-- See Note [exprIsLiteral_maybe]
exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr)
-- The simpe case: It is a lambda
exprIsLambda_maybe _ (Lam x e)
= Just (x, e)
-- Also possible: A casted lambda. Push the coercion insinde
exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
| Just (x, e) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
-- Only do value lambdas.
-- this implies that x is not in scope in gamma (makes this code simpler)
, not (isTyVar x) && not (isCoVar x)
, ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
, let res = pushCoercionIntoLambda in_scope_set x e co
= -- pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e, ppr co, ppr res])
res
-- Another attempt: See if we find a partial unfolding
exprIsLambda_maybe (in_scope_set, id_unf) e
| (Var f, as) <- collectArgs e
, let unfolding = id_unf f
, Just rhs <- expandUnfolding_maybe unfolding
-- Make sure there is hope to get a lamda
, unfoldingArity unfolding > length (filter isValArg as)
-- Optimize, for beta-reduction
, let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
, Just (x', e'') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
, let res = Just (x', e'')
= -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr res])
res
exprIsLambda_maybe _ _e
= -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
Nothing
pushCoercionIntoLambda
:: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)
pushCoercionIntoLambda in_scope x e co
-- This implements the Push rule from the paper on coercions
-- Compare with simplCast in Simplify
| ASSERT (not (isTyVar x) && not (isCoVar x)) True
, Pair s1s2 t1t2 <- coercionKind co
, Just (_s1,_s2) <- splitFunTy_maybe s1s2
, Just (t1,_t2) <- splitFunTy_maybe t1t2
= let [co1, co2] = decomposeCo 2 co
-- Should we optimize the coercions here?
-- Otherwise they might not match too well
x' = x `setIdType` t1
in_scope' = in_scope `extendInScopeSet` x'
subst = extendIdSubst (mkEmptySubst in_scope')
x
(mkCast (Var x') co1)
in Just (x', subst_expr subst e `mkCast` co2)
| otherwise
= pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
Nothing
\end{code}
......@@ -578,6 +578,9 @@ data RuleMatchEnv
, rv_unf :: IdUnfoldingFun
}
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)
data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the
, rs_id_subst :: IdSubstEnv -- template variables
, rs_binds :: BindWrapper -- Floated bindings
......@@ -638,7 +641,8 @@ match renv subst e1 (Var v2) -- Note [Expanding variables]
-- because of the not-inRnEnvR
match renv subst e1 (Let bind e2)
| okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]
| -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $
okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]
= match (renv { rv_fltR = flt_subst' })
(subst { rs_binds = rs_binds subst . Let bind'
, rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })
......@@ -671,23 +675,11 @@ match renv subst (App f1 a1) (App f2 a2)
= do { subst' <- match renv subst f1 f2
; match renv subst' a1 a2 }
match renv subst (Lam x1 e1) (Lam x2 e2)
= match renv' subst e1 e2
where
renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
, rv_fltR = delBndr (rv_fltR renv) x2 }
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
-- It's important that this is *after* the let rule,
-- so that (\x.M) ~ (let y = e in \y.N)
-- does the let thing, and then gets the lam/lam rule above
-- See Note [Eta expansion in match]
match renv subst (Lam x1 e1) e2
= match renv' subst e1 (App e2 (varToCoreExpr new_x))
where
(rn_env', new_x) = rnEtaL (rv_lcl renv) x1
renv' = renv { rv_lcl = rn_env' }
| Just (x2, e2) <- exprIsLambda_maybe (rvInScopeEnv renv) e2
= let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
, rv_fltR = delBndr (rv_fltR renv) x2 }
in match renv' subst e1 e2
-- Eta expansion the other way
-- M ~ (\y.N) iff M y ~ N
......@@ -1018,23 +1010,6 @@ at all.
That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
is so important.
Note [Eta expansion in match]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At a first glance, this (eta-expansion of the thing to match if the template
contains a lambda) might waste work. For example
{-# RULES "f/expand" forall n. f (\x -> foo n x) = \x -> foo n x #-}
(for a non-inlined "f = id") will turn
go n = app (f (foo n))
into
go n = app (\x -> foo n x)
and if foo had arity 1 and app calls its argument many times, are wasting work.
In practice this does not occur (or at least I could not tickle this "bug")
because CSE turns it back into
go n = let lvl = foo n in app (\x -> lvl x)
which is fine.
%************************************************************************
%* *
......
......@@ -51,7 +51,7 @@ test('T5453', normal, compile_and_run, [''])
test('T5441', extra_clean(['T5441a.o','T5441a.hi']),
multimod_compile_and_run, ['T5441',''])
test('T5603', normal, compile_and_run, [''])
test('T2110', expect_broken(2110), compile_and_run, [''])
test('T2110', normal, compile_and_run, [''])
# Run these tests *without* optimisation too
test('T5625', [ only_ways(['normal','optasm']), exit_code(1) ], compile_and_run, [''])
......
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