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.

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"
@@ -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}

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.
-
-
 
 %************************************************************************
 %*                                                                      *

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, [''])