diff options
Diffstat (limited to 'compiler/GHC/CoreToStg/Prep.hs')
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 82 |
1 files changed, 22 insertions, 60 deletions
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 63aeba48ca..045d580a2a 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -36,7 +36,6 @@ import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Core.Utils import GHC.Core.Opt.Arity -import GHC.Core.FVs import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Core @@ -64,7 +63,6 @@ import GHC.Utils.Trace import GHC.Types.Demand import GHC.Types.Var -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info @@ -781,7 +779,7 @@ cpeRhsE env expr@(Lit (LitNumber nt i)) Just e -> cpeRhsE env e cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr -cpeRhsE env expr@(App {}) = cpeApp env expr +cpeRhsE env expr@(App {}) = cpeApp env expr cpeRhsE env (Let bind body) = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind @@ -916,9 +914,7 @@ rhsToBody (Cast e co) = do { (floats, e') <- rhsToBody e ; return (floats, Cast e' co) } -rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) +rhsToBody expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) | otherwise -- Some value lambdas @@ -927,11 +923,29 @@ rhsToBody expr@(Lam {}) ; let float = FloatLet (NonRec fn rhs) ; return (unitFloat float, Var fn) } where - (bndrs,body) = collectBinders expr + (bndrs,_) = collectBinders expr rhsToBody expr = return (emptyFloats, expr) +{- Note [No eta reduction needed in rhsToBody] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Historical note. In the olden days we used to have a Prep-specific +eta-reduction step in rhsToBody: + rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + +The goal was to reduce + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } + +to avoid allocating a lambda. Of course, we'd allocate a PAP +instead, which is hardly better, but that's the way it was. + +Now we simply don't bother with this. It doesn't seem to be a win, +and it's extra work. +-} -- --------------------------------------------------------------------------- -- CpeApp: produces a result satisfying CpeApp @@ -1581,7 +1595,7 @@ the simplifier only when there at least one lambda already. NB1:we could refrain when the RHS is trivial (which can happen for exported things). This would reduce the amount of code - generated (a little) and make things a little words for + generated (a little) and make things a little worse for code compiled without -O. The case in point is data constructor wrappers. @@ -1615,58 +1629,6 @@ cpeEtaExpand arity expr | otherwise = etaExpand arity expr {- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Why try eta reduction? Hasn't the simplifier already done eta? -But the simplifier only eta reduces if that leaves something -trivial (like f, or f Int). But for deLam it would be enough to -get to a partial application: - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } --} - --- When updating this function, make sure it lines up with --- GHC.Core.Utils.tryEtaReduce! -tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f - , n_remaining >= 0 - , and (zipWith ok bndrs last_args) - , not (any (`elemVarSet` fvs_remaining) bndrs) - , exprIsHNF remaining_expr -- Don't turn value into a non-value - -- else the behaviour with 'seq' changes - = - -- pprTrace "prep-reduce" (vcat - -- [ text "reduced:" <+> ppr expr - -- , text "from" <+> ppr (length args) <+> text "to" <+> ppr n_remaining - -- , (case f of Var v -> text "has strict worker:" <+> ppr (idCbvMarkArity v) <+> ppr n_remaining_vals; _ -> empty) - -- , ppr remaining_args - -- ]) $ - Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - n_remaining_vals = length $ filter isRuntimeArg remaining_args - - ok bndr (Var arg) = bndr == arg - ok _ _ = False - - ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals - ok_to_eta_reduce _ = False -- Safe. ToDo: generalise - - -tryEtaReducePrep bndrs (Tick tickish e) - | tickishFloatable tickish - = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e - -tryEtaReducePrep _ _ = Nothing - -{- ************************************************************************ * * Floats |