diff options
| -rw-r--r-- | compiler/coreSyn/CoreSubst.lhs | 78 | ||||
| -rw-r--r-- | compiler/specialise/Rules.lhs | 43 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 2 |
3 files changed, 86 insertions, 37 deletions
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 20394f2bc0..7dfa25f146 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" @@ -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} diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 4753e8ff36..c85bc06990 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 6f5751e84b..fa11dc542f 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, ['']) |