-
+%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
#include "HsVersions.h"
-import CmdLineOpts ( intSwitchSet, switchIsOn,
- opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction,
- opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms,
+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,
- SimplCont(..), DupFlag(..), contResultType, analyseCont,
- discardInline, countArgs, countValArgs, discardCont, contIsDupable
+import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
+ simplBinder, simplBinders, simplIds,
+ SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
+ contResultType, discardInline, countArgs, contIsDupable,
+ getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo )
+import Var ( mkSysTyVar, tyVarKind )
import VarEnv
-import VarSet
-import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe,
+import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
- idSpecialisation, setIdSpecialisation,
- idDemandInfo, setIdDemandInfo,
- setIdInfo,
- idOccInfo, setIdOccInfo,
- zapLamIdInfo, zapFragileIdInfo,
- idStrictness, isBottomingId,
- setInlinePragma, mayHaveNoBinding,
- setOneShotLambda, maybeModifyIdInfo
+ idDemandInfo, setIdInfo,
+ idOccInfo, setIdOccInfo,
+ zapLamIdInfo, setOneShotLambda,
)
-import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
- ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
- specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo,
- CprInfo(..), cprInfo
+import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
+ setArityInfo,
+ setUnfoldingInfo, atLeastArity,
+ occInfo
)
-import Demand ( Demand, isStrict, wwLazy )
-import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity,
+import Demand ( isStrict )
+import DataCon ( dataConNumInstArgs, dataConRepStrictness,
dataConSig, dataConArgTys
)
-import Name ( isLocallyDefined )
import CoreSyn
-import CoreFVs ( exprFreeVars )
-import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate,
- callSiteInline, hasSomeUnfolding, noUnfolding
+import PprCore ( pprParendExpr, pprCoreExpr )
+import CoreFVs ( mustHaveLocalBinding )
+import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
+ callSiteInline
)
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, exprIsConApp_maybe,
- exprType, coreAltsType, exprArity, exprIsValue, idAppIsCheap,
- exprOkForSpeculation, etaReduceExpr,
+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 ( isSubsumedCCS, currentCCS, isEmptyCC )
-import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitFunTy, splitFunTys, splitFunTy_maybe,
- splitTyConApp_maybe,
- funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys
+import CostCentre ( currentCCS )
+import Type ( mkTyVarTys, isUnLiftedType, seqType,
+ mkFunTy, splitTyConApp_maybe, tyConAppArgs,
+ funResultTy
)
-import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr,
- substEnv, isInScope, lookupIdSubst, substIdInfo
+import Subst ( mkSubst, substTy,
+ isInScope, lookupIdSubst, substIdInfo
)
-import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
+import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
-import BasicTypes ( TopLevelFlag(..), isTopLevel )
+import OrdList
import Maybes ( maybeToBool )
-import Util ( zipWithEqual, lengthExceeds )
-import PprCore
+import Util ( zipWithEqual )
import Outputable
-import Unique ( foldrIdKey ) -- Temp
\end{code}
loop for the simplifier is in SimplCore.lhs.
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more. (Actually, it never did!) The reason is
+documented with simplifyArgs.
+
+
+
+
%************************************************************************
%* *
\subsection{Bindings}
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')
%* *
%************************************************************************
-\begin{code}
-addLetBind :: OutId -> OutExpr -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addLetBind bndr rhs thing_inside
- = thing_inside `thenSmpl` \ (binds, res) ->
- returnSmpl (NonRec bndr rhs : binds, res)
-
-addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addLetBinds binds1 thing_inside
- = thing_inside `thenSmpl` \ (binds2, res) ->
- returnSmpl (binds1 ++ binds2, res)
-
-needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
- -- Make a case expression instead of a let
- -- These can arise either from the desugarer,
- -- 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)]))
-
-addNonRecBind bndr rhs thing_inside
- -- Checks for needing a case binding
- | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
- | otherwise = addLetBind bndr rhs thing_inside
-\end{code}
-
The reason for this OutExprStuff stuff is that we want to float *after*
simplifying a RHS, not before. If we do so naively we get quadratic
behaviour as things float out.
\begin{code}
simplExpr :: CoreExpr -> SimplM CoreExpr
simplExpr expr = getSubst `thenSmpl` \ subst ->
- simplExprC expr (Stop (substTy subst (exprType expr)))
+ simplExprC expr (mkStop (substTy subst (exprType expr)))
-- The type in the Stop continuation is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
-- 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
-- If case-of-case is off, simply simplify the case expression
-- in a vanilla Stop context, and rebuild the result around it
simplExprC scrut (Select NoDup bndr alts subst_env
- (Stop (contResultType cont))) `thenSmpl` \ case_expr' ->
+ (mkStop (contResultType cont))) `thenSmpl` \ case_expr' ->
rebuild case_expr' cont
simplExprF expr@(Lam _ _) cont = simplLam expr cont
simplExprF (Type ty) cont
- = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } )
+ = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
simplType ty `thenSmpl` \ ty' ->
rebuild (Type ty') cont
simplExprF (Note InlineCall e) cont
= simplExprF e (InlinePlease cont)
--- Comments about the InlineMe case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 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!
-- the specialised version of g when f is inlined at some call site
-- (perhaps in some other module).
-simplExprF (Note InlineMe e) cont
- = case cont of
- Stop _ -> -- Totally boring continuation
- -- Don't inline inside an INLINE expression
- switchOffInlining (simplExpr e) `thenSmpl` \ e' ->
- rebuild (mkInlineMe e') cont
+-- 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
- 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
+simplExprF (Note InlineMe e) cont
+ | keep_inline cont -- Totally boring continuation
+ = -- Don't inline inside an INLINE expression
+ setBlackList noInlineBlackList (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
-- A non-recursive let is dealt with by simplBeta
simplExprF (Let (NonRec bndr rhs) body) cont
go expr cont = simplExprF expr cont
-- completeLam deals with the case where a lambda doesn't have an ApplyTo
--- continuation.
--- We used to try for eta reduction here, but I found that this was
--- eta reducing things like
--- f = \x -> (coerce (\x -> e))
--- This made f's arity reduce, which is a bad thing, so I removed the
--- eta reduction at this point, and now do it only when binding
--- (at the call to postInlineUnconditionally)
-
-completeLam acc (Lam bndr body) cont
+-- continuation, so there are real lambdas left to put in the result
+
+-- We try for eta reduction here, but *only* if we get all the
+-- way to an exprIsTrivial expression.
+-- We don't want to remove extra lambdas unless we are going
+-- to avoid allocating this thing altogether
+
+completeLam rev_bndrs (Lam bndr body) cont
= simplBinder bndr $ \ bndr' ->
- completeLam (bndr':acc) body cont
+ completeLam (bndr':rev_bndrs) body cont
-completeLam acc body cont
+completeLam rev_bndrs body cont
= simplExpr body `thenSmpl` \ body' ->
- rebuild (foldl (flip Lam) body' acc) cont
- -- Remember, acc is the *reversed* binders
+ case try_eta body' of
+ Just etad_lam -> tick (EtaReduction (head rev_bndrs)) `thenSmpl_`
+ rebuild etad_lam cont
+
+ Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
+ where
+ -- 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 (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
+ go [] body | ok_body body = Just body -- Success!
+ go _ _ = Nothing -- Failure!
+
+ 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
| otherwise
= -- Simplify the RHS
simplBinder bndr $ \ bndr' ->
- simplValArg (idType bndr') (idDemandInfo bndr)
- rhs rhs_se cont_ty $ \ rhs' ->
+ let
+ bndr_ty' = idType bndr'
+ is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
+ in
+ simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-- Now complete the binding and simplify the body
- if needsCaseBinding (idType bndr') rhs' then
+ if needsCaseBinding bndr_ty' rhs' then
addCaseBind bndr' rhs' thing_inside
else
completeBinding bndr bndr' False False rhs' thing_inside
seqType ty_arg' `seq`
returnSmpl ty_arg'
-simplValArg :: OutType -- Type of arg
- -> Demand -- Demand on the argument
+simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally
+ -> Bool -- True <=> evaluate eagerly
-> InExpr -> SubstEnv
- -> OutType -- Type of thing computed by the context
- -> (OutExpr -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
-
-simplValArg arg_ty demand arg arg_se cont_ty thing_inside
- | isStrict demand ||
- isUnLiftedType arg_ty ||
- (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty)
- -- Return true only for dictionary types where the dictionary
- -- has more than one component (else we risk poking on the component
- -- of a newtype dictionary)
- = transformRhs arg `thenSmpl` \ t_arg ->
- getEnv `thenSmpl` \ env ->
+ -> OutType -- cont_ty: Type of thing computed by the context
+ -> (OutExpr -> SimplM OutExprStuff)
+ -- Takes an expression of type rhs_ty,
+ -- returns an expression of type cont_ty
+ -> SimplM OutExprStuff -- An expression of type cont_ty
+
+simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside
+ | is_strict
+ = getEnv `thenSmpl` \ env ->
setSubstEnv arg_se $
- simplExprF t_arg (ArgOf NoDup cont_ty $ \ rhs' ->
+ simplExprF arg (ArgOf NoDup cont_ty $ \ rhs' ->
setAllExceptInScope env $
- etaFirst thing_inside rhs')
+ thing_inside rhs')
| otherwise
= simplRhs False {- Not top level -}
True {- OK to float unboxed -}
arg_ty arg arg_se
thing_inside
-
--- Do eta-reduction on the simplified RHS, if eta reduction is on
--- NB: etaFirst only eta-reduces if that results in something trivial
-etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs)
- | otherwise = \ thing_inside rhs -> thing_inside rhs
-
--- Try for eta reduction, but *only* if we get all
--- the way to an exprIsTrivial expression. We don't want to remove
--- extra lambdas unless we are going to avoid allocating this thing altogether
-etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
- | otherwise = rhs
- where
- rhs' = etaReduceExpr rhs
\end{code}
-> SimplM (OutStuff a)
completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
- | (case occ_info of -- This happens; for example, the case_bndr during case of
- IAmDead -> True -- known constructor: case (a,b) of x { (p,q) -> ... }
- other -> False) -- Here x isn't mentioned in the RHS, so we don't want to
+ | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
-- create the (dead) let-binding let x = (a,b) in ...
= thing_inside
- | postInlineUnconditionally black_listed occ_info old_bndr new_rhs
- -- Maybe we don't need a let-binding! Maybe we can just
- -- inline it right away. Unlike the preInlineUnconditionally case
- -- we are allowed to look at the 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: You might think that postInlineUnconditionally is an optimisation,
- -- but if we have
- -- let x = f Bool in (x, y)
- -- then because of the constructor, x will not be *inlined* in the pair,
- -- so the trivial binding will stay. But in this postInlineUnconditionally
- -- gag we use the *substitution* to substitute (f Bool) for x, and that *will*
- -- happen.
- = tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- extendSubst old_bndr (DoneEx new_rhs)
- thing_inside
+ -- NOTE: This isn't our last opportunity to inline.
+ -- We're at the binding site right now, and
+ -- we'll get another opportunity when we get to the ocurrence(s)
+
+ -- Note that we do this unconditional inlining only for trival RHSs.
+ -- Don't inline even WHNFs inside lambdas; doing so may
+ -- simply increase allocation when the function is called
+ -- This isn't the last chance; see NOTE above.
+ --
+ -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
+ -- Why? Because we don't even want to inline them into the
+ -- RHS of constructor arguments. See NOTE above
+ --
+ -- 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.
+ = -- 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
+
+ | 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,
+ -- but it's useful to do it very promptly, so that
+ -- x = coerce T (I# 3)
+ -- get's w/wd to
+ -- c = I# 3
+ -- x = coerce T c
+ -- This in turn means that
+ -- case (coerce Int x) of ...
+ -- 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.)
+ = newId SLIT("c") inner_ty $ \ c_id ->
+ completeBinding c_id c_id top_lvl False inner_rhs $
+ completeBinding old_bndr new_bndr top_lvl black_listed
+ (Note InlineMe (Note coercion (Var c_id))) $
+ thing_inside
| otherwise
- = 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
- old_info = idInfo old_bndr
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` ArityAtLeast (exprArity new_rhs)
- `setUnfoldingInfo` mkUnfolding top_lvl (cprInfo old_info) new_rhs
-
- final_id = new_bndr `setIdInfo` new_bndr_info
- in
- -- These seqs force the Ids, and hence the IdInfos, and hence any
- -- inner substitutions
- final_id `seq`
- addLetBind final_id new_rhs $
- modifyInScope new_bndr final_id thing_inside
+ = 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
+
+ -- 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
+
+ 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
where
- occ_info = idOccInfo old_bndr
+ 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}
+
%************************************************************************
%* *
\subsection{simplLazyBind}
-- Simplify the RHS
getSubstEnv `thenSmpl` \ rhs_se ->
- simplRhs top_lvl False {- Not ok to float unboxed -}
+ simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
(idType bndr')
rhs rhs_se $ \ rhs' ->
\begin{code}
simplRhs :: Bool -- True <=> Top level
-> Bool -- True <=> OK to float unboxed (speculative) bindings
- -> OutType -> InExpr -> SubstEnv
+ -- 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
- = -- Swizzle the inner lets past the big lambda (if any)
- -- and try eta expansion
- transformRhs rhs `thenSmpl` \ t_rhs ->
-
- -- Simplify it
- setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) ->
-
- -- Float lets out of RHS
+ = -- Simplify it
+ setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats1, (rhs_in_scope, rhs1)) ->
let
- (floats_out, rhs'') | float_ubx = (floats, rhs')
- | otherwise = splitFloats 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' $
- etaFirst 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
- etaFirst 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
--- Don't float any unlifted bindings out, because the context
+-- If float_ubx is true we float all the bindings, otherwise
+-- we just float until we come across an unlifted one.
+-- Remember that the unlifted bindings in the floats are all for
+-- guaranteed-terminating non-exception-raising unlifted things,
+-- which we are happy to do speculatively. However, we may still
+-- not be able to float them out, because the context
-- is either a Rec group, or the top level, neither of which
-- can tolerate them.
-splitFloats floats rhs
- = go floats
+splitFloats float_ubx floats rhs
+ | float_ubx = (floats, rhs) -- Float them all
+ | 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.
---
--- This defn isn't quite like
--- exprIsCheap (it ignores non-cheap args)
--- exprIsValue (may not say True for a lone variable)
--- which is slightly weird
-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}
case lookupIdSubst subst var of
DoneEx e -> zapSubstEnv (simplExprF e cont)
ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
- DoneId var1 occ -> WARN( not (isInScope var1 subst) && isLocallyDefined var1 && not (mayHaveNoBinding var1),
+ DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,
text "simplVar:" <+> ppr var )
- -- The mayHaveNoBinding test accouunts for the fact
- -- that class dictionary constructors dont have top level
- -- bindings and hence aren't in scope.
zapSubstEnv (completeCall var1 occ cont)
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
---------------------------------------------------------
-- Dealing with a call
-completeCall var occ cont
- = getBlackList `thenSmpl` \ black_list_fn ->
- getInScope `thenSmpl` \ in_scope ->
- getSwitchChecker `thenSmpl` \ chkr ->
+completeCall var occ_info cont
+ = getBlackList `thenSmpl` \ black_list_fn ->
+ getInScope `thenSmpl` \ in_scope ->
+ getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
+ getDOptsSmpl `thenSmpl` \ dflags ->
let
- dont_use_rules = switchIsOn chkr DontApplyRules
- no_case_of_case = switchIsOn chkr NoCaseOfCase
black_listed = black_list_fn var
+ arg_infos = [ interestingArg in_scope arg subst
+ | (arg, subst, _) <- args, isValArg arg]
+
+ interesting_cont = interestingCallContext (not (null args))
+ (not (null arg_infos))
+ call_cont
- (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
- discard_inline_cont | inline_call = discardInline cont
- | otherwise = cont
+ inline_cont | inline_call = discardInline cont
+ | otherwise = cont
- maybe_inline = callSiteInline 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
-
case maybe_inline of {
Just unfolding -- There is an inlining!
-> tick (UnfoldingDone var) `thenSmpl_`
- simplExprF unfolding discard_inline_cont
+ simplExprF unfolding inline_cont
;
Nothing -> -- No inlining!
+
+ simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' ->
+
-- Next, look for rules or specialisations that match
--
-- It's important to simplify the args first, because the rule-matcher
-- 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
- prepareArgs no_case_of_case var cont $ \ args' cont' ->
+ getSwitchChecker `thenSmpl` \ chkr ->
let
- maybe_rule | dont_use_rules = Nothing
- | otherwise = lookupRule in_scope var args'
+ maybe_rule | switchIsOn chkr DontApplyRules = Nothing
+ | otherwise = lookupRule in_scope var args'
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
- simplExprF rule_rhs cont' ;
+#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
-- Done
- rebuild (mkApps (Var var) args') cont'
+ rebuild (mkApps (Var var) args') call_cont
}}
-\end{code}
-\begin{code}
---------------------------------------------------------
--- Preparing arguments for a call
-
-prepareArgs :: Bool -- True if the no-case-of-case switch is on
- -> OutId -> SimplCont
- -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
-prepareArgs no_case_of_case fun orig_cont thing_inside
- = go [] demands orig_fun_ty orig_cont
- where
- orig_fun_ty = idType fun
- is_data_con = isDataConId fun
-
- (demands, result_bot)
- | no_case_of_case = ([], False) -- Ignore strictness info if the no-case-of-case
- -- flag is on. Strictness changes evaluation order
- -- and that can change full laziness
- | otherwise
- = case idStrictness fun of
- StrictnessInfo demands result_bot
- | not (demands `lengthExceeds` countValArgs orig_cont)
- -> -- Enough args, use the strictness given.
- -- For bottoming functions we used to pretend that the arg
- -- is lazy, so that we don't treat the arg as an
- -- interesting context. This avoids substituting
- -- top-level bindings for (say) strings into
- -- calls to error. But now we are more careful about
- -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
- (demands, result_bot)
-
- other -> ([], False) -- Not enough args, or no strictness
-
- -- Main game plan: loop through the arguments, simplifying
- -- each of them in turn. We carry with us a list of demands,
- -- and the type of the function-applied-to-earlier-args
-
- -- We've run out of demands, and the result is now bottom
- -- This deals with
- -- * case (error "hello") of { ... }
- -- * (error "Hello") arg
- -- * f (error "Hello") where f is strict
- -- etc
- go acc [] fun_ty cont
- | result_bot
- = tick_case_of_error cont `thenSmpl_`
- thing_inside (reverse acc) (discardCont cont)
-
- -- Type argument
- go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont)
- = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
- go (Type new_ty_arg : acc) ds (applyTy fun_ty new_ty_arg) cont
-
- -- Value argument
- go acc ds fun_ty (ApplyTo _ val_arg se cont)
- | not is_data_con -- Function isn't a data constructor
- = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
- go (new_arg : acc) ds' res_ty cont
-
- | exprIsTrivial val_arg -- Function is a data contstructor, arg is trivial
- = getInScope `thenSmpl` \ in_scope ->
- let
- new_arg = substExpr (mkSubst in_scope se) val_arg
- -- Simplify the RHS with inlining switched off, so that
- -- only absolutely essential things will happen.
+-- Simplifying the arguments of a call
+
+simplifyArgs :: Bool -- It's a data constructor
+ -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments
+ -> OutType -- Type of the continuation
+ -> ([OutExpr] -> SimplM OutExprStuff)
+ -> SimplM OutExprStuff
+
+-- Simplify the arguments to a call.
+-- This part of the simplifier may break the no-shadowing invariant
+-- Consider
+-- f (...(\a -> e)...) (case y of (a,b) -> e')
+-- where f is strict in its second arg
+-- If we simplify the innermost one first we get (...(\a -> e)...)
+-- Simplifying the second arg makes us float the case out, so we end up with
+-- case y of (a,b) -> f (...(\a -> e)...) e'
+-- So the output does not have the no-shadowing invariant. However, there is
+-- no danger of getting name-capture, because when the first arg was simplified
+-- we used an in-scope set that at least mentioned all the variables free in its
+-- static environment, and that is enough.
+--
+-- We can't just do innermost first, or we'd end up with a dual problem:
+-- case x of (a,b) -> f e (...(\a -> e')...)
+--
+-- I spent hours trying to recover the no-shadowing invariant, but I just could
+-- not think of an elegant way to do it. The simplifier is already knee-deep in
+-- continuations. We have to keep the right in-scope set around; AND we have
+-- to get the effect that finding (error "foo") in a strict arg position will
+-- discard the entire application and replace it with (error "foo"). Getting
+-- all this at once is TOO HARD!
+
+simplifyArgs is_data_con args cont_ty thing_inside
+ | not is_data_con
+ = go args thing_inside
+
+ | otherwise -- It's a data constructor, so we want
+ -- to switch off inlining in the arguments
-- If we don't do this, consider:
-- let x = +# p q in C {x}
-- 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!
- --
- -- It's important that the substitution *does* deal with case-binder synonyms:
- -- case x of y { True -> (x,1) }
- -- Here we must be sure to substitute y for x when simplifying the args of the pair,
- -- to increase the chances of being able to inline x. The substituter will do
- -- that because the x->y mapping is held in the in-scope set.
- in
- -- It's not always the case that the new arg will be trivial
- -- Consider f x
- -- where, in one pass, f gets substituted by a constructor,
- -- but x gets substituted by an expression (assume this is the
- -- unique occurrence of x). It doesn't really matter -- it'll get
- -- fixed up next pass. And it happens for dictionary construction,
- -- which mentions the wrapper constructor to start with.
-
- go (new_arg : acc) ds' res_ty cont
-
- | otherwise
- = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
- -- A data constructor whose argument is now non-trivial;
- -- so let/case bind it.
- newId arg_ty $ \ arg_id ->
- addNonRecBind arg_id new_arg $
- go (Var arg_id : acc) ds' res_ty cont
+ = getBlackList `thenSmpl` \ old_bl ->
+ setBlackList noInlineBlackList $
+ go args $ \ args' ->
+ setBlackList old_bl $
+ thing_inside args'
- where
- (arg_ty, res_ty) = splitFunTy fun_ty
- (dem, ds') = case ds of
- [] -> (wwLazy, [])
- (d:ds) -> (d,ds)
-
- -- We're run out of arguments and the result ain't bottom
- go acc ds fun_ty cont = thing_inside (reverse acc) cont
-
--- Boring: we must only record a tick if there was an interesting
--- continuation to discard. If not, we tick forever.
-tick_case_of_error (Stop _) = returnSmpl ()
-tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl ()
-tick_case_of_error other = tick BottomFound
-\end{code}
+ where
+ go [] thing_inside = thing_inside []
+ go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $ \ arg' ->
+ go args $ \ args' ->
+ thing_inside (arg':args')
+
+simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside
+ = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
+ thing_inside (Type new_ty_arg)
+
+simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside
+ = getInScope `thenSmpl` \ in_scope ->
+ let
+ arg_ty = substTy (mkSubst in_scope se) (exprType val_arg)
+ in
+ if not is_data_con then
+ -- An ordinary function
+ simplValArg arg_ty is_strict val_arg se cont_ty thing_inside
+ else
+ -- A data constructor
+ -- simplifyArgs has already switched off inlining, so
+ -- all we have to do here is to let-bind any non-trivial argument
+
+ -- It's not always the case that new_arg will be trivial
+ -- Consider f x
+ -- where, in one pass, f gets substituted by a constructor,
+ -- but x gets substituted by an expression (assume this is the
+ -- unique occurrence of x). It doesn't really matter -- it'll get
+ -- fixed up next pass. And it happens for dictionary construction,
+ -- which mentions the wrapper constructor to start with.
+ simplValArg arg_ty is_strict val_arg se cont_ty $ \ arg' ->
+
+ if exprIsTrivial arg' then
+ thing_inside arg'
+ else
+ newId SLIT("a") (exprType arg') $ \ arg_id ->
+ addNonRecBind arg_id arg' $
+ thing_inside (Var arg_id)
+\end{code}
%************************************************************************
(a) some might appear as a function argument, so we simply
replace static allocation with dynamic allocation:
l = <...>
- x = f x
+ x = f l
becomes
x = f <...>
OneOcc in_lam once -> not in_lam && once
-- Not inside a lambda, one occurrence ==> safe!
other -> False
-
-
-postInlineUnconditionally :: Bool -- Black listed
- -> OccInfo
- -> InId -> OutExpr -> Bool
- -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
- -- It returns True if it's ok to discard the binding and inline the
- -- RHS at every use site.
-
- -- NOTE: This isn't our last opportunity to inline.
- -- We're at the binding site right now, and
- -- we'll get another opportunity when we get to the ocurrence(s)
-
-postInlineUnconditionally black_listed occ_info bndr rhs
- | isExportedId bndr ||
- black_listed ||
- loop_breaker = False -- Don't inline these
- | otherwise = exprIsTrivial rhs -- Duplicating is free
- -- Don't inline even WHNFs inside lambdas; doing so may
- -- simply increase allocation when the function is called
- -- This isn't the last chance; see NOTE above.
- --
- -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
- -- Why? Because we don't even want to inline them into the
- -- RHS of constructor arguments. See NOTE above
- --
- -- 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.
- where
- loop_breaker = case occ_info of
- IAmALoopBreaker -> True
- other -> False
\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
-- Stop continuation
-rebuild expr (Stop _) = rebuild_done expr
+rebuild expr (Stop _ _) = rebuild_done expr
-- ArgOf continuation
rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr
-> 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 $
-- (using funResultTy) in mkDupableCont.
\end{code}
-simplCaseBinder checks whether the scrutinee is a variable, v.
-If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
-that way, there's a chance that v will now only be used once, and hence inlined.
+simplCaseBinder checks whether the scrutinee is a variable, v. If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
-There is a time we *don't* want to do that, namely when -fno-case-of-case
-is on. This happens in the first simplifier pass, and enhances full laziness.
-Here's the bad case:
+There is a time we *don't* want to do that, namely when
+-fno-case-of-case is on. This happens in the first simplifier pass,
+and enhances full laziness. Here's the bad case:
f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
If we eliminate the inner case, we trap it inside the I# v -> arm,
which might prevent some full laziness happening. I've seen this
let
ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ arg_tys = dataConArgTys data_con
+ (inst_tys ++ mkTyVarTys ex_tyvars')
in
- newIds (dataConArgTys
- data_con
- (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
+ newIds SLIT("a") arg_tys $ \ bndrs ->
returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
other -> returnSmpl filtered_alts
[] -> alts
other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
- missing_cons = [data_con | data_con <- tyConDataCons tycon,
+ missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon,
not (data_con `elem` handled_data_cons)]
handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++
[data_con | (DataAlt data_con, _, _) <- filtered_alts]
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
-- Bind the case-binder to (con args)
let
- unfolding = mkUnfolding False NoCPRInfo (mkAltExpr con vs' inst_tys')
+ unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
in
modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $
simplExprC rhs cont' `thenSmpl` \ rhs' ->
mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
= -- Build the RHS of the join point
- newId join_arg_ty ( \ arg_id ->
- cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
- returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
+ newId SLIT("a") join_arg_ty ( \ arg_id ->
+ 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
- newId (exprType join_rhs) $ \ join_id ->
+ -- We give it a "$j" name just so that for later amusement
+ -- we can identify any join points that don't end up as let-no-escapes
+ -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
+ newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) $ \ join_id ->
let
new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
-- Want to tick here so that we go round again,
-- and maybe copy or inline the code;
-- not strictly CaseOf Case
- addLetBind join_id join_rhs (thing_inside new_cont)
+ addLetBind (NonRec join_id join_rhs) $
+ thing_inside new_cont
mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
= mkDupableCont (funResultTy ty) cont $ \ cont' ->
if exprIsDupable arg' then
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
- newId (exprType arg') $ \ bndr ->
+ newId SLIT("a") (exprType arg') $ \ bndr ->
- tick (CaseOfCase bndr) `thenSmpl_`
+ tick (CaseOfCase bndr) `thenSmpl_`
-- Want to tick here so that we go round again,
-- and maybe copy or inline the code;
-- not strictly CaseOf Case
- addLetBind bndr arg' $
+ addLetBind (NonRec bndr arg') $
-- But what if the arg should be case-bound? We can't use
-- addNonRecBind here because its type is too specific.
-- This has been this way for a long time, so I'll leave it,
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')) ->
- extendInScopes [b | NonRec b _ <- 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
-- This is VITAL when the type of case_bndr is an unboxed pair (often the
-- case in I/O rich code. We aren't allowed a lambda bound
-- arg of unboxed tuple type, and indeed such a case_bndr is always dead
- addLetBinds alt_binds $
- thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont)))
-
-mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
-mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
+ thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont)))
+
+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' ->
- if (case cont of { Stop _ -> exprIsDupable rhs'; other -> False}) then
+ if (case cont of { Stop _ _ -> exprIsDupable rhs'; other -> False}) then
-- It is worth checking for a small RHS because otherwise we
-- get extra let bindings that may cause an extra iteration of the simplifier to
-- inline back in place. Quite often the rhs is just a variable or constructor.
-- 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
-- then 78
-- else 5
- then newId realWorldStatePrimTy $ \ rw_id ->
+ then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
)
`thenSmpl` \ (final_bndrs', final_args) ->
- newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-
- -- Notice that we make the lambdas into one-shot-lambdas. The
+ -- See comment about "$j" name above
+ 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