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.
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,
#include "HsVersions.h"
import Unique
-import Panic ( panic )
-
import GlaExts
#if __GLASGOW_HASKELL__ < 301
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
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
exprArity,
-- Expr transformation
- etaReduce, exprEtaExpandArity,
--- etaExpandExpr,
+ etaReduce, etaExpand,
+ exprArity, exprEtaExpandArity,
-- Size
coreBindsSize,
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
exprArity _ = 0
\end{code}
+
%************************************************************************
%* *
\subsection{Eta reduction and expansion}
\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
--
-- 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
\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
= 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}
%************************************************************************
module SimplMonad (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
- OutExprStuff, OutStuff,
+ OutExprStuff, OutStuff, returnOutStuff,
-- The monad
SimplM,
setBlackList, getBlackList, noInlineBlackList,
-- Unique supply
- getUniqueSmpl, getUniquesSmpl,
+ getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
newId, newIds,
-- Counting
-- Adding bindings
addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
- addCaseBind, needsCaseBinding, addNonRecBind
+ addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats
) where
#include "HsVersions.h"
import OccName ( UserFS )
import VarEnv
import VarSet
+import OrdList
import qualified Subst
import Subst ( Subst, mkSubst, substEnv,
InScopeSet, mkInScopeSet, substInScope
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
-- 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
%************************************************************************
\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
| 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
tickToTag (PostInlineUnconditionally _) = 1
tickToTag (UnfoldingDone _) = 2
tickToTag (RuleFired _) = 3
-tickToTag (LetFloatFromLet _) = 4
+tickToTag LetFloatFromLet = 4
tickToTag (EtaExpansion _) = 5
tickToTag (EtaReduction _) = 6
tickToTag (BetaReduction _) = 7
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
tickString (UnfoldingDone _) = "UnfoldingDone"
tickString (RuleFired _) = "RuleFired"
-tickString (LetFloatFromLet _) = "LetFloatFromLet"
+tickString LetFloatFromLet = "LetFloatFromLet"
tickString (EtaExpansion _) = "EtaExpansion"
tickString (EtaReduction _) = "EtaReduction"
tickString (BetaReduction _) = "BetaReduction"
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
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
\begin{code}
module SimplUtils (
simplBinder, simplBinders, simplIds,
- transformRhs,
+ tryRhsTyLam, tryEtaExpansion,
mkCase, findAlt, findDefault,
-- The continuation type
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
)
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
\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
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
-- 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
-- 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 ->
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}
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,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
- setArityInfo, unknownArity,
- setUnfoldingInfo,
+ setArityInfo,
+ setUnfoldingInfo, atLeastArity,
occInfo
)
import Demand ( isStrict )
)
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 )
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
+import OrdList
import Maybes ( maybeToBool )
import Util ( zipWithEqual )
import Outputable
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
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')
-- 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
-- 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!
--
-- 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,
(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}
\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
-- 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}
\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
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
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
-- 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' ->
-- 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
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}
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import Id ( Id, idName, idType, mkUserLocal,
idSpecialisation, modifyIdInfo
)
import UniqSupply ( UniqSupply,
UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
- getUs, setUs, mapUs
+ withUs, mapUs
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-- 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 ->
projects / ghc-hetmet.git / commitdiff