[commit: ghc] master: Use exprIsLambda_maybe in match (a27b298)
git at git.haskell.org
git at git.haskell.org
Tue Feb 11 15:40:37 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/a27b2985511800fa3b740fef82ad3da9c8683302/ghc
>---------------------------------------------------------------
commit a27b2985511800fa3b740fef82ad3da9c8683302
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Tue Feb 11 10:42:50 2014 +0000
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.
>---------------------------------------------------------------
a27b2985511800fa3b740fef82ad3da9c8683302
compiler/coreSyn/CoreSubst.lhs | 76 +++++++++++++++++++++++++++-
compiler/specialise/Rules.lhs | 43 ++++------------
testsuite/tests/simplCore/should_run/all.T | 2 +-
3 files changed, 85 insertions(+), 36 deletions(-)
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 20394f2..7dfa25f 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -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"
@@ -1301,3 +1301,77 @@ exprIsLiteral_maybe env@(_, id_unf) e
-> exprIsLiteral_maybe env rhs
_ -> Nothing
\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}
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 4753e8f..c85bc06 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -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.
-
-
%************************************************************************
%* *
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 6f5751e..fa11dc5 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -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, [''])
More information about the ghc-commits
mailing list