From: simonpj Date: Thu, 7 Dec 2000 09:28:43 +0000 (+0000) Subject: [project @ 2000-12-07 09:28:42 by simonpj] X-Git-Tag: Approximately_9120_patches~3177 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0b62f53e6da34769aa1bf8409d9987a5311bb516;p=ghc-hetmet.git [project @ 2000-12-07 09:28:42 by simonpj] Do a better job of eta expansion. This showed up in one of Manuel's programs, where he got code like: $wsimpleGen ww (\ i :: Int -> case i of wild1 { I# i# -> case w of wild2 { I# e# -> __coerce (ST RealWorld ()) (\ s# :: (State# RealWorld) -> case writeIntArray# @ RealWorld mba# i# e# s# of s2#1 { __DEFAULT -> (# s2#1, () #) }) } }) s2# The argument wasn't eta expanded, so it got right through to the code generator as two separte lambdas. Needless to say, I fiddled around with things in a vain attempt to tidy them up. Yell if anything seems to go wrong, or perfomance drops on any programs. --- diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 4f56474..a24a4c1 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -11,7 +11,7 @@ module UniqSupply ( uniqFromSupply, uniqsFromSupply, -- basic ops UniqSM, -- type: unique supply monad - initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, setUs, + initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, withUs, getUniqueUs, getUniquesUs, mapUs, mapAndUnzipUs, mapAndUnzip3Us, thenMaybeUs, mapAccumLUs, @@ -24,8 +24,6 @@ module UniqSupply ( #include "HsVersions.h" import Unique -import Panic ( panic ) - import GlaExts #if __GLASGOW_HASKELL__ < 301 @@ -149,11 +147,11 @@ thenUs_ expr cont us returnUs :: a -> UniqSM a returnUs result us = (result, us) +withUs :: (UniqSupply -> (a, UniqSupply)) -> UniqSM a +withUs f us = f us -- Ha ha! + getUs :: UniqSM UniqSupply -getUs us = (us, panic "getUs: bad supply") - -setUs :: UniqSupply -> UniqSM () -setUs us old_us = ((), us) +getUs us = splitUniqSupply us getUniqueUs :: UniqSM Unique getUniqueUs us = case splitUniqSupply us of diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs index 56c319e..acd0a4e 100644 --- a/ghc/compiler/coreSyn/CoreSat.lhs +++ b/ghc/compiler/coreSyn/CoreSat.lhs @@ -300,44 +300,14 @@ cloneTyVar tv maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr maybeSaturate fn expr n_args ty = case idFlavour fn of - PrimOpId op -> saturate fn expr n_args ty - DataConId dc -> saturate fn expr n_args ty + PrimOpId op -> saturate_it + DataConId dc -> saturate_it other -> returnUs expr - -saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr - -- The type should be the type of expr. - -- The returned expression should also have this type -saturate fn expr n_args ty - = go excess_arity expr ty where fn_arity = idArity fn excess_arity = fn_arity - n_args - - go n expr ty - | n == 0 -- Saturated, so nothing to do - = returnUs expr - - | otherwise -- An unsaturated constructor or primop; eta expand it - = case splitForAllTy_maybe ty of { - Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' -> - returnUs (Lam tv expr') ; - Nothing -> - - case splitFunTy_maybe ty of { - Just (arg_ty, res_ty) - -> newVar arg_ty `thenUs` \ arg' -> - go (n-1) (App expr (Var arg')) res_ty `thenUs` \ expr' -> - returnUs (Lam arg' expr') ; - Nothing -> - - case splitNewType_maybe ty of { - Just ty' -> go n (mkCoerce ty' ty expr) ty' `thenUs` \ expr' -> - returnUs (mkCoerce ty ty' expr') ; - - Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty) - returnUs expr - }}} - + saturate_it = getUs `thenUs` \ us -> + returnUs (etaExpand excess_arity us expr ty) fiddleCCall id = case idFlavour id of diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 0bf8f9b..729b54f 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -19,8 +19,8 @@ module CoreUtils ( exprArity, -- Expr transformation - etaReduce, exprEtaExpandArity, --- etaExpandExpr, + etaReduce, etaExpand, + exprArity, exprEtaExpandArity, -- Size coreBindsSize, @@ -50,17 +50,19 @@ import PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable ) import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, - isDataConId_maybe, isPrimOpId_maybe + isDataConId_maybe, isPrimOpId_maybe, mkSysLocal ) import IdInfo ( LBVarInfo(..), IdFlavour(..), megaSeqIdInfo ) import Demand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, - applyTys, isUnLiftedType, seqType, mkUTy + applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, + splitForAllTy_maybe, splitNewType_maybe ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) +import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) import Maybes ( maybeToBool ) import Outputable import TysPrim ( alphaTy ) -- Debugging only @@ -509,6 +511,7 @@ exprArity (Note _ e) exprArity _ = 0 \end{code} + %************************************************************************ %* * \subsection{Eta reduction and expansion} @@ -550,8 +553,13 @@ etaReduce expr = expr -- The common case \begin{code} -exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to - -- without doing much work +exprEtaExpandArity :: CoreExpr -> (Int, Bool) +-- The Int is number of value args the thing can be +-- applied to without doing much work +-- The Bool is True iff there are enough explicit value lambdas +-- at the top to make this arity apparent +-- (but ignore it when arity==0) + -- This is used when eta expanding -- e ==> \xy -> e x y -- @@ -562,20 +570,27 @@ exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be ap -- Hence "generous" arity exprEtaExpandArity e - = go e `max` 0 -- Never go -ve! + = go 0 e where - go (Var v) = idArity v - go (App f (Type _)) = go f - go (App f a) | exprIsCheap a = go f - 1 - go (Lam x e) | isId x = go e + 1 - | otherwise = go e - go (Note n e) | ok_note n = go e - go (Case scrut _ alts) - | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts] - go (Let b e) - | all exprIsCheap (rhssOfBind b) = go e + go ar (Lam x e) | isId x = go (ar+1) e + | otherwise = go ar e + go ar (Note n e) | ok_note n = go ar e + go ar other = (ar + ar', ar' == 0) + where + ar' = go1 other `max` 0 + + go1 (Var v) = idArity v + go1 (Lam x e) | isId x = go1 e + 1 + | otherwise = go1 e + go1 (Note n e) | ok_note n = go1 e + go1 (App f (Type _)) = go1 f + go1 (App f a) | exprIsCheap a = go1 f - 1 + go1 (Case scrut _ alts) + | exprIsCheap scrut = min_zero [go1 rhs | (_,_,rhs) <- alts] + go1 (Let b e) + | all exprIsCheap (rhssOfBind b) = go1 e - go other = 0 + go1 other = 0 ok_note (Coerce _ _) = True ok_note InlineCall = True @@ -601,11 +616,13 @@ min_zero (x:xs) = go x xs \end{code} -\begin{pseudocode} +\begin{code} etaExpand :: Int -- Add this number of value args - -> UniquSupply + -> UniqSupply -> CoreExpr -> Type -- Expression and its type - -> CoreEpxr + -> CoreExpr +-- (etaExpand n us e ty) returns an expression with +-- the same meaning as 'e', but with arity 'n'. -- Given e' = etaExpand n us e ty -- We should have @@ -629,23 +646,23 @@ etaExpand n us expr ty = case splitForAllTy_maybe ty of { Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty') - Nothing -> + ; Nothing -> case splitFunTy_maybe ty of { - Just (arg_ty, res_ty) -> Lam arg' (etaExpand (n-1) us2 (App expr (Var arg')) res_ty) + Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty) where - arg' = mkSysLocal SLIT("eta") uniq arg_ty - (us1, us2) = splitUnqiSupply us - uniq = uniqFromSupply us1 + arg1 = mkSysLocal SLIT("eta") uniq arg_ty + (us1, us2) = splitUniqSupply us + uniq = uniqFromSupply us1 - Nothing -> + ; Nothing -> case splitNewType_maybe ty of { - Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') + Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr }}} -\end{pseudocode} +\end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index c120e49..9978ab2 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -7,7 +7,7 @@ module SimplMonad ( InId, InBind, InExpr, InAlt, InArg, InType, InBinder, OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - OutExprStuff, OutStuff, + OutExprStuff, OutStuff, returnOutStuff, -- The monad SimplM, @@ -19,7 +19,7 @@ module SimplMonad ( setBlackList, getBlackList, noInlineBlackList, -- Unique supply - getUniqueSmpl, getUniquesSmpl, + getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId, newIds, -- Counting @@ -44,7 +44,7 @@ module SimplMonad ( -- Adding bindings addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds, - addCaseBind, needsCaseBinding, addNonRecBind + addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats ) where #include "HsVersions.h" @@ -58,6 +58,7 @@ import CostCentre ( CostCentreStack, subsumedCCS ) import OccName ( UserFS ) import VarEnv import VarSet +import OrdList import qualified Subst import Subst ( Subst, mkSubst, substEnv, InScopeSet, mkInScopeSet, substInScope @@ -105,23 +106,35 @@ type OutArg = CoreArg type SwitchChecker = SimplifierSwitch -> SwitchResult -type OutExprStuff = OutStuff (InScopeSet, OutExpr) -type OutStuff a = ([OutBind], a) +type OutExprStuff = OutStuff OutExpr +type OutStuff a = (OrdList OutBind, (InScopeSet, a)) -- We return something equivalent to (let b in e), but -- in pieces to avoid the quadratic blowup when floating -- incrementally. Comments just before simplExprB in Simplify.lhs \end{code} \begin{code} +wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr +wrapFloats binds body = foldOL Let body binds + +returnOutStuff :: a -> SimplM (OutStuff a) +returnOutStuff x = getInScope `thenSmpl` \ in_scope -> + returnSmpl (nilOL, (in_scope, x)) + +addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a) +addFloats floats in_scope thing_inside + = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) -> + returnSmpl (floats `appOL` binds, res) + addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a) addLetBind bind thing_inside = thing_inside `thenSmpl` \ (binds, res) -> - returnSmpl (bind : binds, res) + returnSmpl (bind `consOL` binds, res) addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a) addLetBinds binds1 thing_inside = thing_inside `thenSmpl` \ (binds2, res) -> - returnSmpl (binds1 ++ binds2, res) + returnSmpl (toOL binds1 `appOL` binds2, res) addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a) -- Extends the in-scope environment as well as wrapping the bindings @@ -141,9 +154,8 @@ needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) -- or from beta reductions: (\x.e) (x +# y) addCaseBind bndr rhs thing_inside - = getInScope `thenSmpl` \ in_scope -> - thing_inside `thenSmpl` \ (floats, (_, body)) -> - returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)])) + = thing_inside `thenSmpl` \ (floats, (_, body)) -> + returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)]) addNonRecBind bndr rhs thing_inside -- Checks for needing a case binding @@ -261,6 +273,11 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> %************************************************************************ \begin{code} +getUniqSupplySmpl :: SimplM UniqSupply +getUniqSupplySmpl dflags env us sc + = case splitUniqSupply us of + (us1, us2) -> (us1, us2, sc) + getUniqueSmpl :: SimplM Unique getUniqueSmpl dflags env us sc = case splitUniqSupply us of @@ -429,7 +446,7 @@ data Tick | UnfoldingDone Id | RuleFired FAST_STRING -- Rule name - | LetFloatFromLet Id -- Thing floated out + | LetFloatFromLet | EtaExpansion Id -- LHS binder | EtaReduction Id -- Binder on outer lambda | BetaReduction Id -- Lambda binder @@ -462,7 +479,7 @@ tickToTag (PreInlineUnconditionally _) = 0 tickToTag (PostInlineUnconditionally _) = 1 tickToTag (UnfoldingDone _) = 2 tickToTag (RuleFired _) = 3 -tickToTag (LetFloatFromLet _) = 4 +tickToTag LetFloatFromLet = 4 tickToTag (EtaExpansion _) = 5 tickToTag (EtaReduction _) = 6 tickToTag (BetaReduction _) = 7 @@ -480,7 +497,7 @@ tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" tickString (UnfoldingDone _) = "UnfoldingDone" tickString (RuleFired _) = "RuleFired" -tickString (LetFloatFromLet _) = "LetFloatFromLet" +tickString LetFloatFromLet = "LetFloatFromLet" tickString (EtaExpansion _) = "EtaExpansion" tickString (EtaReduction _) = "EtaReduction" tickString (BetaReduction _) = "BetaReduction" @@ -498,7 +515,7 @@ pprTickCts (PreInlineUnconditionally v) = ppr v pprTickCts (PostInlineUnconditionally v)= ppr v pprTickCts (UnfoldingDone v) = ppr v pprTickCts (RuleFired v) = ppr v -pprTickCts (LetFloatFromLet v) = ppr v +pprTickCts LetFloatFromLet = empty pprTickCts (EtaExpansion v) = ppr v pprTickCts (EtaReduction v) = ppr v pprTickCts (BetaReduction v) = ppr v @@ -524,7 +541,6 @@ cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b -cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index fc9cd21..dd1f86a 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -6,7 +6,7 @@ \begin{code} module SimplUtils ( simplBinder, simplBinders, simplIds, - transformRhs, + tryRhsTyLam, tryEtaExpansion, mkCase, findAlt, findDefault, -- The continuation type @@ -23,19 +23,19 @@ import CmdLineOpts ( switchIsOn, SimplifierSwitch(..), opt_UF_UpdateInPlace ) import CoreSyn -import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec ) +import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, etaExpand, exprEtaExpandArity, bindNonRec ) import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr ) import Id ( idType, idName, idUnfolding, idStrictness, mkVanillaId, idInfo ) -import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity ) +import IdInfo ( StrictnessInfo(..) ) import Maybes ( maybeToBool, catMaybes ) import Name ( setNameUnique ) import Demand ( isStrict ) import SimplMonad import Type ( Type, mkForAllTys, seqType, repType, - splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, splitFunTys, + splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, isDictTy, isDataType, isUnLiftedType, splitRepFunTys ) @@ -464,26 +464,6 @@ seqBndr b | isTyVar b = b `seq` () %************************************************************************ %* * -\subsection{Transform a RHS} -%* * -%************************************************************************ - -Try (a) eta expansion - (b) type-lambda swizzling - -\begin{code} -transformRhs :: OutExpr - -> (ArityInfo -> OutExpr -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) - -transformRhs rhs thing_inside - = tryRhsTyLam rhs $ \ rhs1 -> - tryEtaExpansion rhs1 thing_inside -\end{code} - - -%************************************************************************ -%* * \subsection{Local tyvar-lifting} %* * %************************************************************************ @@ -553,12 +533,15 @@ as we would normally do. \begin{code} -tryRhsTyLam rhs thing_inside -- Only does something if there's a let +tryRhsTyLam :: OutExpr -> SimplM ([OutBind], OutExpr) + +tryRhsTyLam rhs -- Only does something if there's a let | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that - = thing_inside rhs + = returnSmpl ([], rhs) + | otherwise - = go (\x -> x) body $ \ body' -> - thing_inside (mkLams tyvars body') + = go (\x -> x) body `thenSmpl` \ (binds, body') -> + returnSmpl (binds, mkLams tyvars body') where (tyvars, body) = collectTyBinders rhs @@ -568,15 +551,14 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let whnf_in_middle (Let _ e) = whnf_in_middle e whnf_in_middle e = exprIsCheap e - - go fn (Let bind@(NonRec var rhs) body) thing_inside + go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs - = go (fn . Let bind) body thing_inside + = go (fn . Let bind) body - go fn (Let bind@(NonRec var rhs) body) thing_inside - = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') -> - addAuxiliaryBind (NonRec var' (mkLams tyvars_here (fn rhs))) $ - go (fn . Let (mk_silly_bind var rhs')) body thing_inside + go fn (Let (NonRec var rhs) body) + = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') -> + go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ (binds, body') -> + returnSmpl (NonRec var' (mkLams tyvars_here (fn rhs)) : binds, body') where tyvars_here = tyvars @@ -599,13 +581,14 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let -- abstracting wrt *all* the tyvars. We'll see if that -- gives rise to problems. SLPJ June 98 - go fn (Let (Rec prs) body) thing_inside + go fn (Let (Rec prs) body) = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') -> let - gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss')) + gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss')) + new_bind = Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]) in - addAuxiliaryBind (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) $ - go gn body thing_inside + go gn body `thenSmpl` \ (binds, body') -> + returnSmpl (new_bind : binds, body') where (vars,rhss) = unzip prs tyvars_here = tyvars @@ -613,8 +596,7 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let -- var_tys = map idType vars -- See notes with tyvars_here above - - go fn body thing_inside = thing_inside (fn body) + go fn body = returnSmpl ([], fn body) mk_poly tyvars_here var = getUniqueSmpl `thenSmpl` \ uniq -> @@ -694,81 +676,39 @@ that would leave use with some lets sandwiched between lambdas; that's what the final test in the first equation is for. \begin{code} -tryEtaExpansion :: OutExpr - -> (ArityInfo -> OutExpr -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) -tryEtaExpansion rhs thing_inside - | not opt_SimplDoLambdaEtaExpansion - || null y_tys -- No useful expansion - || not (is_case1 || is_case2) -- Neither case matches - = thing_inside final_arity rhs -- So, no eta expansion, but - -- return a good arity - - | is_case1 - = make_y_bndrs $ \ y_bndrs -> - thing_inside final_arity - (mkLams x_bndrs $ mkLams y_bndrs $ - mkApps body (map Var y_bndrs)) - - | otherwise -- Must be case 2 - = mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) -> - addAuxiliaryBinds (catMaybes maybe_z_binds) $ - make_y_bndrs $ \ y_bndrs -> - thing_inside final_arity - (mkLams y_bndrs $ - mkApps (mkApps fun z_args) (map Var y_bndrs)) - where - all_trivial_args = all is_trivial arg_infos - is_case1 = all_trivial_args - is_case2 = null x_bndrs && not (any unlifted_non_trivial arg_infos) - - (x_bndrs, body) = collectBinders rhs -- NB: x_bndrs can include type variables - x_arity = valBndrCount x_bndrs - - (fun, args) = collectArgs body - arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args] +tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr) +tryEtaExpansion rhs rhs_ty + | not opt_SimplDoLambdaEtaExpansion -- Not if switched off + || exprIsTrivial rhs -- Not if RHS is trivial + || final_arity == 0 -- Not if arity is zero + = returnSmpl ([], rhs) + + | n_val_args == 0 && not arity_is_manifest + = -- Some lambdas but not enough: case 1 + getUniqSupplySmpl `thenSmpl` \ us -> + returnSmpl ([], etaExpand final_arity us rhs rhs_ty) + + | n_val_args > 0 && not (any cant_bind arg_infos) + = -- Partial application: case 2 + mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) -> + getUniqSupplySmpl `thenSmpl` \ us -> + returnSmpl (catMaybes maybe_z_binds, + etaExpand final_arity us (mkApps fun z_args) rhs_ty) - is_trivial (_, _, triv) = triv - unlifted_non_trivial (_, ty, triv) = not triv && isUnLiftedType ty - - fun_arity = exprEtaExpandArity fun - - final_arity | all_trivial_args = atLeastArity (x_arity + extra_args_wanted) - | otherwise = atLeastArity x_arity - -- Arity can be more than the number of lambdas - -- because of coerces. E.g. \x -> coerce t (\y -> e) - -- will have arity at least 2 - -- The worker/wrapper pass will bring the coerce out to the top + | otherwise + = returnSmpl ([], rhs) + where + (fun, args) = collectArgs rhs + n_val_args = valArgCount args + (fun_arity, arity_is_manifest) = exprEtaExpandArity fun + final_arity = 0 `max` (fun_arity - n_val_args) + arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args] + cant_bind (_, ty, triv) = not triv && isUnLiftedType ty bind_z_arg (arg, arg_ty, trivial_arg) | trivial_arg = returnSmpl (Nothing, arg) | otherwise = newId SLIT("z") arg_ty $ \ z -> returnSmpl (Just (NonRec z arg), Var z) - - make_y_bndrs thing_inside - = ASSERT( not (exprIsTrivial rhs) ) - newIds SLIT("y") y_tys $ \ y_bndrs -> - tick (EtaExpansion (head y_bndrs)) `thenSmpl_` - thing_inside y_bndrs - - (potential_extra_arg_tys, _) = splitFunTys (exprType body) - - y_tys :: [InType] - y_tys = take extra_args_wanted potential_extra_arg_tys - - extra_args_wanted :: Int -- Number of extra args we want - extra_args_wanted = 0 `max` (fun_arity - valArgCount args) - - -- We used to expand the arity to the previous arity fo the - -- function; but this is pretty dangerous. Consdier - -- f = \xy -> e - -- so that f has arity 2. Now float something into f's RHS: - -- f = let z = BIG in \xy -> e - -- The last thing we want to do now is to put some lambdas - -- outside, to get - -- f = \xy -> let z = BIG in e - -- - -- (bndr_arity - no_of_xs) `max` \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 7af03dc..f15edf8 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -13,7 +13,7 @@ import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction, SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, transformRhs, findAlt, +import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, findAlt, simplBinder, simplBinders, simplIds, findDefault, SimplCont(..), DupFlag(..), mkStop, mkRhsStop, contResultType, discardInline, countArgs, contIsDupable, @@ -29,8 +29,8 @@ import Id ( Id, idType, idInfo, isDataConId, zapLamIdInfo, setOneShotLambda, ) import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, - setArityInfo, unknownArity, - setUnfoldingInfo, + setArityInfo, + setUnfoldingInfo, atLeastArity, occInfo ) import Demand ( isStrict ) @@ -44,8 +44,8 @@ import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, ) import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe, mkPiType, - exprType, coreAltsType, exprIsValue, idAppIsCheap, - exprOkForSpeculation, + exprType, coreAltsType, exprIsValue, + exprOkForSpeculation, exprArity, exprIsCheap, mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) import Rules ( lookupRule ) @@ -60,6 +60,7 @@ import Subst ( mkSubst, substTy, import TyCon ( isDataTyCon, tyConDataConsIfAvailable ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) +import OrdList import Maybes ( maybeToBool ) import Util ( zipWithEqual ) import Outputable @@ -97,12 +98,12 @@ simplTopBinds binds simplIds (bindersOfBinds binds) $ \ bndrs' -> simpl_binds binds bndrs' `thenSmpl` \ (binds', _) -> freeTick SimplifierDone `thenSmpl_` - returnSmpl binds' + returnSmpl (fromOL binds') where -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info) - simpl_binds [] bs = ASSERT( null bs ) returnSmpl ([], panic "simplTopBinds corner") + simpl_binds [] bs = ASSERT( null bs ) returnSmpl (nilOL, panic "simplTopBinds corner") simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs) simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs)) where @@ -111,11 +112,11 @@ simplTopBinds binds simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId] -> SimplM (OutStuff a) -> SimplM (OutStuff a) simplRecBind top_lvl pairs bndrs' thing_inside - = go pairs bndrs' `thenSmpl` \ (binds', (binds'', res)) -> - returnSmpl (Rec (flattenBinds binds') : binds'', res) + = go pairs bndrs' `thenSmpl` \ (binds', (_, (binds'', res))) -> + returnSmpl (unitOL (Rec (flattenBinds (fromOL binds'))) `appOL` binds'', res) where go [] _ = thing_inside `thenSmpl` \ stuff -> - returnSmpl ([], stuff) + returnOutStuff stuff go ((bndr, rhs) : pairs) (bndr' : bndrs') = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs') @@ -181,7 +182,7 @@ simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr -- Simplify an expression, given a continuation simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) -> - returnSmpl (mkLets floats body) + returnSmpl (wrapFloats floats body) simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff -- Simplify an expression, returning floated binds @@ -511,7 +512,7 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside -- create the (dead) let-binding let x = (a,b) in ... = thing_inside - | exprIsTrivial new_rhs + | trivial_rhs && not must_keep_binding -- We're looking at a binding with a trivial RHS, so -- perhaps we can discard it altogether! -- @@ -535,20 +536,15 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside -- NB: Even NOINLINEis ignored here: if the rhs is trivial -- it's best to inline it anyway. We often get a=E; b=a -- from desugaring, with both a and b marked NOINLINE. - = if must_keep_binding then -- Keep the binding - finally_bind_it unknownArity new_rhs - -- Arity doesn't really matter because for a trivial RHS - -- we will inline like crazy at call sites - -- If this turns out be false, we can easily compute arity - else -- Drop the binding - extendSubst old_bndr (DoneEx new_rhs) $ + = -- Drop the binding + extendSubst old_bndr (DoneEx new_rhs) $ -- Use the substitution to make quite, quite sure that the substitution -- will happen, since we are going to discard the binding - tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - thing_inside + tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + thing_inside - | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs - -- [NB inner_rhs is guaranteed non-trivial by now] + | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs, + not trivial_rhs -- x = coerce t e ==> c = e; x = inline_me (coerce t c) -- Now x can get inlined, which moves the coercion -- to the usage site. This is a bit like worker/wrapper stuff, @@ -571,40 +567,38 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside (Note InlineMe (Note coercion (Var c_id))) $ thing_inside - | otherwise - = transformRhs new_rhs finally_bind_it - - where - old_info = idInfo old_bndr - occ_info = occInfo old_info - loop_breaker = isLoopBreaker occ_info - must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr - - finally_bind_it arity_info new_rhs - = getSubst `thenSmpl` \ subst -> - let + = getSubst `thenSmpl` \ subst -> + let -- We make new IdInfo for the new binder by starting from the old binder, -- doing appropriate substitutions. -- Then we add arity and unfolding info to get the new binder - new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) - `setArityInfo` arity_info + new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) + `setArityInfo` arity_info -- Add the unfolding *only* for non-loop-breakers -- Making loop breakers not have an unfolding at all -- means that we can avoid tests in exprIsConApp, for example. -- This is important: if exprIsConApp says 'yes' for a recursive -- thing, then we can get into an infinite loop - info_w_unf | loop_breaker = new_bndr_info - | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs + info_w_unf | loop_breaker = new_bndr_info + | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs - final_id = new_bndr `setIdInfo` info_w_unf - in + final_id = new_bndr `setIdInfo` info_w_unf + in -- These seqs forces the Id, and hence its IdInfo, -- and hence any inner substitutions - final_id `seq` - addLetBind (NonRec final_id new_rhs) $ - modifyInScope new_bndr final_id thing_inside + final_id `seq` + addLetBind (NonRec final_id new_rhs) $ + modifyInScope new_bndr final_id thing_inside + + where + old_info = idInfo old_bndr + occ_info = occInfo old_info + loop_breaker = isLoopBreaker occ_info + trivial_rhs = exprIsTrivial new_rhs + must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr + arity_info = atLeastArity (exprArity new_rhs) \end{code} @@ -661,46 +655,51 @@ simplLazyBind top_lvl bndr bndr' rhs thing_inside \begin{code} simplRhs :: Bool -- True <=> Top level -> Bool -- True <=> OK to float unboxed (speculative) bindings - -- False for (a) recursive and (b) top-level bindings + -- False for (a) recursive and (b) top-level bindings -> OutType -- Type of RHS; used only occasionally -> InExpr -> SubstEnv -> (OutExpr -> SimplM (OutStuff a)) -> SimplM (OutStuff a) simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside = -- Simplify it - setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) -> - - -- Float lets out of RHS + setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats1, (rhs_in_scope, rhs1)) -> let - (floats_out, rhs'') = splitFloats float_ubx floats rhs' + (floats2, rhs2) = splitFloats float_ubx floats1 rhs1 in - if (top_lvl || wantToExpose 0 rhs') && -- Float lets if (a) we're at the top level - not (null floats_out) -- or (b) the resulting RHS is one we'd like to expose - then - tickLetFloat floats_out `thenSmpl_` - -- Do the float - -- -- There's a subtlety here. There may be a binding (x* = e) in the -- floats, where the '*' means 'will be demanded'. So is it safe -- to float it out? Answer no, but it won't matter because -- we only float if arg' is a WHNF, -- and so there can't be any 'will be demanded' bindings in the floats. -- Hence the assert - WARN( any demanded_float floats_out, ppr floats_out ) - addLetBinds floats_out $ - setInScope in_scope' $ - thing_inside rhs'' - -- in_scope' may be excessive, but that's OK; - -- it's a superset of what's in scope + WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) ) + + -- Transform the RHS + -- It's important that we do eta expansion on function *arguments* (which are + -- simplified with simplRhs), as well as let-bound right-hand sides. + -- Otherwise we find that things like + -- f (\x -> case x of I# x' -> coerce T (\ y -> ...)) + -- get right through to the code generator as two separate lambdas, + -- which is a Bad Thing + tryRhsTyLam rhs2 `thenSmpl` \ (floats3, rhs3) -> + tryEtaExpansion rhs3 rhs_ty `thenSmpl` \ (floats4, rhs4) -> + + -- Float lets if (a) we're at the top level + -- or (b) the resulting RHS is one we'd like to expose + if (top_lvl || exprIsCheap rhs4) then + (if (isNilOL floats2 && null floats3 && null floats4) then + returnSmpl () + else + tick LetFloatFromLet) `thenSmpl_` + + addFloats floats2 rhs_in_scope $ + addAuxiliaryBinds floats3 $ + addAuxiliaryBinds floats4 $ + thing_inside rhs4 else -- Don't do the float - thing_inside (mkLets floats rhs') + thing_inside (wrapFloats floats1 rhs1) --- In a let-from-let float, we just tick once, arbitrarily --- choosing the first floated binder to identify it -tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b) -tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b) - demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b)) -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them demanded_float (Rec _) = False @@ -715,42 +714,15 @@ demanded_float (Rec _) = False -- can tolerate them. splitFloats float_ubx floats rhs | float_ubx = (floats, rhs) -- Float them all - | otherwise = go floats + | otherwise = go (fromOL floats) where - go [] = ([], rhs) - go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs) + go [] = (nilOL, rhs) + go (f:fs) | must_stay f = (nilOL, mkLets (f:fs) rhs) | otherwise = case go fs of - (out, rhs') -> (f:out, rhs') + (out, rhs') -> (f `consOL` out, rhs') must_stay (Rec prs) = False -- No unlifted bindings in here must_stay (NonRec b r) = isUnLiftedType (idType b) - -wantToExpose :: Int -> CoreExpr -> Bool --- True for expressions that we'd like to expose at the --- top level of an RHS. This includes partial applications --- even if the args aren't cheap; the next pass will let-bind the --- args and eta expand the partial application. So exprIsCheap won't do. --- Here's the motivating example: --- z = letrec g = \x y -> ...g... in g E --- Even though E is a redex we'd like to float the letrec to give --- g = \x y -> ...g... --- z = g E --- Now the next use of SimplUtils.tryEtaExpansion will give --- g = \x y -> ...g... --- z = let v = E in \w -> g v w --- And now we'll float the v to give --- g = \x y -> ...g... --- v = E --- z = \w -> g v w --- Which is what we want; chances are z will be inlined now. - -wantToExpose n (Var v) = idAppIsCheap v n -wantToExpose n (Lit l) = True -wantToExpose n (Lam _ e) = True -wantToExpose n (Note _ e) = wantToExpose n e -wantToExpose n (App f (Type _)) = wantToExpose n f -wantToExpose n (App f a) = wantToExpose (n+1) f -wantToExpose n other = False -- There won't be any lets \end{code} @@ -999,9 +971,7 @@ preInlineUnconditionally black_listed bndr \begin{code} ------------------------------------------------------------------- -- Finish rebuilding -rebuild_done expr - = getInScope `thenSmpl` \ in_scope -> - returnSmpl ([], (in_scope, expr)) +rebuild_done expr = returnOutStuff expr --------------------------------------------------------- rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff @@ -1439,8 +1409,8 @@ mkDupableCont ty (InlinePlease cont) thing_inside mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside = -- Build the RHS of the join point newId SLIT("a") join_arg_ty ( \ arg_id -> - cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> - returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs)) + cont_fn (Var arg_id) `thenSmpl` \ (floats, (_, rhs)) -> + returnSmpl (Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)) ) `thenSmpl` \ join_rhs -> -- Build the join Id and continuation @@ -1487,11 +1457,11 @@ mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside setSubstEnv se ( simplBinder case_bndr $ \ case_bndr' -> prepareCaseCont alts cont $ \ cont' -> - mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') -> - returnSmpl (concat alt_binds_s, alts') - ) `thenSmpl` \ (alt_binds, alts') -> + mkDupableAlts case_bndr case_bndr' cont' alts $ \ alts' -> + returnOutStuff alts' + ) `thenSmpl` \ (alt_binds, (in_scope, alts')) -> - addAuxiliaryBinds alt_binds $ + addFloats alt_binds in_scope $ -- NB that the new alternatives, alts', are still InAlts, using the original -- binders. That means we can keep the case_bndr intact. This is important @@ -1502,8 +1472,17 @@ mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside -- arg of unboxed tuple type, and indeed such a case_bndr is always dead thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont))) -mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt) -mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) +mkDupableAlts :: InId -> OutId -> SimplCont -> [InAlt] + -> ([InAlt] -> SimplM (OutStuff a)) + -> SimplM (OutStuff a) +mkDupableAlts case_bndr case_bndr' cont [] thing_inside + = thing_inside [] +mkDupableAlts case_bndr case_bndr' cont (alt:alts) thing_inside + = mkDupableAlt case_bndr case_bndr' cont alt $ \ alt' -> + mkDupableAlts case_bndr case_bndr' cont alts $ \ alts' -> + thing_inside (alt' : alts') + +mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside = simplBinders bndrs $ \ bndrs' -> simplExprC rhs cont `thenSmpl` \ rhs' -> @@ -1525,7 +1504,7 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) -- because otherwise we'd need to pair it up with an empty subst-env. -- (Remember we must zap the subst-env before re-simplifying something). -- Rather than do this we simply agree to re-simplify the original (small) thing later. - returnSmpl ([], alt) + thing_inside alt else let @@ -1596,6 +1575,6 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) one_shot v | isId v = setOneShotLambda v | otherwise = v in - returnSmpl ([NonRec join_bndr (mkLams really_final_bndrs rhs')], - (con, bndrs, mkApps (Var join_bndr) final_args)) + addLetBind (NonRec join_bndr (mkLams really_final_bndrs rhs')) $ + thing_inside (con, bndrs, mkApps (Var join_bndr) final_args) \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index e6d6897..6fbc5b9 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -8,7 +8,7 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, modifyIdInfo ) @@ -35,7 +35,7 @@ import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, - getUs, setUs, mapUs + withUs, mapUs ) import Name ( nameOccName, mkSpecOcc, getSrcLoc ) import FiniteMap @@ -1107,29 +1107,25 @@ cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind) -- Clone the binders of the bind; return new bind with the cloned binders -- Return the substitution to use for RHSs, and the one to use for the body cloneBindSM subst (NonRec bndr rhs) - = getUs `thenUs` \ us -> + = withUs $ \ us -> let (subst', us', bndr') = substAndCloneId subst us bndr in - setUs us' `thenUs_` - returnUs (subst, subst', NonRec bndr' rhs) + ((subst, subst', NonRec bndr' rhs), us') cloneBindSM subst (Rec pairs) - = getUs `thenUs` \ us -> + = withUs $ \ us -> let (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs) in - setUs us' `thenUs_` - returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs)) + ((subst', subst', Rec (bndrs' `zip` map snd pairs)), us') cloneBinders subst bndrs - = getUs `thenUs` \ us -> + = withUs $ \ us -> let (subst', us', bndrs') = substAndCloneIds subst us bndrs in - setUs us' `thenUs_` - returnUs (subst', bndrs') - + ((subst', bndrs'), us') newIdSM old_id new_ty = getUniqSM `thenSM` \ uniq ->