import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
opt_SimplNoPreInlining,
+ dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, transformRhs, findAlt,
- simplBinder, simplBinders, simplIds, findDefault,
+import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
+ simplBinder, simplBinders, simplRecIds, simplLetId,
SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
contResultType, discardInline, countArgs, contIsDupable,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( mkSysTyVar, tyVarKind )
+import Var ( mkSysTyVar, tyVarKind, mustHaveLocalBinding )
import VarEnv
-import VarSet ( elemVarSet )
-import Id ( Id, idType, idInfo, isDataConId,
+import Literal ( Literal )
+import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
idDemandInfo, setIdInfo,
- idOccInfo, setIdOccInfo,
+ idOccInfo, setIdOccInfo,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
- setArityInfo, unknownArity,
- setUnfoldingInfo,
+ setArityInfo,
+ setUnfoldingInfo,
occInfo
)
import Demand ( isStrict )
dataConSig, dataConArgTys
)
import CoreSyn
-import CoreFVs ( mustHaveLocalBinding, exprFreeVars )
+import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
callSiteInline
)
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
- exprType, coreAltsType, exprIsValue, idAppIsCheap,
- exprOkForSpeculation,
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+ exprType, coreAltsType, exprIsValue,
+ exprOkForSpeculation, exprArity, exprIsCheap,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitTyConApp_maybe,
- funResultTy
+ mkFunTy, splitTyConApp_maybe, tyConAppArgs,
+ funResultTy, splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy,
- isInScope, lookupIdSubst, substIdInfo
+import Subst ( mkSubst, substTy, substEnv, substExpr,
+ isInScope, lookupIdSubst, simplIdInfo
)
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
+import OrdList
import Maybes ( maybeToBool )
-import Util ( zipWithEqual )
import Outputable
\end{code}
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplIds (bindersOfBinds binds) $ \ bndrs' ->
+ simplRecIds (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
-simplExprF (Var v) cont
- = simplVar v cont
-
-simplExprF (Lit lit) (Select _ bndr alts se cont)
- = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
-
-simplExprF (Lit lit) cont
- = rebuild (Lit lit) cont
+simplExprF (Var v) cont = simplVar v cont
+simplExprF (Lit lit) cont = simplLit lit cont
+simplExprF expr@(Lam _ _) cont = simplLam expr cont
+simplExprF (Note note expr) cont = simplNote note expr cont
simplExprF (App fun arg) cont
= getSubstEnv `thenSmpl` \ se ->
simplExprF fun (ApplyTo NoDup arg se cont)
+simplExprF (Type ty) cont
+ = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
+ simplType ty `thenSmpl` \ ty' ->
+ rebuild (Type ty') cont
+
simplExprF (Case scrut bndr alts) cont
= getSubstEnv `thenSmpl` \ subst_env ->
getSwitchChecker `thenSmpl` \ chkr ->
(mkStop (contResultType cont))) `thenSmpl` \ case_expr' ->
rebuild case_expr' cont
-
simplExprF (Let (Rec pairs) body) cont
- = simplIds (map fst pairs) $ \ bndrs' ->
+ = simplRecIds (map fst pairs) $ \ bndrs' ->
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
simplRecBind False pairs bndrs' (simplExprF body cont)
-simplExprF expr@(Lam _ _) cont = simplLam expr cont
-
-simplExprF (Type ty) cont
- = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
- simplType ty `thenSmpl` \ ty' ->
- rebuild (Type ty') cont
-
--- Comments about the Coerce case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- It's worth checking for a coerce in the continuation,
--- in case we can cancel them. For example, in the initial form of a worker
--- we may find (coerce T (coerce S (\x.e))) y
--- and we'd like it to simplify to e[y/x] in one round of simplification
-
-simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont)
- = simplType from `thenSmpl` \ from' ->
- if outer_to == from' then
- -- The coerces cancel out
- simplExprF e cont
- else
- -- They don't cancel, but the inner one is redundant
- simplExprF e (CoerceIt outer_to cont)
-
-simplExprF (Note (Coerce to from) e) cont
- = simplType to `thenSmpl` \ to' ->
- simplExprF e (CoerceIt to' cont)
-
--- hack: we only distinguish subsumed cost centre stacks for the purposes of
--- inlining. All other CCCSs are mapped to currentCCS.
-simplExprF (Note (SCC cc) e) cont
- = setEnclosingCC currentCCS $
- simplExpr e `thenSmpl` \ e ->
- rebuild (mkSCC cc e) cont
+-- A non-recursive let is dealt with by simplNonRecBind
+simplExprF (Let (NonRec bndr rhs) body) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplNonRecBind bndr rhs se (contResultType cont) $
+ simplExprF body cont
-simplExprF (Note InlineCall e) cont
- = simplExprF e (InlinePlease cont)
--- Comments about the InlineMe case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Don't inline in the RHS of something that has an
--- inline pragma. But be careful that the InScopeEnv that
--- we return does still have inlinings on!
---
--- It really is important to switch off inlinings. This function
--- may be inlinined in other modules, so we don't want to remove
--- (by inlining) calls to functions that have specialisations, or
--- that may have transformation rules in an importing scope.
--- E.g. {-# INLINE f #-}
--- f x = ...g...
--- and suppose that g is strict *and* has specialisations.
--- If we inline g's wrapper, we deny f the chance of getting
--- the specialised version of g when f is inlined at some call site
--- (perhaps in some other module).
+---------------------------------
+simplType :: InType -> SimplM OutType
+simplType ty
+ = getSubst `thenSmpl` \ subst ->
+ let
+ new_ty = substTy subst ty
+ in
+ seqType new_ty `seq`
+ returnSmpl new_ty
-simplExprF (Note InlineMe e) cont
- = case cont of
- Stop _ _ -> -- Totally boring continuation
- -- Don't inline inside an INLINE expression
- setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
- rebuild (mkInlineMe e') cont
+---------------------------------
+simplLit :: Literal -> SimplCont -> SimplM OutExprStuff
- other -> -- Dissolve the InlineMe note if there's
- -- an interesting context of any kind to combine with
- -- (even a type application -- anything except Stop)
- simplExprF e cont
+simplLit lit (Select _ bndr alts se cont)
+ = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
--- A non-recursive let is dealt with by simplBeta
-simplExprF (Let (NonRec bndr rhs) body) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplBeta bndr rhs se (contResultType cont) $
- simplExprF body cont
+simplLit lit cont = rebuild (Lit lit) cont
\end{code}
----------------------------------
+%************************************************************************
+%* *
+\subsection{Lambdas}
+%* *
+%************************************************************************
\begin{code}
simplLam fun cont
-- Ordinary beta reduction
go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
= tick (BetaReduction bndr) `thenSmpl_`
- simplBeta zapped_bndr arg arg_se cont_ty
+ simplNonRecBind zapped_bndr arg arg_se cont_ty
(go body body_cont)
where
zapped_bndr = zap_it bndr
Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
where
- -- We don't use CoreUtils.etaReduceExpr, because we can be more
- -- efficient here: (a) we already have the binders, (b) we can do
- -- the triviality test before computing the free vars
+ -- We don't use CoreUtils.etaReduce, because we can be more
+ -- efficient here:
+ -- (a) we already have the binders,
+ -- (b) we can do the triviality test before computing the free vars
+ -- [in fact I take the simple path and look for just a variable]
+ -- (c) we don't want to eta-reduce a data con worker or primop
+ -- because we only have to eta-expand them later when we saturate
try_eta body | not opt_SimplDoEtaReduction = Nothing
| otherwise = go rev_bndrs body
go [] body | ok_body body = Just body -- Success!
go _ _ = Nothing -- Failure!
- ok_body body = exprIsTrivial body && not (any (`elemVarSet` exprFreeVars body) rev_bndrs)
- ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+ ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v)
+ ok_body other = False
+ ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
mkLamBndrZapper :: CoreExpr -- Function
-> SimplCont -- The context
\end{code}
----------------------------------
+%************************************************************************
+%* *
+\subsection{Notes}
+%* *
+%************************************************************************
+
\begin{code}
-simplType :: InType -> SimplM OutType
-simplType ty
- = getSubst `thenSmpl` \ subst ->
+simplNote (Coerce to from) body cont
+ = getInScope `thenSmpl` \ in_scope ->
let
- new_ty = substTy subst ty
+ addCoerce s1 k1 (CoerceIt t1 cont)
+ -- coerce T1 S1 (coerce S1 K1 e)
+ -- ==>
+ -- e, if T1=K1
+ -- coerce T1 K1 e, otherwise
+ --
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+ | t1 `eqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
+
+ addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
+ | Just (s1, s2) <- splitFunTy_maybe s1s2
+ -- (coerce (T1->T2) (S1->S2) F) E
+ -- ===>
+ -- coerce T2 S2 (F (coerce S1 T1 E))
+ --
+ -- t1t2 must be a function type, T1->T2
+ -- but s1s2 might conceivably not be
+ --
+ -- When we build the ApplyTo we can't mix the out-types
+ -- with the InExpr in the argument, so we simply substitute
+ -- to make it all consistent. This isn't a common case.
+ = let
+ (t1,t2) = splitFunTy t1t2
+ new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope arg_se) arg)
+ in
+ ApplyTo dup new_arg emptySubstEnv (addCoerce t2 s2 cont)
+
+ addCoerce to' _ cont = CoerceIt to' cont
in
- seqType new_ty `seq`
- returnSmpl new_ty
+ simplType to `thenSmpl` \ to' ->
+ simplType from `thenSmpl` \ from' ->
+ simplExprF body (addCoerce to' from' cont)
+
+
+-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplNote (SCC cc) e cont
+ = setEnclosingCC currentCCS $
+ simplExpr e `thenSmpl` \ e ->
+ rebuild (mkSCC cc e) cont
+
+simplNote InlineCall e cont
+ = simplExprF e (InlinePlease cont)
+
+-- Comments about the InlineMe case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Don't inline in the RHS of something that has an
+-- inline pragma. But be careful that the InScopeEnv that
+-- we return does still have inlinings on!
+--
+-- It really is important to switch off inlinings. This function
+-- may be inlinined in other modules, so we don't want to remove
+-- (by inlining) calls to functions that have specialisations, or
+-- that may have transformation rules in an importing scope.
+-- E.g. {-# INLINE f #-}
+-- f x = ...g...
+-- and suppose that g is strict *and* has specialisations.
+-- If we inline g's wrapper, we deny f the chance of getting
+-- the specialised version of g when f is inlined at some call site
+-- (perhaps in some other module).
+
+-- It's also important not to inline a worker back into a wrapper.
+-- A wrapper looks like
+-- wraper = inline_me (\x -> ...worker... )
+-- Normally, the inline_me prevents the worker getting inlined into
+-- the wrapper (initially, the worker's only call site!). But,
+-- if the wrapper is sure to be called, the strictness analyser will
+-- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+-- continuation. That's why the keep_inline predicate returns True for
+-- ArgOf continuations. It shouldn't do any harm not to dissolve the
+-- inline-me note under these circumstances
+
+simplNote InlineMe e cont
+ | keep_inline cont -- Totally boring continuation
+ = -- Don't inline inside an INLINE expression
+ noInlineBlackList `thenSmpl` \ bl ->
+ setBlackList bl (simplExpr e) `thenSmpl` \ e' ->
+ rebuild (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF e cont
+ where
+ keep_inline (Stop _ _) = True -- See notes above
+ keep_inline (ArgOf _ _ _) = True -- about this predicate
+ keep_inline other = False
\end{code}
%* *
%************************************************************************
-@simplBeta@ is used for non-recursive lets in expressions,
+@simplNonRecBind@ is used for non-recursive lets in expressions,
as well as true beta reduction.
Very similar to @simplLazyBind@, but not quite the same.
\begin{code}
-simplBeta :: InId -- Binder
+simplNonRecBind :: InId -- Binder
-> InExpr -> SubstEnv -- Arg, with its subst-env
-> OutType -- Type of thing computed by the context
-> SimplM OutExprStuff -- The body
-> SimplM OutExprStuff
#ifdef DEBUG
-simplBeta bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| isTyVar bndr
- = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
+ = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
#endif
-simplBeta bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally False {- not black listed -} bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
extendSubst bndr (ContEx rhs_se rhs) thing_inside
| otherwise
- = -- Simplify the RHS
- simplBinder bndr $ \ bndr' ->
+ = -- Simplify the binder.
+ -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId bndr $ \ bndr' ->
+ getSubst `thenSmpl` \ bndr_subst ->
let
+ -- Substitute its IdInfo (which simplLetId does not)
+ -- The appropriate substitution env is the one right here,
+ -- not rhs_se. Often they are the same, when all this
+ -- has arisen from an application (\x. E) RHS, perhaps they aren't
+ bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'
bndr_ty' = idType bndr'
is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
in
+ modifyInScope bndr'' bndr'' $
+
+ -- Simplify the argument
simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-- Now complete the binding and simplify the body
if needsCaseBinding bndr_ty' rhs' then
- addCaseBind bndr' rhs' thing_inside
+ addCaseBind bndr'' rhs' thing_inside
else
- completeBinding bndr bndr' False False rhs' thing_inside
+ completeBinding bndr bndr'' False False rhs' thing_inside
\end{code}
-- 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: a loop breaker never has postInlineUnconditionally True
+ -- NB: a loop breaker has must_keep_binding = True
-- and non-loop-breakers only have *forward* references
-- Hence, it's safe to discard the binding
--
-- 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 && not (isUnLiftedType inner_ty)
-- 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,
-- will inline x.
-- Also the full-blown w/w thing isn't set up for non-functions
--
+ -- The (not (isUnLiftedType inner_ty)) avoids the nasty case of
+ -- x::Int = coerce Int Int# (foo y)
+ -- ==>
+ -- v::Int# = foo y
+ -- x::Int = coerce Int Int# v
+ -- which would be bogus because then v will be evaluated strictly.
+ -- How can this arise? Via
+ -- x::Int = case (foo y) of { ... }
+ -- followed by case elimination.
+ --
-- The inline_me note is so that the simplifier doesn't
-- just substitute c back inside x's rhs! (Typically, x will
-- get substituted away, but not if it's exported.)
(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
+ = 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 = idInfo new_bndr `setArityInfo` arity
-- 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 = exprArity new_rhs
\end{code}
else
-- Simplify the RHS
- getSubstEnv `thenSmpl` \ rhs_se ->
+ getSubst `thenSmpl` \ rhs_subst ->
+ let
+ -- Substitute IdInfo on binder, in the light of earlier
+ -- substitutions in this very letrec, and extend the in-scope
+ -- env so that it can see the new thing
+ bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr'
+ in
+ modifyInScope bndr'' bndr'' $
+
simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
(idType bndr')
- rhs rhs_se $ \ rhs' ->
+ rhs (substEnv rhs_subst) $ \ rhs' ->
-- Now compete the binding and simplify the body
- completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
+ completeBinding bndr bndr'' top_lvl black_listed rhs' thing_inside
\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}
---------------------------------------------------------
-- Dealing with a call
-completeCall var occ cont
+completeCall var occ_info cont
= getBlackList `thenSmpl` \ black_list_fn ->
getInScope `thenSmpl` \ in_scope ->
getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
inline_cont | inline_call = discardInline cont
| otherwise = cont
- maybe_inline = callSiteInline dflags black_listed inline_call occ
+ maybe_inline = callSiteInline dflags black_listed inline_call occ_info
var arg_infos interesting_cont
in
-- First, look for an inlining
-- But the black-listing mechanism means that inlining of the wrapper
-- won't occur for things that have specialisations till a later phase, so
-- it's ok to try for inlining first.
+ --
+ -- You might think that we shouldn't apply rules for a loop breaker:
+ -- doing so might give rise to an infinite loop, because a RULE is
+ -- rather like an extra equation for the function:
+ -- RULE: f (g x) y = x+y
+ -- Eqn: f a y = a-y
+ --
+ -- But it's too drastic to disable rules for loop breakers.
+ -- Even the foldr/build rule would be disabled, because foldr
+ -- is recursive, and hence a loop breaker:
+ -- foldr k z (build g) = g k z
+ -- So it's up to the programmer: rules can cause divergence
getSwitchChecker `thenSmpl` \ chkr ->
let
case maybe_rule of {
Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
+#ifdef DEBUG
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ptext rule_name,
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
+ text "After: " <+> pprCoreExpr rule_rhs])
+ else
+ id) $
+#endif
simplExprF rule_rhs call_cont ;
Nothing -> -- No rules
-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
= getBlackList `thenSmpl` \ old_bl ->
- setBlackList noInlineBlackList $
+ noInlineBlackList `thenSmpl` \ ni_bl ->
+ setBlackList ni_bl $
go args $ \ args' ->
setBlackList old_bl $
thing_inside args'
\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
-> SimplM OutExprStuff
knownCon expr con args bndr alts se cont
- = tick (KnownBranch bndr) `thenSmpl_`
+ = -- Arguments should be atomic;
+ -- yell if not
+ WARN( not (all exprIsTrivial args),
+ text "knownCon" <+> ppr expr )
+ tick (KnownBranch bndr) `thenSmpl_`
setSubstEnv se (
simplBinder bndr $ \ bndr' ->
completeBinding bndr bndr' False False expr $
let
(_,_,ex_tyvars,_,_,_) = dataConSig data_con
in
- getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
+ getUniquesSmpl `thenSmpl` \ tv_uniqs ->
let
- ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+ ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys data_con
(inst_tys ++ mkTyVarTys ex_tyvars')
simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
- inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
- Just (tycon, inst_tys) -> inst_tys
+ inst_tys' = tyConAppArgs (idType case_bndr')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
- handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+ (con_alts,_) = findDefault alts
+ handled_cons = scrut_cons ++ [con | (con,_,_) <- con_alts]
simpl_alt (DEFAULT, _, rhs)
= -- In the default case we record the constructors that the
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
-- Consider: let j = if .. then I# 3 else I# 4
-- in case .. of { A -> j; B -> j; C -> ... }
--
- -- Now CPR should not w/w j because it's a thunk, so
+ -- Now CPR doesn't w/w j because it's a thunk, so
-- that means that the enclosing function can't w/w either,
-- which is a lose. Here's the example that happened in practice:
-- kgmod :: Int -> Int -> Int
-- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
-- then 78
-- else 5
+ --
+ -- I have seen a case alternative like this:
+ -- True -> \v -> ...
+ -- It's a bit silly to add the realWorld dummy arg in this case, making
+ -- $j = \s v -> ...
+ -- True -> $j s
+ -- (the \v alone is enough to make CPR happy) but I think it's rare
then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
`thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-
- -- Notice that we make the lambdas into one-shot-lambdas. The
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
-- prevents the body of the join point being floated out by
-- the full laziness pass
- returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
- (con, bndrs, mkApps (Var join_bndr) final_args))
+ really_final_bndrs = map one_shot final_bndrs'
+ one_shot v | isId v = setOneShotLambda v
+ | otherwise = v
+ in
+ addLetBind (NonRec join_bndr (mkLams really_final_bndrs rhs')) $
+ thing_inside (con, bndrs, mkApps (Var join_bndr) final_args)
\end{code}
projects / ghc-hetmet.git / blobdiff