X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=5b68cc5f5d2d5d2413a44f16cb52813054739a9e;hp=dd2a22b63e96914c9986d05e7157de0df983e0f4;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=b812bfb914a0164f5ce3b206cb9769dc70253374 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index dd2a22b..effd245 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -8,66 +8,41 @@ module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), - SimplifierSwitch(..) - ) +import DynFlags import SimplMonad -import SimplEnv -import SimplUtils ( mkCase, mkLam, - SimplCont(..), DupFlag(..), LetRhsFlag(..), - mkRhsStop, mkBoringStop, pushContArgs, - contResultType, countArgs, contIsDupable, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArg, isStrictType, - preInlineUnconditionally, postInlineUnconditionally, - inlineMode, activeInline, activeRule - ) -import Id ( Id, idType, idInfo, idArity, isDataConWorkId, - idUnfolding, setIdUnfolding, isDeadBinder, - idNewDemandInfo, setIdInfo, - setIdOccInfo, zapLamIdInfo, setOneShotLambda - ) -import MkId ( eRROR_ID ) -import Literal ( mkStringLit ) -import IdInfo ( OccInfo(..), isLoopBreaker, - setArityInfo, zapDemandInfo, - setUnfoldingInfo, - occInfo - ) -import NewDemand ( isStrictDmd ) -import Unify ( coreRefineTys, dataConCanMatch ) -import DataCon ( DataCon, dataConTyCon, dataConRepStrictness, isVanillaDataCon, - dataConInstArgTys, dataConTyVars ) -import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe ) +import Type hiding ( substTy, extendTvSubst, substTyVar ) +import SimplEnv +import SimplUtils +import FamInstEnv ( FamInstEnv ) +import Id +import MkId ( seqId, realWorldPrimId ) +import MkCore ( mkImpossibleExpr ) +import Var +import IdInfo +import Name ( mkSystemVarName, isExternalName ) +import Coercion +import OptCoercion ( optCoercion ) +import FamInstEnv ( topNormaliseType ) +import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) +import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn -import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, callSiteInline ) -import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, - exprIsConApp_maybe, mkPiTypes, findAlt, - exprType, exprIsHNF, findDefault, mergeAlts, - exprOkForSpeculation, exprArity, - mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg - ) -import Rules ( lookupRule ) -import BasicTypes ( isMarkedStrict ) -import CostCentre ( currentCCS ) -import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, - splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe, - isTyVarTy, mkTyVarTys - ) -import Var ( tyVarKind, mkTyVar ) -import VarEnv ( elemVarEnv, emptyVarEnv ) -import TysPrim ( realWorldStatePrimTy ) -import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRec - ) -import Name ( mkSysTvName ) -import StaticFlags ( opt_PprStyle_Debug ) -import OrdList -import List ( nub ) -import Maybes ( orElse ) +import Demand ( isStrictDmd, splitStrictSig ) +import PprCore ( pprParendExpr, pprCoreExpr ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, + exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUtils +import qualified CoreSubst +import CoreArity ( exprArity ) +import Rules ( lookupRule, getRules ) +import BasicTypes ( isMarkedStrict, Arity ) +import CostCentre ( currentCCS, pushCCisNop ) +import TysPrim ( realWorldStatePrimTy ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) +import MonadUtils ( foldlM, mapAccumLM ) +import Maybes ( orElse ) +import Data.List ( mapAccumL ) import Outputable -import Util ( notNull, filterOut ) +import FastString \end{code} @@ -76,7 +51,7 @@ the simplifier is in SimplCore.lhs. ----------------------------------------- - *** IMPORTANT NOTE *** + *** 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 @@ -84,7 +59,7 @@ documented with simplifyArgs. ----------------------------------------- - *** IMPORTANT NOTE *** + *** IMPORTANT NOTE *** ----------------------------------------- Many parts of the simplifier return a bunch of "floats" as well as an expression. This is wrapped as a datatype SimplUtils.FloatsWith. @@ -95,76 +70,76 @@ be unlifted (with RHS ok-for-speculation). ----------------------------------------- - ORGANISATION OF FUNCTIONS + ORGANISATION OF FUNCTIONS ----------------------------------------- simplTopBinds - simplify all top-level binders - for NonRec, call simplRecOrTopPair - for Rec, call simplRecBind - - ------------------------------ -simplExpr (applied lambda) ==> simplNonRecBind + + ------------------------------ +simplExpr (applied lambda) ==> simplNonRecBind simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind - ------------------------------ -simplRecBind [binders already simplfied] + ------------------------------ +simplRecBind [binders already simplfied] - use simplRecOrTopPair on each pair in turn simplRecOrTopPair [binder already simplified] Used for: recursive bindings (top level and nested) - top-level non-recursive bindings - Returns: + top-level non-recursive bindings + Returns: - check for PreInlineUnconditionally - simplLazyBind simplNonRecBind Used for: non-top-level non-recursive bindings - beta reductions (which amount to the same thing) - Because it can deal with strict arts, it takes a - "thing-inside" and returns an expression + beta reductions (which amount to the same thing) + Because it can deal with strict arts, it takes a + "thing-inside" and returns an expression - check for PreInlineUnconditionally - simplify binder, including its IdInfo - if strict binding - simplStrictArg - mkAtomicArgs - completeNonRecX + simplStrictArg + mkAtomicArgs + completeNonRecX else - simplLazyBind - addFloats + simplLazyBind + addFloats -simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder] +simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder] Used for: binding case-binder and constr args in a known-constructor case - check for PreInLineUnconditionally - simplify binder - completeNonRecX - - ------------------------------ -simplLazyBind: [binder already simplified, RHS not] + + ------------------------------ +simplLazyBind: [binder already simplified, RHS not] Used for: recursive bindings (top level and nested) - top-level non-recursive bindings - non-top-level, but *lazy* non-recursive bindings - [must not be strict or unboxed] + top-level non-recursive bindings + non-top-level, but *lazy* non-recursive bindings + [must not be strict or unboxed] Returns floats + an augmented environment, not an expression - - substituteIdInfo and add result to in-scope - [so that rules are available in rec rhs] + - substituteIdInfo and add result to in-scope + [so that rules are available in rec rhs] - simplify rhs - mkAtomicArgs - float if exposes constructor or PAP - - completeLazyBind + - completeBind -completeNonRecX: [binder and rhs both simplified] +completeNonRecX: [binder and rhs both simplified] - if the the thing needs case binding (unlifted and not ok-for-spec) - build a Case + build a Case else - completeLazyBind - addFloats + completeBind + addFloats -completeLazyBind: [given a simplified RHS] - [used for both rec and non-rec bindings, top level and not] +completeBind: [given a simplified RHS] + [used for both rec and non-rec bindings, top level and not] - try PostInlineUnconditionally - add unfolding [this is the only place we add an unfolding] - add arity @@ -173,35 +148,35 @@ completeLazyBind: [given a simplified RHS] Right hand sides and arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In many ways we want to treat - (a) the right hand side of a let(rec), and - (b) a function argument +In many ways we want to treat + (a) the right hand side of a let(rec), and + (b) a function argument in the same way. But not always! In particular, we would like to leave these arguments exactly as they are, so they will match a RULE more easily. - - f (g x, h x) - g (+ x) + + f (g x, h x) + g (+ x) It's harder to make the rule match if we ANF-ise the constructor, or eta-expand the PAP: - f (let { a = g x; b = h x } in (a,b)) - g (\y. + x y) + f (let { a = g x; b = h x } in (a,b)) + g (\y. + x y) On the other hand if we see the let-defns - p = (g x, h x) - q = + x + p = (g x, h x) + q = + x then we *do* want to ANF-ise and eta-expand, so that p and q -can be safely inlined. +can be safely inlined. Even floating lets out is a bit dubious. For let RHS's we float lets out if that exposes a value, so that the value can be inlined more vigorously. For example - r = let x = e in (x,x) + r = let x = e in (x,x) Here, if we float the let out we'll expose a nice constructor. We did experiments that showed this to be a generally good thing. But it was a bad thing to float @@ -216,7 +191,7 @@ Eta expansion ~~~~~~~~~~~~~~ For eta expansion, we want to catch things like - case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r If the \x was on the RHS of a let, we'd eta expand to bring the two lambdas together. And in general that's a good thing to do. Perhaps @@ -225,235 +200,112 @@ expansion at a let RHS can concentrate solely on the PAP case. %************************************************************************ -%* * +%* * \subsection{Bindings} -%* * -%************************************************************************ - -\begin{code} -simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] - -simplTopBinds env binds - = -- Put all the top-level binders into scope at the start - -- 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. - simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> - simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> - freeTick SimplifierDone `thenSmpl_` - returnSmpl (floatBinds floats) - where - -- We need to track the zapped top-level binders, because - -- they should have their fragile IdInfo zapped (notably occurrence info) - -- That's why we run down binds and bndrs' simultaneously. - simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ()) - simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ()) - simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) -> - addFloats env floats $ \env -> - simpl_binds env binds (drop_bs bind bs) - - drop_bs (NonRec _ _) (_ : bs) = bs - drop_bs (Rec prs) bs = drop (length prs) bs - - simpl_bind env bind bs - = getDOptsSmpl `thenSmpl` \ dflags -> - if dopt Opt_D_dump_inlinings dflags then - pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs - else - simpl_bind1 env bind bs - - simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r - simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' -\end{code} - - -%************************************************************************ -%* * -\subsection{simplNonRec} -%* * +%* * %************************************************************************ -simplNonRecBind is used for - * non-top-level non-recursive lets in expressions - * beta reduction - -It takes - * An unsimplified (binder, rhs) pair - * The env for the RHS. It may not be the same as the - current env because the bind might occur via (\x.E) arg - -It uses the CPS form because the binding might be strict, in which -case we might discard the continuation: - let x* = error "foo" in (...x...) - -It needs to turn unlifted bindings into a @case@. They can arise -from, say: (\x -> e) (4# + 3#) - \begin{code} -simplNonRecBind :: SimplEnv - -> InId -- Binder - -> InExpr -> SimplEnv -- Arg, with its subst-env - -> OutType -- Type of thing computed by the context - -> (SimplEnv -> SimplM FloatsWithExpr) -- The body - -> SimplM FloatsWithExpr -#ifdef DEBUG -simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside - | isTyVar bndr - = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs) -#endif - -simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside - = simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside - -simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside - | preInlineUnconditionally env NotTopLevel bndr rhs - = tick (PreInlineUnconditionally bndr) `thenSmpl_` - thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs)) - - | isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let - = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence info in the substitution - simplNonRecBndr env bndr `thenSmpl` \ (env, bndr1) -> - simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> - - -- Now complete the binding and simplify the body - let - (env2,bndr2) = addLetIdInfo env1 bndr bndr1 - in - if needsCaseBinding bndr_ty rhs1 - then - thing_inside env2 `thenSmpl` \ (floats, body) -> - returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body) - [(DEFAULT, [], wrapFloats floats body)]) - else - completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside - - | otherwise -- Normal, lazy case - = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence info in the substitution - simplNonRecBndr env bndr `thenSmpl` \ (env, bndr') -> - simplLazyBind env NotTopLevel NonRecursive - bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> - addFloats env floats thing_inside - +simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv + +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- 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. + ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) + ; dflags <- getDOptsSmpl + ; let dump_flag = dopt Opt_D_verbose_core2core dflags + ; env2 <- simpl_binds dump_flag env1 binds0 + ; freeTick SimplifierDone + ; return env2 } where - bndr_ty = idType bndr -\end{code} - -A specialised variant of simplNonRec used when the RHS is already simplified, notably -in knownCon. It uses case-binding where necessary. - -\begin{code} -simplNonRecX :: SimplEnv - -> InId -- Old binder - -> OutExpr -- Simplified RHS - -> (SimplEnv -> SimplM FloatsWithExpr) - -> SimplM FloatsWithExpr - -simplNonRecX env bndr new_rhs thing_inside - | needsCaseBinding (idType bndr) new_rhs - -- Make this test *before* the preInlineUnconditionally - -- Consider case I# (quotInt# x y) of - -- I# v -> let w = J# v in ... - -- If we gaily inline (quotInt# x y) for v, we end up building an - -- extra thunk: - -- let w = J# (quotInt# x y) in ... - -- because quotInt# can fail. - = simplBinder env bndr `thenSmpl` \ (env, bndr') -> - thing_inside env `thenSmpl` \ (floats, body) -> - let body' = wrapFloats floats body in - returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')]) - - | preInlineUnconditionally env NotTopLevel bndr new_rhs - -- 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 ... - -- - -- Similarly, single occurrences can be inlined vigourously - -- e.g. case (f x, g y) of (a,b) -> .... - -- If a,b occur once we can avoid constructing the let binding for them. - = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) - - | otherwise - = simplBinder env bndr `thenSmpl` \ (env, bndr') -> - completeNonRecX env False {- Non-strict; pessimistic -} - bndr bndr' new_rhs thing_inside - -completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside - = mkAtomicArgs is_strict - True {- OK to float unlifted -} - new_rhs `thenSmpl` \ (aux_binds, rhs2) -> - - -- Make the arguments atomic if necessary, - -- adding suitable bindings - addAtomicBindsE env (fromOL aux_binds) $ \ env -> - completeLazyBind env NotTopLevel - old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) -> - addFloats env floats thing_inside + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + -- The dump-flag emits a trace for each top-level binding, which + -- helps to locate the tracing for inlining and rule firing + simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv + simpl_binds _ env [] = return env + simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $ + simpl_bind env bind + ; simpl_binds dump env' binds } + + trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) + trace_bind False _ = \x -> x + + simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs + simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r + where + (env', b') = addBndrRules env b (lookupRecBndr env b) \end{code} %************************************************************************ -%* * +%* * \subsection{Lazy bindings} -%* * +%* * %************************************************************************ simplRecBind is used for - * recursive bindings only + * recursive bindings only \begin{code} simplRecBind :: SimplEnv -> TopLevelFlag - -> [(InId, InExpr)] -> [OutId] - -> SimplM (FloatsWith SimplEnv) -simplRecBind env top_lvl pairs bndrs' - = go env pairs bndrs' `thenSmpl` \ (floats, env) -> - returnSmpl (flattenFloats floats, env) + -> [(InId, InExpr)] + -> SimplM SimplEnv +simplRecBind env0 top_lvl pairs0 + = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0 + ; env1 <- go (zapFloats env_with_info) triples + ; return (env0 `addRecFloats` env1) } + -- addFloats adds the floats from env1, + -- _and_ updates env0 with the in-scope set from env1 where - go env [] _ = returnSmpl (emptyFloats env, env) - - go env ((bndr, rhs) : pairs) (bndr' : bndrs') - = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) -> - addFloats env floats (\env -> go env pairs bndrs') -\end{code} + add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs)) + where + (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr) + + go env [] = return env + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs + ; go env' pairs } +\end{code} -simplRecOrTopPair is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings It assumes the binder has already been simplified, but not its IdInfo. \begin{code} simplRecOrTopPair :: SimplEnv - -> TopLevelFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -> InExpr -- The RHS and its environment - -> SimplM (FloatsWith SimplEnv) + -> TopLevelFlag + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM SimplEnv -- Returns an env that includes the binding -simplRecOrTopPair env top_lvl bndr bndr' rhs - | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline - = tick (PreInlineUnconditionally bndr) `thenSmpl_` - returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs)) +simplRecOrTopPair env top_lvl old_bndr new_bndr rhs + | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline + = do { tick (PreInlineUnconditionally old_bndr) + ; return (extendIdSubst env old_bndr (mkContEx env rhs)) } | otherwise - = simplLazyBind env top_lvl Recursive bndr bndr' rhs env - -- May not actually be recursive, but it doesn't matter + = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env + -- May not actually be recursive, but it doesn't matter \end{code} simplLazyBind is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings - * non-top-level *lazy* non-recursive bindings - -[Thus it deals with the lazy cases from simplNonRecBind, and all cases -from SimplRecOrTopBind] + * [simplRecOrTopPair] recursive bindings (whether top level or not) + * [simplRecOrTopPair] top-level non-recursive bindings + * [simplNonRecE] non-top-level *lazy* non-recursive bindings Nota bene: - 1. It assumes that the binder is *already* simplified, - and is in scope, but not its IdInfo + 1. It assumes that the binder is *already* simplified, + and is in scope, and its IdInfo too, except unfolding 2. It assumes that the binder type is lifted. @@ -462,104 +314,294 @@ Nota bene: \begin{code} simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM (FloatsWith SimplEnv) + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, unfolding + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM SimplEnv simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = let - (env1,bndr2) = addLetIdInfo env bndr bndr1 - rhs_env = setInScope rhs_se env1 - is_top_level = isTopLevel top_lvl - ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkRhsStop (idType bndr2) - in - -- Simplify the RHS; note the mkRhsStop, which tells - -- the simplifier that this is the RHS of a let. - simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) -> - - -- If any of the floats can't be floated, give up now - -- (The allLifted predicate says True for empty floats.) - if (not ok_float_unlifted && not (allLifted floats)) then - completeLazyBind env1 top_lvl bndr bndr2 - (wrapFloats floats rhs1) - else - - -- ANF-ise a constructor or PAP rhs - mkAtomicArgs False {- Not strict -} - ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> - - -- If the result is a PAP, float the floats out, else wrap them - -- By this time it's already been ANF-ised (if necessary) - if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case - completeLazyBind env1 top_lvl bndr bndr2 rhs2 - - else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then - -- WARNING: long dodgy argument coming up - -- WANTED: a better way to do this - -- - -- We can't use "exprIsCheap" instead of exprIsHNF, - -- because that causes a strictness bug. - -- x = let y* = E in case (scc y) of { T -> F; F -> T} - -- The case expression is 'cheap', but it's wrong to transform to - -- y* = E; x = case (scc y) of {...} - -- Either we must be careful not to float demanded non-values, or - -- we must use exprIsHNF for the test, which ensures that the - -- thing is non-strict. So exprIsHNF => bindings are non-strict - -- I think. The WARN below tests for this. - -- - -- We use exprIsTrivial here because we want to reveal lone variables. - -- E.g. let { x = letrec { y = E } in y } in ... - -- Here we definitely want to float the y=E defn. - -- exprIsHNF definitely isn't right for that. - -- - -- Again, the floated binding can't be strict; if it's recursive it'll - -- be non-strict; if it's non-recursive it'd be inlined. - -- - -- Note [SCC-and-exprIsTrivial] - -- If we have - -- y = let { x* = E } in scc "foo" x - -- then we do *not* want to float out the x binding, because - -- it's strict! Fortunately, exprIsTrivial replies False to - -- (scc "foo" x). - - -- 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 (a) arg' is a WHNF, or (b) it's going to top level - -- and so there can't be any 'will be demanded' bindings in the floats. - -- Hence the warning - ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)), - ppr (filter demanded_float (floatBinds floats)) ) - - tick LetFloatFromLet `thenSmpl_` ( - addFloats env1 floats $ \ env2 -> - addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> - completeLazyBind env3 top_lvl bndr bndr2 rhs2) + = do { let rhs_env = rhs_se `setInScope` env + (tvs, body) = case collectTyBinders rhs of + (tvs, body) | not_lam body -> (tvs,body) + | otherwise -> ([], rhs) + not_lam (Lam _ _) = False + not_lam _ = True + -- Do not do the "abstract tyyvar" thing if there's + -- a lambda inside, becuase it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce + + ; (body_env, tvs') <- simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in SimplUtils + + -- Simplify the RHS + ; (body_env1, body1) <- simplExprF body_env body mkRhsStop + -- ANF-ise a constructor or PAP rhs + ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 + + ; (env', rhs') + <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) + then -- No floating, revert to body1 + do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) + ; return (env, rhs') } + + else if null tvs then -- Simple floating + do { tick LetFloatFromLet + ; return (addFloats env body_env2, body2) } + + else -- Do type-abstraction first + do { tick LetFloatFromLet + ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 + ; rhs' <- mkLam env tvs' body3 + ; env' <- foldlM (addPolyBind top_lvl) env poly_binds + ; return (env', rhs') } + + ; completeBind env' top_lvl bndr bndr1 rhs' } +\end{code} - else - completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) +A specialised variant of simplNonRec used when the RHS is already simplified, +notably in knownCon. It uses case-binding where necessary. + +\begin{code} +simplNonRecX :: SimplEnv + -> InId -- Old binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv + +simplNonRecX env bndr new_rhs + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p } + = return env -- Here b is dead, and we avoid creating + | otherwise -- the binding b = (a,b) + = do { (env', bndr') <- simplBinder env bndr + ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things + +completeNonRecX :: TopLevelFlag -> SimplEnv + -> Bool + -> InId -- Old binder + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv + +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs + ; (env2, rhs2) <- + if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 + then do { tick LetFloatFromLet + ; return (addFloats env env1, rhs1) } -- Add the floats to the main env + else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS + ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 } +\end{code} + +{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX + Doing so risks exponential behaviour, because new_rhs has been simplified once already + In the cases described by the folowing commment, postInlineUnconditionally will + catch many of the relevant cases. + -- 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 ... + -- + -- Similarly, single occurrences can be inlined vigourously + -- e.g. case (f x, g y) of (a,b) -> .... + -- If a,b occur once we can avoid constructing the let binding for them. + + Furthermore in the case-binding case preInlineUnconditionally risks extra thunks + -- Consider case I# (quotInt# x y) of + -- I# v -> let w = J# v in ... + -- If we gaily inline (quotInt# x y) for v, we end up building an + -- extra thunk: + -- let w = J# (quotInt# x y) in ... + -- because quotInt# can fail. + + | preInlineUnconditionally env NotTopLevel bndr new_rhs + = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) +-} + +---------------------------------- +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) -#ifdef DEBUG -demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) - -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them -demanded_float (Rec _) = False -#endif +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does + +\begin{code} +prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Adds new floats to the env iff that allows us to return a good RHS +prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] + | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type + , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] + = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs + ; return (env', Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setDemandInfo` demandInfo info + info = idInfo id + +prepareRhs top_lvl env0 _ rhs0 + = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 + ; return (env1, rhs1) } + where + go n_val_args env (Cast rhs co) + = do { (is_exp, env', rhs') <- go n_val_args env rhs + ; return (is_exp, env', Cast rhs' co) } + go n_val_args env (App fun (Type ty)) + = do { (is_exp, env', rhs') <- go n_val_args env fun + ; return (is_exp, env', App rhs' (Type ty)) } + go n_val_args env (App fun arg) + = do { (is_exp, env', fun') <- go (n_val_args+1) env fun + ; case is_exp of + True -> do { (env'', arg') <- makeTrivial top_lvl env' arg + ; return (True, env'', App fun' arg') } + False -> return (False, env, App fun arg) } + go n_val_args env (Var fun) + = return (is_exp, env, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- OccurAnal.occAnalApp + + go _ env other + = return (False, env, other) \end{code} +Note [Float coercions] +~~~~~~~~~~~~~~~~~~~~~~ +When we find the binding + x = e `cast` co +we'd like to transform it to + x' = e + x = x `cast` co -- A trivial binding +There's a chance that e will be a constructor application or function, or something +like that, so moving the coerion to the usage site may well cancel the coersions +and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + x = T m + go 0 = 0 + go n = case x of { T m -> go (n-m) } + -- This case should optimise + +Note [Preserve strictness when floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Float coercions] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Float coercions (unlifted)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT don't do [Float coercions] if 'e' has an unlifted type. +This *can* happen: + + foo :: Int = (error (# Int,Int #) "urk") + `cast` CoUnsafe (# Int,Int #) Int + +If do the makeTrivial thing to the error call, we'll get + foo = case error (# Int,Int #) "urk" of v -> v `cast` ... +But 'v' isn't in scope! + +These strange casts can happen as a result of case-of-case + bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of + (# p,q #) -> p+q + + +\begin{code} +makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr + +makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo + -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +-- Returned SimplEnv has same substitution as incoming one +makeTrivialWithInfo top_lvl env info expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (env, expr) + | otherwise -- See Note [Take care] below + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "a") + var = mkLocalIdWithInfo name expr_ty info + ; env' <- completeNonRecX top_lvl env False var var expr + ; expr' <- simplVar env' var + ; return (env', expr') } + -- The simplVar is needed becase we're constructing a new binding + -- a = rhs + -- And if rhs is of form (rhs1 |> co), then we might get + -- a1 = rhs1 + -- a = a1 |> co + -- and now a's RHS is trivial and can be substituted out, and that + -- is what completeNonRecX will do + -- To put it another way, it's as if we'd simplified + -- let var = e in var + where + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl _ expr_ty + | isTopLevel top_lvl = not (isUnLiftedType expr_ty) + | otherwise = True +\end{code} + +Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tih + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +A case in point is literal strings (a MachStr is not regarded as +trivial): + + foo = Ptr "blob"# + +We don't want to ANF-ise this. + %************************************************************************ -%* * +%* * \subsection{Completing a lazy binding} -%* * +%* * %************************************************************************ -completeLazyBind - * deals only with Ids, not TyVars - * takes an already-simplified binder and RHS - * is used for both recursive and non-recursive bindings - * is used for both top-level and non-top-level bindings +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings It does the following: - tries discarding a dead binding @@ -568,80 +610,189 @@ It does the following: - add arity It does *not* attempt to do let-to-case. Why? Because it is used for - - top-level bindings (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing \begin{code} -completeLazyBind :: SimplEnv - -> TopLevelFlag -- Flag stuck into unfolding - -> InId -- Old binder - -> OutId -- New binder - -> OutExpr -- Simplified RHS - -> SimplM (FloatsWith SimplEnv) --- We return a new SimplEnv, because completeLazyBind may choose to do its work --- by extending the substitution (e.g. let x = y in ...) --- The new binding (if any) is returned as part of the floats. --- NB: the returned SimplEnv has the right SubstEnv, but you should --- (as usual) use the in-scope-env from the floats - -completeLazyBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding - = -- Drop the binding - tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - returnSmpl (emptyFloats env, extendIdSubst env 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 - - | otherwise - = let - -- Add arity info - new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs - - -- 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 - - -- If the unfolding is a value, the demand info may - -- go pear-shaped, so we nuke it. Example: - -- let x = (a,b) in - -- case x of (p,q) -> h p q x - -- Here x is certainly demanded. But after we've nuked - -- the case, we'll get just - -- let x = (a,b) in h a b x - -- and now x is not demanded (I'm assuming h is lazy) - -- This really happens. Similarly - -- let f = \x -> e in ...f..f... - -- After inling f at some of its call sites the original binding may - -- (for example) be no longer strictly demanded. - -- The solution here is a bit ad hoc... - info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding - final_info | loop_breaker = new_bndr_info - | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf - | otherwise = info_w_unf - - final_id = new_bndr `setIdInfo` final_info - in - -- These seqs forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - final_id `seq` - returnSmpl (unitFloat env final_id new_rhs, env) +completeBind :: SimplEnv + -> TopLevelFlag -- Flag stuck into unfolding + -> InId -- Old binder + -> OutId -> OutExpr -- New binder and RHS + -> SimplM SimplEnv +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt + +completeBind env top_lvl old_bndr new_bndr new_rhs + = do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info + + ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf + + ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding + -- Inline and discard the binding + then do { tick (PostInlineUnconditionally old_bndr) + ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $ + return (extendIdSubst env 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 + + else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } + +------------------------------ +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv +-- Add a new binding to the environment, complete with its unfolding +-- but *do not* do postInlineUnconditionally, because we have already +-- processed some of the scope of the binding +-- We still want the unfolding though. Consider +-- let +-- x = /\a. let y = ... in Just y +-- in body +-- Then we float the y-binding out (via abstractFloats and addPolyBind) +-- but 'x' may well then be inlined in 'body' in which case we'd like the +-- opportunity to inline 'y' too. + +addPolyBind top_lvl env (NonRec poly_id rhs) + = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding + -- Assumes that poly_id did not have an INLINE prag + -- which is perhaps wrong. ToDo: think about this + ; return (addNonRecWithUnf env poly_id rhs unfolding) } + +addPolyBind _ env bind@(Rec _) = return (extendFloats env bind) + -- Hack: letrecs are more awkward, so we extend "by steam" + -- without adding unfoldings etc. At worst this leads to + -- more simplifier iterations + +------------------------------ +addNonRecWithUnf :: SimplEnv + -> OutId -> OutExpr -- New binder and RHS + -> Unfolding -- New unfolding + -> SimplEnv +addNonRecWithUnf env new_bndr new_rhs new_unfolding + = let new_arity = exprArity new_rhs + old_arity = idArity new_bndr + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding - where - unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - loop_breaker = isLoopBreaker occ_info - old_info = idInfo old_bndr - occ_info = occInfo old_info -\end{code} + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 + final_id = new_bndr `setIdInfo` info3 + dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr + in + ASSERT( isId new_bndr ) + WARN( new_arity < old_arity || new_arity < dmd_arity, + (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity + <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) ) + -- Note [Arity decrease] + + final_id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + addNonRec env final_id new_rhs + -- The addNonRec adds it to the in-scope set too + +------------------------------ +simplUnfolding :: SimplEnv-> TopLevelFlag + -> Id + -> OccInfo -> OutExpr + -> Unfolding -> SimplM Unfolding +-- Note [Setting the new unfolding] +simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) + = return (DFunUnfolding ar con ops') + where + ops' = map (substExpr (text "simplUnfolding") env) ops + +simplUnfolding env top_lvl id _ _ + (CoreUnfolding { uf_tmpl = expr, uf_arity = arity + , uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src + = do { expr' <- simplExpr rule_env expr + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src + ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } + -- See Note [Top-level flag on inline rules] in CoreUnfold + where + act = idInlineActivation id + rule_env = updMode (updModeForInlineRules act) env + -- See Note [Simplifying gently inside InlineRules] in SimplUtils + +simplUnfolding _ top_lvl id _occ_info new_rhs _ + = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. +\end{code} + +Note [Arity decrease] +~~~~~~~~~~~~~~~~~~~~~ +Generally speaking the arity of a binding should not decrease. But it *can* +legitimately happen becuase of RULES. Eg + f = g Int +where g has arity 2, will have arity 2. But if there's a rewrite rule + g Int --> h +where h has arity 1, then f's arity will decrease. Here's a real-life example, +which is in the output of Specialise: + + Rec { + $dm {Arity 2} = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm #-} + + dInt = MkD .... opInt ... + opInt {Arity 1} = $dm dInt + + $s$dm {Arity 0} = \x. op dInt } + +Here opInt has arity 1; but when we apply the rule its arity drops to 0. +That's why Specialise goes to a little trouble to pin the right arity +on specialised functions too. + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *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 + +If there's an InlineRule on a loop breaker, we hang on to the inlining. +It's pretty dodgy, but the user did say 'INLINE'. May need to revisit +this choice. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... %************************************************************************ -%* * +%* * \subsection[Simplify-simplExpr]{The main function: simplExpr} -%* * +%* * %************************************************************************ The reason for this OutExprStuff stuff is that we want to float *after* @@ -650,682 +801,790 @@ behaviour as things float out. To see why it's important to do it after, consider this (real) example: - let t = f x - in fst t + let t = f x + in fst t ==> - let t = let a = e1 - b = e2 - in (a,b) - in fst t + let t = let a = e1 + b = e2 + in (a,b) + in fst t ==> - let a = e1 - b = e2 - t = (a,b) - in - a -- Can't inline a this round, cos it appears twice + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice ==> - e1 + e1 Each of the ==> steps is a round of simplification. We'd save a whole round if we float first. This can cascade. Consider - let f = g d - in \x -> ...f... + let f = g d + in \x -> ...f... ==> - let f = let d1 = ..d.. in \y -> e - in \x -> ...f... + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... ==> - let d1 = ..d.. - in \x -> ...(\y ->e)... + let d1 = ..d.. + in \x -> ...(\y ->e)... -Only in this second round can the \y be applied, and it +Only in this second round can the \y be applied, and it might do the same again. \begin{code} simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') - where - expr_ty' = substTy env (exprType expr) - -- The type in the Stop continuation, expr_ty', is usually not used - -- It's only needed when discarding continuations after finding - -- a function that returns bottom. - -- Hence the lazy substitution - +simplExpr env expr = simplExprC env expr mkBoringStop simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr - -- Simplify an expression, given a continuation -simplExprC env expr cont - = simplExprF env expr cont `thenSmpl` \ (floats, expr) -> - returnSmpl (wrapFloats floats expr) - -simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr - -- Simplify an expression, returning floated binds - -simplExprF env (Var v) cont = simplVar env v cont -simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont -simplExprF env expr@(Lam _ _) cont = simplLam env expr cont -simplExprF env (Note note expr) cont = simplNote env note expr cont -simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont) - -simplExprF env (Type ty) cont + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $ + do { (env', expr') <- simplExprF (zapFloats env) expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $ + return (wrapFloats env' expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplExprF env e cont + = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ + simplExprF' env e cont + +simplExprF' :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplExprF' env (Var v) cont = simplVarF env v cont +simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF' env (Note n expr) cont = simplNote env n expr cont +simplExprF' env (Cast body co) cont = simplCast env body co cont +simplExprF' env (App fun arg) cont = simplExprF env fun $ + ApplyTo NoDup arg env cont + +simplExprF' env expr@(Lam _ _) cont + = simplLam env (map zap bndrs) body cont + -- The main issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info. + where + n_args = countArgs cont + n_params = length bndrs + (bndrs, body) = collectBinders expr + zap | n_args >= n_params = \b -> b + | otherwise = \b -> if isTyCoVar b then b + else zapLamIdInfo b + -- NB: we count all the args incl type args + -- so we must count all the binders (incl type lambdas) + +simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) - simplType env ty `thenSmpl` \ ty' -> - rebuild env (Type ty') cont + do { ty' <- simplCoercion env ty + ; rebuild env (Type ty') cont } -simplExprF env (Case scrut bndr case_ty alts) cont +simplExprF' env (Case scrut bndr _ alts) cont | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) - = -- Simplify the scrutinee with a Select continuation + = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) | otherwise - = -- If case-of-case is off, simply simplify the case expression - -- in a vanilla Stop context, and rebuild the result around it - simplExprC env scrut case_cont `thenSmpl` \ case_expr' -> - rebuild env case_expr' cont + = -- If case-of-case is off, simply simplify the case expression + -- in a vanilla Stop context, and rebuild the result around it + do { case_expr' <- simplExprC env scrut case_cont + ; rebuild env case_expr' cont } where - case_cont = Select NoDup bndr alts env (mkBoringStop case_ty') - case_ty' = substTy env case_ty -- c.f. defn of simplExpr - -simplExprF env (Let (Rec pairs) body) cont - = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down + case_cont = Select NoDup bndr alts env mkBoringStop - simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> - addFloats env floats $ \ env -> - simplExprF env body cont +simplExprF' env (Let (Rec pairs) body) cont + = do { env' <- simplRecBndrs env (map fst pairs) + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down --- A non-recursive let is dealt with by simplNonRecBind -simplExprF env (Let (NonRec bndr rhs) body) cont - = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env -> - simplExprF env body cont + ; env'' <- simplRecBind env' NotTopLevel pairs + ; simplExprF env'' body cont } +simplExprF' env (Let (NonRec bndr rhs) body) cont + = simplNonRecE env bndr (rhs, env) ([], body) cont --------------------------------- simplType :: SimplEnv -> InType -> SimplM OutType - -- Kept monadic just so we can do the seqType + -- Kept monadic just so we can do the seqType simplType env ty - = seqType new_ty `seq` returnSmpl new_ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty where new_ty = substTy env ty + +--------------------------------- +simplCoercion :: SimplEnv -> InType -> SimplM OutType +-- The InType isn't *necessarily* a coercion, but it might be +-- (in a type application, say) and optCoercion is a no-op on types +simplCoercion env co + = seqType new_co `seq` return new_co + where + new_co = optCoercion (getTvSubst env) co +\end{code} + + +%************************************************************************ +%* * +\subsection{The main rebuilder} +%* * +%************************************************************************ + +\begin{code} +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant +-- only the in-scope set and floats should matter +rebuild env expr cont0 + = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $ + case cont0 of + Stop {} -> return (env, expr) + CoerceIt co cont -> rebuild env (mkCoerce co expr) cont + Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont + StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont + StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + ; simplLam env' bs body cont } + ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg + ; rebuild env (App expr arg') cont } \end{code} %************************************************************************ -%* * +%* * \subsection{Lambdas} -%* * +%* * %************************************************************************ \begin{code} -simplLam env fun cont - = go env fun cont - where - zap_it = mkLamBndrZapper fun (countArgs cont) - cont_ty = contResultType cont - - -- Type-beta reduction - go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) - = ASSERT( isTyVar bndr ) - tick (BetaReduction bndr) `thenSmpl_` - simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' -> - go (extendTvSubst env bndr ty_arg') body body_cont - - -- Ordinary beta reduction - go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) - = tick (BetaReduction bndr) `thenSmpl_` - simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env -> - go env body body_cont - - -- Not enough args, so there are real lambdas left to put in the result - go env lam@(Lam _ _) cont - = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') -> - simplExpr env body `thenSmpl` \ body' -> - mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) -> - addFloats env floats $ \ env -> - rebuild env new_lam cont - where - (bndrs,body) = collectBinders lam - - -- Exactly enough args - go env expr cont = simplExprF env expr cont - -mkLamBndrZapper :: CoreExpr -- Function - -> Int -- Number of args supplied, *including* type args - -> Id -> Id -- Use this to zap the binders -mkLamBndrZapper fun n_args - | n_args >= n_params fun = \b -> b -- Enough args - | otherwise = \b -> zapLamIdInfo b +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- simplCoercion env co0 + ; simplExprF env body (addCoerce co1 cont0) } where - -- NB: we count all the args incl type args - -- so we must count all the binders (incl type lambdas) - n_params (Note _ e) = n_params e - n_params (Lam b e) = 1 + n_params e - n_params other = 0::Int + addCoerce co cont = add_coerce co (coercionKind co) cont + + add_coerce _co (s1, k1) cont -- co :: ty~ty + | s1 `coreEqType` k1 = cont -- is a no-op + + add_coerce co1 (s1, _k2) (CoerceIt co2 cont) + | (_l1, t1) <- coercionKind co2 + -- e |> (g1 :: S1~L) |> (g2 :: L~T1) + -- ==> + -- e, if S1=T1 + -- e |> (g1 . g2 :: S1~T1) 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 + , s1 `coreEqType` t1 = cont -- The coerces cancel out + | otherwise = CoerceIt (mkTransCoercion co1 co2) cont + + add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) + -- (f |> g) ty ---> (f ty) |> (g @ ty) + -- This implements the PushT and PushC rules from the paper + | Just (tyvar,_) <- splitForAllTy_maybe s1s2 + = let + (new_arg_ty, new_cast) + | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule + | otherwise = (ty', mkInstCoercion co ty') -- PushT rule + in + ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont) + where + ty' = substTy (arg_se `setInScope` env) arg_ty + new_arg_co = mkCsel1Coercion co `mkTransCoercion` + ty' `mkTransCoercion` + mkSymCoercion (mkCsel2Coercion co) + + add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) + | not (isTypeArg arg) -- This implements the Push rule from the paper + , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied + -- (e |> (g :: s1s2 ~ t1->t2)) f + -- ===> + -- (e (f |> (arg g :: t1~s1)) + -- |> (res g :: s2->t2) + -- + -- t1t2 must be a function type, t1->t2, because it's applied + -- to something 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. It's a bit messy. + -- But it isn't a common case. + -- + -- Example of use: Trac #995 + = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont) + where + -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and + -- t2 ~ s2 with left and right on the curried form: + -- (->) t1 t2 ~ (->) s1 s2 + [co1, co2] = decomposeCo 2 co + new_arg = mkCoerce (mkSymCoercion co1) arg' + arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg + + add_coerce co _ cont = CoerceIt co cont \end{code} %************************************************************************ -%* * -\subsection{Notes} -%* * +%* * +\subsection{Lambdas} +%* * %************************************************************************ \begin{code} -simplNote env (Coerce to from) body cont - = let - addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic - -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the - -- two are the same. This happens a lot in Happy-generated parsers - | s1 `coreEqType` k1 = cont - - 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 `coreEqType` 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) - | not (isTypeArg arg), -- This whole case only works for value args - -- Could upgrade to have equiv thing for type apps too - 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, because it's applied to something - -- 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. It's a bit messy. - -- But it isn't a common case. - = let - (t1,t2) = splitFunTy t1t2 - new_arg = mkCoerce2 s1 t1 (substExpr arg_env arg) - arg_env = setInScope arg_se env - in - ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) - - addCoerce to' _ cont = CoerceIt to' cont - in - simplType env to `thenSmpl` \ to' -> - simplType env from `thenSmpl` \ from' -> - simplExprF env body (addCoerce to' from' cont) +simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplLam env [] body cont = simplExprF env body cont + + -- Beta reduction +simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) + = do { tick (BetaReduction bndr) + ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } + + -- Not enough args, so there are real lambdas left to put in the result +simplLam env bndrs body cont + = do { (env', bndrs') <- simplLamBndrs env bndrs + ; body' <- simplExpr env' body + ; new_lam <- mkLam env' bndrs' body' + ; rebuild env' new_lam cont } + +------------------ +simplNonRecE :: SimplEnv + -> InBndr -- The binder + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> ([InBndr], InExpr) -- Body of the let/lambda + -- \xs.e + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive lets in expressions +-- * beta reduction +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process +-- +-- The "body" of the binding comes as a pair of ([InId],InExpr) +-- representing a lambda; so we recurse back to simplLam +-- Why? Because of the binder-occ-info-zapping done before +-- the call to simplLam in simplExprF (Lam ...) + + -- First deal with type applications and type lets + -- (/\a. e) (Type ty) and (let a = Type ty in e) +simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont + = ASSERT( isTyCoVar bndr ) + do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg + ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } + +simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont + | preInlineUnconditionally env NotTopLevel bndr rhs + = do { tick (PreInlineUnconditionally bndr) + ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - --- Hack: we only distinguish subsumed cost centre stacks for the purposes of --- inlining. All other CCCSs are mapped to currentCCS. -simplNote env (SCC cc) e cont - = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' -> - rebuild env (mkSCC cc e') cont + | isStrictId bndr + = do { simplExprF (rhs_se `setFloats` env) rhs + (StrictBind bndr bndrs body env cont) } -simplNote env InlineCall e cont - = simplExprF env e (InlinePlease cont) + | otherwise + = ASSERT( not (isTyCoVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 + ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; simplLam env3 bndrs body cont } +\end{code} --- See notes with SimplMonad.inlineMode -simplNote env InlineMe e cont - | contIsRhsOrArg cont -- Totally boring continuation; see notes above - = -- Don't inline inside an INLINE expression - simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' -> - rebuild env (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 env e cont +%************************************************************************ +%* * +\subsection{Notes} +%* * +%************************************************************************ + +\begin{code} +-- Hack alert: we only distinguish subsumed cost centre stacks for the +-- purposes of inlining. All other CCCSs are mapped to currentCCS. +simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplNote env (SCC cc) e cont + | pushCCisNop cc (getEnclosingCC env) -- scc "f" (...(scc "f" e)...) + = simplExprF env e cont -- ==> scc "f" (...e...) + | otherwise + = do { e' <- simplExpr (setEnclosingCC env currentCCS) e + ; rebuild env (mkSCC cc e') cont } simplNote env (CoreNote s) e cont - = simplExpr env e `thenSmpl` \ e' -> - rebuild env (Note (CoreNote s) e') cont + = do { e' <- simplExpr env e + ; rebuild env (Note (CoreNote s) e') cont } \end{code} %************************************************************************ -%* * -\subsection{Dealing with calls} -%* * +%* * + Variables +%* * %************************************************************************ \begin{code} -simplVar env var cont +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyCoVar var + = return (Type (substTyVar env var)) + | otherwise = case substId env var of - DoneEx e -> simplExprF (zapSubstEnv env) e cont - ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont - -- Note [zapSubstEnv] - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! - ---------------------------------------------------------- --- Dealing with a call site - -completeCall env var occ_info cont - = -- Simplify the arguments - getDOptsSmpl `thenSmpl` \ dflags -> - let - chkr = getSwitchChecker env - (args, call_cont, inline_call) = getContArgs chkr var cont - fn_ty = idType var - in - simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args -> - - -- Next, look for rules or specialisations that match - -- - -- It's important to simplify the args first, because the rule-matcher - -- doesn't do substitution as it goes. We don't want to use subst_args - -- (defined in the 'where') because that throws away useful occurrence info, - -- and perhaps-very-important specialisations. - -- - -- Some functions have specialisations *and* are strict; in this case, - -- we don't want to inline the wrapper of the non-specialised thing; better - -- to call the specialised thing instead. - -- We used to use the black-listing mechanism to ensure that inlining of - -- the wrapper didn't occur for things that have specialisations till a - -- later phase, so but now we just try RULES 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 - - let - in_scope = getInScope env - rules = getRules env - maybe_rule = case activeRule env of - Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope rules var args - in - case maybe_rule of { - Just (rule_name, rule_rhs) -> - tick (RuleFired rule_name) `thenSmpl_` - (if dopt Opt_D_dump_inlinings dflags then - pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ftext rule_name, - text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "After: " <+> pprCoreExpr rule_rhs, - text "Cont: " <+> ppr call_cont]) - else - id) $ - simplExprF env rule_rhs call_cont ; - - Nothing -> -- No rules - - -- Next, look for an inlining - let - arg_infos = [ interestingArg arg | arg <- args, isValArg arg] + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e - interesting_cont = interestingCallContext (notNull args) - (notNull arg_infos) - call_cont +simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplVarF env var cont + = case substId env var of + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont + DoneId var1 -> completeCall env var1 cont + -- Note [zapSubstEnv] + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! - active_inline = activeInline env var occ_info - maybe_inline = callSiteInline dflags active_inline inline_call occ_info - var arg_infos interesting_cont - in - case maybe_inline of { - Just unfolding -- There is an inlining! - -> tick (UnfoldingDone var) `thenSmpl_` - (if dopt Opt_D_dump_inlinings dflags then - pprTrace "Inlining done" (vcat [ - text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> ppr unfolding, - text "Cont: " <+> ppr call_cont]) - else - id) $ - makeThatCall env var unfolding args call_cont - - ; - Nothing -> -- No inlining! - - -- Done - rebuild env (mkApps (Var var) args) call_cont - }} - -makeThatCall :: SimplEnv - -> Id - -> InExpr -- Inlined function rhs - -> [OutExpr] -- Arguments, already simplified - -> SimplCont -- After the call - -> SimplM FloatsWithExpr --- Similar to simplLam, but this time --- the arguments are already simplified -makeThatCall orig_env var fun@(Lam _ _) args cont - = go orig_env fun args +--------------------------------------------------------- +-- Dealing with a call site + +completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) +completeCall env var cont + = do { ------------- Try inlining ---------------- + dflags <- getDOptsSmpl + ; let (lone_variable, arg_infos, call_cont) = contArgs cont + -- The args are OutExprs, obtained by *lazily* substituting + -- in the args found in cont. These args are only examined + -- to limited depth (unless a rule fires). But we must do + -- the substitution; rule matching on un-simplified args would + -- be bogus + + n_val_args = length arg_infos + interesting_cont = interestingCallContext call_cont + unfolding = activeUnfolding env var + maybe_inline = callSiteInline dflags var unfolding + lone_variable arg_infos interesting_cont + ; case maybe_inline of { + Just expr -- There is an inlining! + -> do { tick (UnfoldingDone var) + ; trace_inline dflags expr cont $ + simplExprF (zapSubstEnv env) expr cont } + + ; Nothing -> do -- No inlining! + + { rule_base <- getSimplRules + ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont + ; rebuildCall env info cont + }}} where - zap_it = mkLamBndrZapper fun (length args) - - -- Type-beta reduction - go env (Lam bndr body) (Type ty_arg : args) - = ASSERT( isTyVar bndr ) - tick (BetaReduction bndr) `thenSmpl_` - go (extendTvSubst env bndr ty_arg) body args - - -- Ordinary beta reduction - go env (Lam bndr body) (arg : args) - = tick (BetaReduction bndr) `thenSmpl_` - simplNonRecX env (zap_it bndr) arg $ \ env -> - go env body args - - -- Not enough args, so there are real lambdas left to put in the result - go env fun args - = simplExprF env fun (pushContArgs orig_env args cont) - -- NB: orig_env; the correct environment to capture with - -- the arguments.... env has been augmented with substitutions - -- from the beta reductions. + trace_inline dflags unfolding cont stuff + | not (dopt Opt_D_dump_inlinings dflags) = stuff + | not (dopt Opt_D_verbose_core2core dflags) + = if isExternalName (idName var) then + pprTrace "Inlining done:" (ppr var) stuff + else stuff + | otherwise + = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont]) + stuff + +rebuildCall :: SimplEnv + -> ArgInfo + -> SimplCont + -> SimplM (SimplEnv, OutExpr) +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see SimplUtils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + = return (env, mk_coerce res) -- contination to discard, else we do it + where -- again and again! + res = mkApps (Var fun) (reverse rev_args) + res_ty = exprType res + cont_ty = contResultType env res_ty cont + co = mkUnsafeCoercion res_ty cont_ty + mk_coerce expr | cont_ty `coreEqType` res_ty = expr + | otherwise = mkCoerce co expr + +rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) + = do { ty' <- simplCoercion (se `setInScope` env) arg_ty + ; rebuildCall env (info `addArgTo` Type ty') cont } + +rebuildCall env info@(ArgInfo { ai_encl = encl_rules + , ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyTo _ arg arg_se cont) + | str -- Strict argument + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setFloats` env) arg + (StrictArg info' cci cont) + -- Note [Shadowing] + + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScope` env) arg + (mkLazyArgStop cci) + ; rebuildCall env (addArgTo info' arg') cont } + where + info' = info { ai_strs = strs, ai_discs = discs } + cci | encl_rules || disc > 0 = ArgCtxt encl_rules -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + = do { -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULEs apply to simplified arguments] + -- See also Note [Rules for recursive functions] + ; let args = reverse rev_args + env' = zapSubstEnv env + ; mb_rule <- tryRules env rules fun args cont + ; case mb_rule of { + Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ + pushArgs env' (drop n_args args) cont ; + -- n_args says how many args the rule consumed + ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules + } } +\end{code} -makeThatCall env var fun args cont - = simplExprF env fun (pushContArgs env args cont) -\end{code} +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweeep. + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +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! %************************************************************************ -%* * -\subsection{Arguments} -%* * +%* * + Rewrite rules +%* * %************************************************************************ \begin{code} ---------------------------------------------------------- --- Simplifying the arguments of a call - -simplifyArgs :: SimplEnv - -> OutType -- Type of the function - -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments - -> OutType -- Type of the continuation - -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr) - -> SimplM FloatsWithExpr - --- [CPS-like because of strict arguments] - --- 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 env fn_ty args cont_ty thing_inside - = go env fn_ty args thing_inside - where - go env fn_ty [] thing_inside = thing_inside env [] - go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' -> - go env (applyTypeToArg fn_ty arg') args $ \ env args' -> - thing_inside env (arg':args') - -simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside - = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg -> - thing_inside env (Type new_ty_arg) - -simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside - | is_strict - = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside - - | otherwise -- Lazy argument - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = simplExprC (setInScope arg_se env) val_arg - (mkBoringStop arg_ty) `thenSmpl` \ arg1 -> - thing_inside env arg1 +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [OutExpr] -> SimplCont + -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of + -- args consumed by the rule +tryRules env rules fn args call_cont + | null rules + = return Nothing + | otherwise + = do { dflags <- getDOptsSmpl + ; case activeRule dflags env of { + Nothing -> return Nothing ; -- No rules apply + Just act_fn -> + case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of { + Nothing -> return Nothing ; -- No rule matches + Just (rule, rule_rhs) -> + + do { tick (RuleFired (ru_name rule)) + ; trace_dump dflags rule rule_rhs $ + return (Just (ruleArity rule, rule_rhs)) }}}} where - arg_ty = funArgTy fn_ty - - -simplStrictArg :: LetRhsFlag - -> SimplEnv -- The env of the call - -> InExpr -> SimplEnv -- The arg plus its env - -> OutType -- arg_ty: type of the argument - -> OutType -- cont_ty: Type of thing computed by the context - -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) - -- Takes an expression of type rhs_ty, - -- returns an expression of type cont_ty - -- The env passed to this continuation is the - -- env of the call, plus any new in-scope variables - -> SimplM FloatsWithExpr -- An expression of type cont_ty - -simplStrictArg is_rhs call_env arg arg_env arg_ty cont_ty thing_inside - = simplExprF (setInScope arg_env call_env) arg - (ArgOf is_rhs arg_ty cont_ty (\ new_env -> thing_inside (setInScope call_env new_env))) - -- Notice the way we use arg_env (augmented with in-scope vars from call_env) - -- to simplify the argument - -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation + trace_dump dflags rule rule_rhs stuff + | not (dopt Opt_D_dump_rule_firings dflags) = stuff + | not (dopt Opt_D_verbose_core2core dflags) + + = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff + | otherwise + = pprTrace "Rule fired" + (vcat [text "Rule:" <+> ftext (ru_name rule), + text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), + text "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) + stuff \end{code} +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 + %************************************************************************ -%* * -\subsection{mkAtomicArgs} -%* * +%* * + Rebuilding a cse expression +%* * %************************************************************************ -mkAtomicArgs takes a putative RHS, checks whether it's a PAP or -constructor application and, if so, converts it to ANF, so that the -resulting thing can be inlined more easily. Thus - x = (f a, g b) -becomes - t1 = f a - t2 = g b - x = (t1,t2) - -There are three sorts of binding context, specified by the two -boolean arguments +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: -Strict - OK-unlifted + case x# of ===> e[x#/y#] + y# -> e -N N Top-level or recursive Only bind args of lifted type +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! -N Y Non-top-level and non-recursive, Bind args of lifted type, or - but lazy unlifted-and-ok-for-speculation +The code in SimplUtils.prepareAlts has the effect of generalise this +idea to look for a case where we're scrutinising a variable, and we +know that only the default case can match. For example: -Y Y Non-top-level, non-recursive, Bind all args - and strict (demanded) - + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... -For example, given +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. - x = MkC (y div# z) +We also make sure that we deal with this very common case: -there is no point in transforming to + case e of + x -> ...x... - x = case (y div# z) of r -> MkC r +Here we are using the case as a strict let; if x is used only once +then we want to inline it. We have to be careful that this doesn't +make the program terminate when it would have diverged before, so we +check that + - e is already evaluated (it may so if e is a variable) + - x is used strictly, or -because the (y div# z) can't float out of the let. But if it was -a *strict* let, then it would be a good thing to do. Hence the -context information. +Lastly, the code in SimplUtils.mkCase combines identical RHSs. So -\begin{code} -mkAtomicArgs :: Bool -- A strict binding - -> Bool -- OK to float unlifted args - -> OutExpr - -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include - OutExpr) -- things that need case-binding, - -- if the strict-binding flag is on + case e of ===> case e of DEFAULT -> r + True -> r + False -> r -mkAtomicArgs is_strict ok_float_unlifted rhs - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP - = go fun nilOL [] args -- Have a go +Now again the case may be elminated by the CaseElim transformation. - | otherwise = bale_out -- Give up - where - bale_out = returnSmpl (nilOL, rhs) - - go fun binds rev_args [] - = returnSmpl (binds, mkApps (Var fun) (reverse rev_args)) - - go fun binds rev_args (arg : args) - | exprIsTrivial arg -- Easy case - = go fun binds (arg:rev_args) args - - | not can_float_arg -- Can't make this arg atomic - = bale_out -- ... so give up - - | otherwise -- Don't forget to do it recursively - -- E.g. x = a:b:c:[] - = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> - newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> - go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) - (Var arg_id : rev_args) args - where - arg_ty = exprType arg - can_float_arg = is_strict - || not (isUnLiftedType arg_ty) - || (ok_float_unlifted && exprOkForSpeculation arg) - - -addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)] - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) -addAtomicBinds env [] thing_inside = thing_inside env -addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env -> - addAtomicBinds env bs thing_inside - -addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)] - -> (SimplEnv -> SimplM FloatsWithExpr) - -> SimplM FloatsWithExpr --- Same again, but this time we're in an expression context, --- and may need to do some case bindings - -addAtomicBindsE env [] thing_inside - = thing_inside env -addAtomicBindsE env ((v,r):bs) thing_inside - | needsCaseBinding (idType v) r - = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) -> - WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr ) - (let body = wrapFloats floats expr in - returnSmpl (emptyFloats env, Case r v (exprType body) [(DEFAULT,[],body)])) +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print - | otherwise - = addAuxiliaryBind env (NonRec v r) $ \ env -> - addAtomicBindsE env bs thing_inside -\end{code} +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: State# RealWorld -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: -%************************************************************************ -%* * -\subsection{The main rebuilder} -%* * -%************************************************************************ +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x -\begin{code} -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr +At a particular call site we have (f v 1). So we inline to get -rebuild env expr (Stop _ _ _) = rebuildDone env expr -rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr -rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont -rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont -rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont -rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont + if v < 0 then jtos x + else if 1==0 then "" else jtos x -rebuildApp env fun arg cont - = simplExpr env arg `thenSmpl` \ arg' -> - rebuild env (App fun arg') cont +Now simplify the 1==0 conditional: -rebuildDone env expr = returnSmpl (emptyFloats env, expr) -\end{code} + if v<0 then jtos v else jtos v +Now common-up the two branches of the case: -%************************************************************************ -%* * -\subsection{Functions dealing with a case} -%* * -%************************************************************************ + case (v<0) of DEFAULT -> jtos v -Blob of helper functions for the "case-of-something-else" situation. +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. \begin{code} --------------------------------------------------------- --- Eliminate the case if possible +-- Eliminate the case if possible -rebuildCase :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Alternatives (inceasing order) - -> SimplCont - -> SimplM FloatsWithExpr +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (inceasing order) + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- rebuildCase env scrut case_bndr alts cont - | Just (con,args) <- exprIsConApp_maybe scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - = knownCon env (DataAlt con) args case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs bs rhs } + + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + = do { tick (KnownBranch case_bndr) + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs + Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs bs rhs = ASSERT( null bs ) + do { env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } + + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont + -- See if we can get rid of the case altogether + -- See Note [Case eliminiation] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + | all isDeadBinder bndrs -- bndrs are [InId] + + -- Check that the scrutinee can be let-bound instead of case-bound + , exprOkForSpeculation scrut + -- OK not to evaluate it + -- This includes things like (==# a# b#)::Bool + -- so that we simplify + -- case ==# a# b# of { True -> x; False -> x } + -- to just + -- x + -- This particular example shows up in default methods for + -- comparision operations (e.g. in (>=) for Int.Int32) + || exprIsHNF scrut -- It's already evaluated + || var_demanded_later scrut -- It'll be demanded later + +-- || not opt_SimplPedanticBottoms) -- Or we don't care! +-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on, +-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate +-- its argument: case x of { y -> dataToTag# y } +-- Here we must *not* discard the case, because dataToTag# just fetches the tag from +-- the info pointer. So we'll be pedantic all the time, and see if that gives any +-- other problems +-- Also we don't want to discard 'seq's + = do { tick (CaseElim case_bndr) + ; env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } + where + -- The case binder is going to be evaluated later, + -- and the scrutinee is a simple variable + var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr) + && not (isTickBoxOp v) + -- ugly hack; covering this case is what + -- exprOkForSpeculation was intended for. + var_demanded_later _ = False + +-------------------------------------------------- +-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont + | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' + = do { let rhs' = substExpr (text "rebuild-case") env rhs + out_args = [Type (substTy env (idType case_bndr)), + Type (exprType rhs'), scrut, rhs'] + -- Lazily evaluated, so we don't do most of this + + ; rule_base <- getSimplRules + ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont + ; case mb_rule of + Just (n_args, res) -> simplExprF (zapSubstEnv env) + (mkApps res (drop n_args out_args)) + cont + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } - | Lit lit <- scrut -- No need for same treatment as constructors - -- because literals are inlined more vigorously - = knownCon env (LitAlt lit) [] case_bndr alts cont +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont - | otherwise - = -- Prepare the continuation; - -- The new subst_env is in place - prepareCaseCont env alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> - addFloats env floats $ \ env -> - - let - -- The case expression is annotated with the result type of the continuation - -- This may differ from the type originally on the case. For example - -- case(T) (case(Int#) a of { True -> 1#; False -> 0# }) of - -- a# -> - -- ===> - -- let j a# = - -- in case(T) a of { True -> j 1#; False -> j 0# } - -- Note that the case that scrutinises a now returns a T not an Int# - res_ty' = contResultType dup_cont - in +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- - -- Deal with case binder - simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') -> +reallyRebuildCase env scrut case_bndr alts cont + = do { -- Prepare the continuation; + -- The new subst_env is in place + (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont - -- Deal with the case alternatives - simplAlts alt_env scrut case_bndr' alts dup_cont `thenSmpl` \ alts' -> + -- Simplify the alternatives + ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont - -- Put the case back together - mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr -> + -- Check for empty alternatives + ; if null alts' then missingAlt env case_bndr alts cont + else do + { dflags <- getDOptsSmpl + ; case_expr <- mkCase dflags scrut' case_bndr' alts' - -- Notice that rebuildDone returns the in-scope set from env, not alt_env + -- Notice that rebuild gets the in-scope set from env', not alt_env + -- (which in any case is only build in simplAlts) -- The case binder *not* scope over the whole returned case-expression - rebuild env case_expr nondup_cont + ; rebuild env' case_expr nodup_cont } } \end{code} simplCaseBinder checks whether the scrutinee is a variable, v. If so, @@ -1333,709 +1592,748 @@ 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. -Note 1 -~~~~~~ -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 -in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] -Hence the check for NoCaseOfCase. - -Note 2 -~~~~~~ -There is another situation when we don't want to do it. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - -We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - -But there is no point in doing it for the inner case, because w1 can't -be inlined anyway. Furthermore, doing the case-swapping involves -zapping w2's occurrence info (see paragraphs that follow), and that -forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - -This is plain silly in the common case where w2 is dead. - -Even so, I can't see a good way to implement this idea. I tried -not doing the binder-swap if the scrutinee was already evaluated -but that failed big-time: +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyer; see +OccurAnal Note [Binder swap]. - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - -Notice that because MkT is strict, x is marked "evaluated". But to -eliminate the last case, we must either make sure that x (as well as -x1) has unfolding MkT y1. THe straightforward thing to do is to do -the binder-swap. So this whole note is a no-op. - -Note 3 -~~~~~~ -If we replace the scrutinee, v, by tbe case binder, then we have to nuke -any occurrence info (eg IAmDead) in the case binder, because the -case-binder now effectively occurs whenever v does. AND we have to do -the same for the pattern-bound variables! Example: - - (case x of { (a,b) -> a }) (case x of { (p,q) -> q }) - -Here, b and p are dead. But when we move the argment inside the first -case RHS, and eliminate the second case, we get - - case x of { (a,b) -> a b } - -Urk! b is alive! Reason: the scrutinee was a variable, and case elimination -happened. - -Indeed, this can happen anytime the case binder isn't dead: - case of x { (a,b) -> +Note [zapOccInfo] +~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> case x of { (p,q) -> p } } Here (a,b) both look dead, but come alive after the inner case is eliminated. The point is that we bring into the envt a binding - let x = (a,b) + let x = (a,b) after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. -\begin{code} -simplCaseBinder env (Var v) case_bndr - | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) - --- Failed try [see Note 2 above] --- not (isEvaldUnfolding (idUnfolding v)) - - = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') -> - returnSmpl (modifyInScope env v case_bndr', case_bndr') - -- We could extend the substitution instead, but it would be - -- a hack because then the substitution wouldn't be idempotent - -- any more (v is an OutId). And this does just as well. - where - zap b = b `setIdOccInfo` NoOccInfo - -simplCaseBinder env other_scrut case_bndr - = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') -> - returnSmpl (env, case_bndr') -\end{code} - - -simplAlts does two things: - -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. +In practice, the scrutinee is almost always a variable, so we pretty +much always zap the OccInfo of the binders. It doesn't matter much though. -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. -Here "cannot match" includes knowledge from GADTs +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (v `cast` co) of x { I# y -> + ... (case (v `cast` co) of {...}) ... +We'd like to eliminate the inner case. We can get this neatly by +arranging that inside the outer case we add the unfolding + v |-> x `cast` (sym co) +to v. Then we should inline v at the inner case, cancel the casts, and away we go -It's a good idea do do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + + ... case e of x { DEFAULT -> rhs } ... + +where x::F Int. Then we'd like to rewrite (F Int) to Int, getting + + case e `cast` co of x'::Int + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. + +Notice that Note [Case of cast] may then apply to the result. + +Nota Bene: We only do the [Improving seq] transformation if the +case binder 'x' is actually used in the rhs; that is, if the case +is *not* a *pure* seq. + a) There is no point in adding the cast to a pure seq. + b) There is a good reason not to: doing so would interfere + with seq rules (Note [Built-in RULES for seq] in MkId). + In particular, this [Improving seq] thing *adds* a cast + while [Built-in RULES for seq] *removes* one, so they + just flip-flop. + +You might worry about + case v of x { __DEFAULT -> + ... case (v `cast` co) of y { I# -> ... }} +This is a pure seq (since x is unused), so [Improving seq] won't happen. +But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get + case v of x { __DEFAULT -> + ... case (x `cast` co) of y { I# -> ... }} +Now the outer case is not a pure seq, so [Improving seq] will happen, +and then the inner case will disappear. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: +\begin{code} +simplAlts :: SimplEnv + -> OutExpr + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation +-- Like simplExpr, this just returns the simplified alternatives; +-- it does not return an environment -data Colour = Red | Green | Blue +simplAlts env scrut case_bndr alts cont' + = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $ + do { let env0 = zapFloats env -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x + ; (env1, case_bndr1) <- simplBinder env0 case_bndr -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] + ; fam_envs <- getFamEnvs + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut + case_bndr case_bndr1 alts -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts + ; return (scrut', case_bndr', alts') } -\begin{code} -simplAlts :: SimplEnv - -> OutExpr - -> OutId -- Case binder - -> [InAlt] -> SimplCont - -> SimplM [OutAlt] -- Includes the continuation - -simplAlts env scrut case_bndr' alts cont' - = do { mb_alts <- mapSmpl (simplAlt env imposs_cons case_bndr' cont') alts_wo_default - ; default_alts <- simplDefault env case_bndr' imposs_deflt_cons cont' maybe_deflt - ; return (mergeAlts default_alts [alt' | Just (_, alt') <- mb_alts]) } - -- We need the mergeAlts in case the new default_alt - -- has turned into a constructor alternative. - where - (alts_wo_default, maybe_deflt) = findDefault alts - imposs_cons = case scrut of - Var v -> otherCons (idUnfolding v) - other -> [] - - -- "imposs_deflt_cons" are handled either by the context, - -- OR by a branch in this case expression. (Don't include DEFAULT!!) - imposs_deflt_cons = nub (imposs_cons ++ [con | (con,_,_) <- alts_wo_default]) - -simplDefault :: SimplEnv - -> OutId -- Case binder; need just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example - -> [AltCon] -- These cons can't happen when matching the default - -> SimplCont - -> Maybe InExpr - -> SimplM [OutAlt] -- One branch or none; we use a list because it's what - -- mergeAlts expects - - -simplDefault env case_bndr' imposs_cons cont Nothing - = return [] -- No default branch -simplDefault env case_bndr' imposs_cons cont (Just rhs) - | -- This branch handles the case where we are - -- scrutinisng an algebraic data type - Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr'), - isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples. - not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! - Just all_cons <- tyConDataCons_maybe tycon, - not (null all_cons), -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, then the case expression will have at most a default - -- alternative. We don't want to eliminate that alternative, because the - -- invariant is that there's always one alternative. It's more convenient - -- to leave - -- case x of { DEFAULT -> e } - -- as it is, rather than transform it to - -- error "case cant match" - -- which would be quite legitmate. But it's a really obscure corner, and - -- not worth wasting code on. - - let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type - poss_data_cons = filterOut (`elem` imposs_data_cons) all_cons - gadt_imposs | all isTyVarTy inst_tys = [] - | otherwise = filter (cant_match inst_tys) poss_data_cons - final_poss = filterOut (`elem` gadt_imposs) poss_data_cons - - = case final_poss of - [] -> returnSmpl [] -- Eliminate the default alternative - -- altogether if it can't match - [con] -> -- It matches exactly one constructor, so fill it in - do { con_alt <- mkDataConAlt case_bndr' con inst_tys rhs - ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt - -- The simplAlt must succeed with Just because we have - -- already filtered out construtors that can't match - ; return [alt'] } +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note! + , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } - two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons) +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) - | otherwise - = simplify_default imposs_cons - where - cant_match tys data_con = not (dataConCanMatch data_con tys) - - simplify_default imposs_cons - = do { let env' = mk_rhs_env env case_bndr' (mkOtherCon imposs_cons) - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont - ; return [(DEFAULT, [], rhs')] } - -mkDataConAlt :: Id -> DataCon -> [OutType] -> InExpr -> SimplM InAlt --- Make a data-constructor alternative to replace the DEFAULT case --- NB: there's something a bit bogus here, because we put OutTypes into an InAlt -mkDataConAlt case_bndr con tys rhs - = do { tick (FillInCaseDefault case_bndr) - ; args <- mk_args con tys - ; return (DataAlt con, args, rhs) } - where - mk_args con inst_tys - = do { (tv_bndrs, inst_tys') <- mk_tv_bndrs con inst_tys - ; let arg_tys = dataConInstArgTys con inst_tys' - ; arg_ids <- mapM (newId FSLIT("a")) arg_tys - ; returnSmpl (tv_bndrs ++ arg_ids) } - - mk_tv_bndrs con inst_tys - | isVanillaDataCon con - = return ([], inst_tys) - | otherwise - = do { tv_uniqs <- getUniquesSmpl - ; let new_tvs = zipWith mk tv_uniqs (dataConTyVars con) - mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv) - ; return (new_tvs, mkTyVarTys new_tvs) } +------------------------------------ simplAlt :: SimplEnv - -> [AltCon] -- These constructors can't be present when - -- matching this alternative - -> OutId -- The case binder - -> SimplCont - -> InAlt - -> SimplM (Maybe (TvSubstEnv, OutAlt)) - --- Simplify an alternative, returning the type refinement for the --- alternative, if the alternative does any refinement at all --- Nothing => the alternative is inaccessible - -simplAlt env imposs_cons case_bndr' cont' (con, bndrs, rhs) - | con `elem` imposs_cons -- This case can't match - = return Nothing - -simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs) - -- TURGID DUPLICATION, needed only for the simplAlt call - -- in mkDupableAlt. Clean this up when moving to FC + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) = ASSERT( null bndrs ) - simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs'))) - where - env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons) - -- Record the constructors that the case-binder *can't* be. + do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (DEFAULT, [], rhs') } -simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) +simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs) = ASSERT( null bndrs ) - simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs'))) - where - env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit)) - -simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) - | isVanillaDataCon con - = -- Deal with the pattern-bound variables - -- Mark the ones that are in ! positions in the data constructor - -- as certainly-evaluated. - -- NB: it happens that simplBinders does *not* erase the OtherCon - -- form of unfolding, so it's ok to add this info before - -- doing simplBinders - simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') -> - - -- Bind the case-binder to (con args) - let unf = mkUnfolding False (mkConApp con con_args) - inst_tys' = tyConAppArgs (idType case_bndr') - con_args = map Type inst_tys' ++ map varToCoreExpr vs' - env' = mk_rhs_env env case_bndr' unf - in - simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs'))) - - | otherwise -- GADT case - = let - (tvs,ids) = span isTyVar vs - in - simplBinders env tvs `thenSmpl` \ (env1, tvs') -> - case coreRefineTys con tvs' (idType case_bndr') of { - Nothing -- Inaccessible - | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case - -- so we can see it - -> let rhs' = mkApps (Var eRROR_ID) - [Type (substTy env (exprType rhs)), - Lit (mkStringLit "Impossible alternative (GADT)")] - in - simplBinders env1 ids `thenSmpl` \ (env2, ids') -> - returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs'))) - - | otherwise -- Filter out the inaccessible branch - -> return Nothing ; - - Just refine@(tv_subst_env, _) -> -- The normal case - - let - env2 = refineSimplEnv env1 refine - -- Simplify the Ids in the refined environment, so their types - -- reflect the refinement. Usually this doesn't matter, but it helps - -- in mkDupableAlt, when we want to float a lambda that uses these binders - -- Furthermore, it means the binders contain maximal type information - in - simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') -> - let unf = mkUnfolding False con_app - con_app = mkConApp con con_args - con_args = map varToCoreExpr vs' -- NB: no inst_tys' - env_w_unf = mk_rhs_env env3 case_bndr' unf - vs' = tvs' ++ ids' - in - simplExprC env_w_unf rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) } - + do { let env' = addBinderUnfolding env case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (LitAlt lit, [], rhs') } + +simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) + = do { -- Deal with the pattern-bound variables + -- Mark the ones that are in ! positions in the + -- data constructor as certainly-evaluated. + -- NB: simplLamBinders preserves this eval info + let vs_with_evals = add_evals (dataConRepStrictness con) + ; (env', vs') <- simplLamBndrs env vs_with_evals + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_args = map Type inst_tys' ++ varsToCoreExprs vs' + env'' = addBinderUnfolding env' case_bndr' + (mkConApp con con_args) + + ; rhs' <- simplExprC env'' rhs cont' + ; return (DataAlt con, vs', rhs') } where - -- add_evals records the evaluated-ness of the bound variables of - -- a case pattern. This is *important*. Consider - -- data T = T !Int !Int - -- - -- case x of { T a b -> T (a+1) b } - -- - -- We really must record that b is already evaluated so that we don't - -- go and re-evaluate it when constructing the result. - add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc) - - cat_evals dc vs strs - = go vs strs - where - go [] [] = [] - go (v:vs) strs | isTyVar v = v : go vs strs - go (v:vs) (str:strs) - | isMarkedStrict str = evald_v : go vs strs - | otherwise = zapped_v : go vs strs - where - zapped_v = zap_occ_info v - evald_v = zapped_v `setIdUnfolding` evaldUnfolding - go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) - - -- If the case binder is alive, then we add the unfolding - -- case_bndr = C vs - -- to the envt; so vs are now very much alive - zap_occ_info | isDeadBinder case_bndr' = \id -> id - | otherwise = \id -> id `setIdOccInfo` NoOccInfo - -mk_rhs_env env case_bndr' case_bndr_unf - = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf) + -- add_evals records the evaluated-ness of the bound variables of + -- a case pattern. This is *important*. Consider + -- data T = T !Int !Int + -- + -- case x of { T a b -> T (a+1) b } + -- + -- We really must record that b is already evaluated so that we don't + -- go and re-evaluate it when constructing the result. + -- See Note [Data-con worker strictness] in MkId.lhs + add_evals the_strs + = go vs the_strs + where + go [] [] = [] + go (v:vs') strs | isTyCoVar v = v : go vs' strs + go (v:vs') (str:strs) + | isMarkedStrict str = evald_v : go vs' strs + | otherwise = zapped_v : go vs' strs + where + zapped_v = zap_occ_info v + evald_v = zapped_v `setIdUnfolding` evaldUnfolding + go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) + + -- See Note [zapOccInfo] + -- zap_occ_info: if the case binder is alive, then we add the unfolding + -- case_bndr = C vs + -- to the envt; so vs are now very much alive + -- Note [Aug06] I can't see why this actually matters, but it's neater + -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... } + -- ==> case e of t { (a,b) -> ...(a)... } + -- Look, Ma, a is alive now. + zap_occ_info = zapCasePatIdOcc case_bndr' + +addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv +addBinderUnfolding env bndr rhs + = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) + +addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv +addBinderOtherCon env bndr cons + = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons) + +zapCasePatIdOcc :: Id -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapCasePatIdOcc case_bndr + | isDeadBinder case_bndr = \ pat_id -> pat_id + | otherwise = \ pat_id -> zapIdOccInfo pat_id \end{code} %************************************************************************ -%* * +%* * \subsection{Known constructor} -%* * +%* * %************************************************************************ We are a bit careful with occurrence info. Here's an example - (\x* -> case x of (a*, b) -> f a) (h v, e) + (\x* -> case x of (a*, b) -> f a) (h v, e) where the * means "occurs once". This effectively becomes - case (h v, e) of (a*, b) -> f a) + case (h v, e) of (a*, b) -> f a) and then - let a* = h v; b = e in f a + let a* = h v; b = e in f a and then - f (h v) + f (h v) All this should happen in one sweep. \begin{code} -knownCon :: SimplEnv -> AltCon -> [OutExpr] - -> InId -> [InAlt] -> SimplCont - -> SimplM FloatsWithExpr - -knownCon env con args bndr alts cont - = tick (KnownBranch bndr) `thenSmpl_` - case findAlt con alts of - (DEFAULT, bs, rhs) -> ASSERT( null bs ) - simplNonRecX env bndr scrut $ \ env -> - -- This might give rise to a binding with non-atomic args - -- like x = Node (f x) (g x) - -- but no harm will be done - simplExprF env rhs cont - where - scrut = case con of - LitAlt lit -> Lit lit - DataAlt dc -> mkConApp dc args - - (LitAlt lit, bs, rhs) -> ASSERT( null bs ) - simplNonRecX env bndr (Lit lit) $ \ env -> - simplExprF env rhs cont - - (DataAlt dc, bs, rhs) - -> ASSERT( n_drop_tys + length bs == length args ) - bind_args env bs (drop n_drop_tys args) $ \ env -> - let - con_app = mkConApp dc (take n_drop_tys args ++ con_args) - con_args = [substExpr env (varToCoreExpr b) | b <- bs] - -- args are aready OutExprs, but bs are InIds - in - simplNonRecX env bndr con_app $ \ env -> - simplExprF env rhs cont - where - n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc) - | otherwise = 0 - -- Vanilla data constructors lack type arguments in the pattern - --- Ugh! -bind_args env [] _ thing_inside = thing_inside env - -bind_args env (b:bs) (Type ty : args) thing_inside - = ASSERT( isTyVar b ) - bind_args (extendTvSubst env b ty) bs args thing_inside - -bind_args env (b:bs) (arg : args) thing_inside - = ASSERT( isId b ) - simplNonRecX env b arg $ \ env -> - bind_args env bs args thing_inside +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont + = do { env' <- bind_args env bs dc_args + ; env'' <- bind_case_bndr env' + ; simplExprF env'' rhs cont } + where + zap_occ = zapCasePatIdOcc bndr -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return env' + + bind_args env' (b:bs') (Type ty : args) + = ASSERT( isTyCoVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (arg : args) + = ASSERT( isId b ) + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [zapOccInfo] + ; env'' <- simplNonRecX env' b' arg + ; bind_args env'' bs' args } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return env + | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are aready OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifer might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr alts cont + = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr ) + return (env, mkImpossibleExpr res_ty) + where + res_ty = contResultType env (substTy env (coreAltsType alts)) cont \end{code} %************************************************************************ -%* * +%* * \subsection{Duplicating continuations} -%* * +%* * %************************************************************************ \begin{code} prepareCaseCont :: SimplEnv - -> [InAlt] -> SimplCont - -> SimplM (FloatsWith (SimplCont,SimplCont)) - -- Return a duplicatable continuation, a non-duplicable part - -- plus some extra bindings (that scope over the entire - -- continunation) - - -- No need to make it duplicatable if there's only one alternative -prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) -prepareCaseCont env alts cont = mkDupableCont env cont + -> [InAlt] -> SimplCont + -> SimplM (SimplEnv, SimplCont,SimplCont) + -- Return a duplicatable continuation, a non-duplicable part + -- plus some extra bindings (that scope over the entire + -- continunation) + + -- No need to make it duplicatable if there's only one alternative +prepareCaseCont env [_] cont = return (env, cont, mkBoringStop) +prepareCaseCont env _ cont = mkDupableCont env cont \end{code} \begin{code} -mkDupableCont :: SimplEnv -> SimplCont - -> SimplM (FloatsWith (SimplCont, SimplCont)) +mkDupableCont :: SimplEnv -> SimplCont + -> SimplM (SimplEnv, SimplCont, SimplCont) mkDupableCont env cont | contIsDupable cont - = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) + = return (env, cont, mkBoringStop) + +mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableCont env (CoerceIt ty cont) - = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> - returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont)) - -mkDupableCont env (InlinePlease cont) - = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> - returnSmpl (floats, (InlinePlease dup_cont, nondup_cont)) - -mkDupableCont env cont@(ArgOf _ arg_ty _ _) - = returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont)) - -- Do *not* duplicate an ArgOf continuation - -- Because ArgOf continuations are opaque, we gain nothing by - -- propagating them into the expressions, and we do lose a lot. - -- Here's an example: - -- && (case x of { T -> F; F -> T }) E - -- Now, && is strict so we end up simplifying the case with - -- an ArgOf continuation. If we let-bind it, we get - -- - -- let $j = \v -> && v E - -- in simplExpr (case x of { T -> F; F -> T }) - -- (ArgOf (\r -> $j r) - -- And after simplifying more we get - -- - -- let $j = \v -> && v E - -- in case of { T -> $j F; F -> $j T } - -- Which is a Very Bad Thing - -- - -- The desire not to duplicate is the entire reason that - -- mkDupableCont returns a pair of continuations. - -- - -- The original plan had: - -- e.g. (...strict-fn...) [...hole...] - -- ==> - -- let $j = \a -> ...strict-fn... - -- in $j [...hole...] + = do { (env', dup, nodup) <- mkDupableCont env cont + ; return (env', CoerceIt ty dup, nodup) } + +mkDupableCont env cont@(StrictBind {}) + = return (env, mkBoringStop, cont) + -- See Note [Duplicating StrictBind] + +mkDupableCont env (StrictArg info cci cont) + -- See Note [Duplicating StrictArg] + = do { (env', dup, nodup) <- mkDupableCont env cont + ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info) + ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - do { (floats, (dup_cont, nondup_cont)) <- mkDupableCont env cont - ; addFloats env floats $ \ env -> do - { arg1 <- simplExpr (setInScope se env) arg - ; (floats2, arg2) <- mkDupableArg env arg1 - ; return (floats2, (ApplyTo OkToDup arg2 (zapSubstEnv se) dup_cont, nondup_cont)) }} + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont + ; arg' <- simplExpr (se `setInScope` env') arg + ; (env'', arg'') <- makeTrivial NotTopLevel env' arg' + ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont + ; return (env'', app_cont, nodup_cont) } + +mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _) +-- See Note [Single-alternative case] +-- | not (exprIsDupable rhs && contIsDupable case_cont) +-- | not (isDeadBinder case_bndr) + | all isDeadBinder bs -- InIds + && not (isUnLiftedType (idType case_bndr)) + -- Note [Single-alternative-unlifted] + = return (env, mkBoringStop, cont) mkDupableCont env (Select _ case_bndr alts se cont) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - do { tick (CaseOfCase case_bndr) - ; let alt_env = setInScope se env - ; (floats1, (dup_cont, nondup_cont)) <- mkDupableCont alt_env cont - -- NB: call mkDupableCont here, *not* prepareCaseCont - -- We must make a duplicable continuation, whereas prepareCaseCont - -- doesn't when there is a single case branch - ; addFloats alt_env floats1 $ \ alt_env -> do - - { (alt_env, case_bndr') <- simplBinder alt_env case_bndr - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# a,b #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# a,b #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - - ; (floats2, alts') <- mkDupableAlts alt_env case_bndr' alts dup_cont - ; return (floats2, (Select OkToDup case_bndr' alts' (zapSubstEnv se) - (mkBoringStop (contResultType dup_cont)), - nondup_cont)) - }} - -mkDupableArg :: SimplEnv -> OutExpr -> SimplM (FloatsWith OutExpr) --- Let-bind the thing if necessary -mkDupableArg env arg - | exprIsDupable arg - = return (emptyFloats env, arg) - | otherwise - = do { arg_id <- newId FSLIT("a") (exprType arg) - ; tick (CaseOfCase arg_id) - -- Want to tick here so that we go round again, - -- and maybe copy or inline the code. - -- Not strictly CaseOfCase, but never mind - ; return (unitFloat env arg_id arg, Var arg_id) } - -- What if the arg should be case-bound? - -- This has been this way for a long time, so I'll leave it, - -- but I can't convince myself that it's right. - -mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont - -> SimplM (FloatsWith [InAlt]) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + do { tick (CaseOfCase case_bndr) + ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont + -- NB: call mkDupableCont here, *not* prepareCaseCont + -- We must make a duplicable continuation, whereas prepareCaseCont + -- doesn't when there is a single case branch + + ; let alt_env = se `setInScope` env' + ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr + ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts' + ; return (env'', -- Note [Duplicated env] + Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop, + nodup_cont) } + + +mkDupableAlts :: SimplEnv -> OutId -> [InAlt] + -> SimplM (SimplEnv, [InAlt]) -- Absorbs the continuation into the new alternatives -mkDupableAlts env case_bndr' alts dupable_cont - = go env alts +mkDupableAlts env case_bndr' the_alts + = go env the_alts where - go env [] = returnSmpl (emptyFloats env, []) - go env (alt:alts) - = do { (floats1, mb_alt') <- mkDupableAlt env case_bndr' dupable_cont alt - ; addFloats env floats1 $ \ env -> do - { (floats2, alts') <- go env alts - ; returnSmpl (floats2, case mb_alt' of - Just alt' -> alt' : alts' - Nothing -> alts' - )}} - -mkDupableAlt env case_bndr' cont alt - = simplAlt env [] case_bndr' cont alt `thenSmpl` \ mb_stuff -> - case mb_stuff of { - Nothing -> returnSmpl (emptyFloats env, Nothing) ; - - Just (reft, (con, bndrs', rhs')) -> - -- Safe to say that there are no handled-cons for the DEFAULT case - - if exprIsDupable rhs' then - returnSmpl (emptyFloats env, Just (con, bndrs', rhs')) - -- 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. - -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra - -- iterations because the version with the let bindings looked big, and so wasn't - -- inlined, but after the join points had been inlined it looked smaller, and so - -- was inlined. - -- - -- NB: we have to check the size of rhs', not rhs. - -- Duplicating a small InAlt might invalidate occurrence information - -- However, if it *is* dupable, we return the *un* simplified alternative, - -- because otherwise we'd need to pair it up with an empty subst-env.... - -- but we only have one env shared between all the alts. - -- (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. - - else - let - rhs_ty' = exprType rhs' - used_bndrs' = filter abstract_over (case_bndr' : bndrs') - abstract_over bndr - | isTyVar bndr = not (bndr `elemVarEnv` reft) - -- Don't abstract over tyvar binders which are refined away - -- See Note [Refinement] below - | otherwise = not (isDeadBinder bndr) - -- The deadness info on the new Ids is preserved by simplBinders - in - -- If we try to lift a primitive-typed something out - -- for let-binding-purposes, we will *caseify* it (!), - -- with potentially-disastrous strictness results. So - -- instead we turn it into a function: \v -> e - -- where v::State# RealWorld#. The value passed to this function - -- is realworld#, which generates (almost) no code. - - -- There's a slight infelicity here: we pass the overall - -- case_bndr to all the join points if it's used in *any* RHS, - -- because we don't know its usage in each RHS separately - - -- We used to say "&& isUnLiftedType rhs_ty'" here, but now - -- we make the join point into a function whenever used_bndrs' - -- is empty. This makes the join-point more CPR friendly. - -- Consider: let j = if .. then I# 3 else I# 4 - -- in case .. of { A -> j; B -> j; C -> ... } - -- - -- 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 - - ( if not (any isId used_bndrs') - then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> - returnSmpl ([rw_id], [Var realWorldPrimId]) - else - returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') - ) `thenSmpl` \ (final_bndrs', final_args) -> - - -- See comment about "$j" name above - newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> - -- Notice the funky mkPiTypes. 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 - really_final_bndrs = map one_shot final_bndrs' - one_shot v | isId v = setOneShotLambda v - | otherwise = v - join_rhs = mkLams really_final_bndrs rhs' - join_call = mkApps (Var join_bndr) final_args - in - returnSmpl (unitFloat env join_bndr join_rhs, Just (con, bndrs', join_call)) } + go env0 [] = return (env0, []) + go env0 (alt:alts) + = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt + ; (env2, alts') <- go env1 alts + ; return (env2, alt' : alts' ) } + +mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) + -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) +mkDupableAlt env case_bndr (con, bndrs', rhs') + | exprIsDupable rhs' -- Note [Small alternative rhs] + = return (env, (con, bndrs', rhs')) + | otherwise + = do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineRule rhs Nothing + rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) + ++ varsToCoreExprs bndrs') + + LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + + abstract_over bndr + | isTyCoVar bndr = True -- Abstract over all type variables just in case + | otherwise = not (isDeadBinder bndr) + -- The deadness info on the new Ids is preserved by simplBinders + + ; (final_bndrs', final_args) -- Note [Join point abstraction] + <- if (any isId used_bndrs') + then return (used_bndrs', varsToCoreExprs used_bndrs') + else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy + ; return ([rw_id], [Var realWorldPrimId]) } + + ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty') + -- Note [Funky mkPiTypes] + + ; 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 + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + join_rhs = mkLams really_final_bndrs rhs' + join_call = mkApps (Var join_bndr) final_args + + ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs) + ; return (env', (con, bndrs', join_call)) } + -- See Note [Duplicated env] \end{code} -Note [Refinement] -~~~~~~~~~~~~~~~~~ -Consider - data T a where - MkT :: a -> b -> T a - - f = /\a. \(w::a). - case (case ...) of - MkT a' b (p::a') (q::b) -> [p,w] - -The danger is that we'll make a join point - - j a' p = [p,w] - -and that's ill-typed, because (p::a') but (w::a). - -Solution so far: don't abstract over a', because the type refinement -maps [a' -> a] . Ultimately that won't work when real refinement goes on. - -Then we must abstract over any refined free variables. Hmm. Maybe we -could just abstract over *all* free variables, thereby lambda-lifting -the join point? We should try this. +Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutines the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(an InlineRule) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lamba-bound unfoldings] in DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have an zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Small alternative rhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. +The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra +iterations because the version with the let bindings looked big, and so wasn't +inlined, but after the join points had been inlined it looked smaller, and so +was inlined. + +NB: we have to check the size of rhs', not rhs. +Duplicating a small InAlt might invalidate occurrence information +However, if it *is* dupable, we return the *un* simplified alternative, +because otherwise we'd need to pair it up with an empty subst-env.... +but we only have one env shared between all the alts. +(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. + +Note [Funky mkPiTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkPiTypes. 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 + +Note [Join point abstaction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we try to lift a primitive-typed something out +for let-binding-purposes, we will *caseify* it (!), +with potentially-disastrous strictness results. So +instead we turn it into a function: \v -> e +where v::State# RealWorld#. The value passed to this function +is realworld#, which generates (almost) no code. + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + +We used to say "&& isUnLiftedType rhs_ty'" here, but now +we make the join point into a function whenever used_bndrs' +is empty. This makes the join-point more CPR friendly. +Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + +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 + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The original plan had (where E is a big argument) +e.g. f E [..hole..] + ==> let $j = \a -> f E a + in $j [..hole..] + +But this is terrible! Here's an example: + && E (case x of { T -> F; F -> T }) +Now, && is strict so we end up simplifying the case with +an ArgOf continuation. If we let-bind it, we get + let $j = \v -> && E v + in simplExpr (case x of { T -> F; F -> T }) + (ArgOf (\r -> $j r) +And after simplifying more we get + let $j = \v -> && E v + in case x of { T -> $j F; F -> $j T } +Which is a Very Bad Thing + +What we do now is this + f E [..hole..] + ==> let a = E + in f a [..hole..] +Now if the thing in the hole is a case expression (which is when +we'll call mkDupableCont), we'll push the function call into the +branches, which is what we want. Now RULES for f may fire, and +call-pattern specialisation. Here's an example from Trac #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') +If we can push the call for 'go' inside the case, we get +call-pattern specialisation for 'go', which is *crucial* for +this program. + +Here is the (&&) example: + && E (case x of { T -> F; F -> T }) + ==> let a = E in + case x of { T -> && a F; F -> && a T } +Much better! + +Notice that + * Arguments to f *after* the strict one are handled by + the ApplyTo case of mkDupableCont. Eg + f [..hole..] E + + * We can only do the let-binding of E because the function + part of a StrictArg continuation is an explicit syntax + tree. In earlier versions we represented it as a function + (CoreExpr -> CoreEpxr) which we couldn't take apart. + +Do *not* duplicate StrictBind and StritArg continuations. We gain +nothing by propagating them into the expressions, and we do lose a +lot. + +The desire not to duplicate is the entire reason that +mkDupableCont returns a pair of continuations. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike StrictArg, there doesn't seem anything to gain from +duplicating a StrictBind continuation, so we don't. + +The desire not to duplicate is the entire reason that +mkDupableCont returns a pair of continuations. + + +Note [Single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This case is just like the ArgOf case. Here's an example: + data T a = MkT !a + ...(MkT (abs x))... +Then we get + case (case x of I# x' -> + case x' <# 0# of + True -> I# (negate# x') + False -> I# x') of y { + DEFAULT -> MkT y +Because the (case x) has only one alternative, we'll transform to + case x of I# x' -> + case (case x' <# 0# of + True -> I# (negate# x') + False -> I# x') of y { + DEFAULT -> MkT y +But now we do *NOT* want to make a join point etc, giving + case x of I# x' -> + let $j = \y -> MkT y + in case x' <# 0# of + True -> $j (I# (negate# x')) + False -> $j (I# x') +In this case the $j will inline again, but suppose there was a big +strict computation enclosing the orginal call to MkT. Then, it won't +"see" the MkT any more, because it's big and won't get duplicated. +And, what is worse, nothing was gained by the case-of-case transform. + +When should use this case of mkDupableCont? +However, matching on *any* single-alternative case is a *disaster*; + e.g. case (case ....) of (a,b) -> (# a,b #) + We must push the outer case into the inner one! +Other choices: + + * Match [(DEFAULT,_,_)], but in the common case of Int, + the alternative-filling-in code turned the outer case into + case (...) of y { I# _ -> MkT y } + + * Match on single alternative plus (not (isDeadBinder case_bndr)) + Rationale: pushing the case inwards won't eliminate the construction. + But there's a risk of + case (...) of y { (a,b) -> let z=(a,b) in ... } + Now y looks dead, but it'll come alive again. Still, this + seems like the best option at the moment. + + * Match on single alternative plus (all (isDeadBinder bndrs)) + Rationale: this is essentially seq. + + * Match when the rhs is *not* duplicable, and hence would lead to a + join point. This catches the disaster-case above. We can test + the *un-simplified* rhs, which is fine. It might get bigger or + smaller after simplification; if it gets smaller, this case might + fire next time round. NB also that we must test contIsDupable + case_cont *btoo, because case_cont might be big! + + HOWEVER: I found that this version doesn't work well, because + we can get let x = case (...) of { small } in ...case x... + When x is inlined into its full context, we find that it was a bad + idea to have pushed the outer case inside the (...) case. + +Note [Single-alternative-unlifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's another single-alternative where we really want to do case-of-case: + +data Mk1 = Mk1 Int# +data Mk1 = Mk2 Int# + +M1.f = + \r [x_s74 y_s6X] + case + case y_s6X of tpl_s7m { + M1.Mk1 ipv_s70 -> ipv_s70; + M1.Mk2 ipv_s72 -> ipv_s72; + } + of + wild_s7c + { __DEFAULT -> + case + case x_s74 of tpl_s7n { + M1.Mk1 ipv_s77 -> ipv_s77; + M1.Mk2 ipv_s79 -> ipv_s79; + } + of + wild1_s7b + { __DEFAULT -> ==# [wild1_s7b wild_s7c]; + }; + }; + +So the outer case is doing *nothing at all*, other than serving as a +join-point. In this case we really want to do case-of-case and decide +whether to use a real join point or just duplicate the continuation. + +Hence: check whether the case binder's type is unlifted, because then +the outer case is *not* a seq.