X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=f27dcab7cf67edd99f2ce789e0d7933f8fc8f2cd;hp=329d32639851725e67c561658cb3056a716e52e8;hb=fc867aa70e3bc8753287cf1f5e9a5adb05c38dc6;hpb=a2c92cccbdfdf295901e6c367c35bd4b2b0288e0 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 329d326..f27dcab 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -8,66 +8,31 @@ module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), - SimplifierSwitch(..) - ) +import DynFlags import SimplMonad +import Type hiding ( substTy, extendTvSubst ) import SimplEnv -import SimplUtils ( mkCase, mkLam, - SimplCont(..), DupFlag(..), LetRhsFlag(..), - mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs, - contResultType, countArgs, contIsDupable, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArg, isStrictType, - preInlineUnconditionally, postInlineUnconditionally, - interestingArgContext, 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 SimplUtils +import Id +import Var +import IdInfo +import Coercion +import DataCon ( dataConRepStrictness, dataConUnivTyVars ) import CoreSyn +import NewDemand ( isStrictDmd ) 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 CoreUtils 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 ) + RecFlag(..), isNonRuleLoopBreaker ) import Maybes ( orElse ) import Outputable -import Util ( notNull, filterOut ) +import Util \end{code} @@ -153,17 +118,17 @@ simplLazyBind: [binder already simplified, RHS not] - simplify rhs - mkAtomicArgs - float if exposes constructor or PAP - - completeLazyBind + - completeBind completeNonRecX: [binder and rhs both simplified] - if the the thing needs case binding (unlifted and not ok-for-spec) build a Case else - completeLazyBind + completeBind addFloats -completeLazyBind: [given a simplified RHS] +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] @@ -234,163 +199,35 @@ expansion at a let RHS can concentrate solely on the PAP case. 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) + = 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. + ; env <- simplRecBndrs env (bindersOfBinds binds) + ; dflags <- getDOptsSmpl + ; let dump_flag = dopt Opt_D_dump_inlinings dflags || + dopt Opt_D_dump_rule_firings dflags + ; env' <- simpl_binds dump_flag env binds + ; freeTick SimplifierDone + ; return (getFloats env') } 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 - - 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 + -- 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 dump env [] = return env + simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $ + simpl_bind env bind + ; simpl_binds dump env' binds } + + trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) + trace False bind = \x -> x + + simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r + simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs \end{code} @@ -405,21 +242,22 @@ simplRecBind is used for \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 env top_lvl pairs + = do { env' <- go (zapFloats env) pairs + ; return (env `addRecFloats` env') } + -- addFloats adds the floats from env', + -- *and* updates env with the in-scope set from env' where - go env [] _ = returnSmpl (emptyFloats env, env) + go env [] = return 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') + go env ((bndr, rhs) : pairs) + = do { env <- simplRecOrTopPair env top_lvl bndr rhs + ; go env pairs } \end{code} - -simplRecOrTopPair is used for +simplOrTopPair is used for * recursive bindings (whether top level or not) * top-level non-recursive bindings @@ -428,32 +266,30 @@ 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) + -> InId -> InExpr -- Binder and rhs + -> SimplM SimplEnv -- Returns an env that includes the binding -simplRecOrTopPair env top_lvl bndr bndr' rhs +simplRecOrTopPair env top_lvl 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)) + = do { tick (PreInlineUnconditionally bndr) + ; return (extendIdSubst env bndr (mkContEx env rhs)) } | otherwise - = simplLazyBind env top_lvl Recursive bndr bndr' rhs env + = do { let bndr' = lookupRecBndr env bndr + (env', bndr'') = addLetIdInfo env bndr bndr' + ; simplLazyBind env' top_lvl Recursive bndr 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 + and is in scope, and its IdInfo too, except unfolding 2. It assumes that the binder type is lifted. @@ -464,88 +300,187 @@ Nota bene: simplLazyBind :: 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 (FloatsWith SimplEnv) + -> 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 + = do { let rhs_env = rhs_se `setInScope` env + rhs_cont = mkRhsStop (idType bndr1) + -- 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) -> + ; (rhs_env1, rhs1) <- simplExprF rhs_env rhs rhs_cont -- 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 - + -- (The canFloat predicate says True for empty floats.) + ; if (not (canFloat top_lvl is_rec False rhs_env1)) + then completeBind env top_lvl bndr bndr1 + (wrapFloats rhs_env1 rhs1) + else do -- 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. + { (rhs_env2, rhs2) <- prepareRhs rhs_env1 rhs1 + ; (env', rhs3) <- chooseRhsFloats top_lvl is_rec False env rhs_env2 rhs2 + ; completeBind env' top_lvl bndr bndr1 rhs3 } } + +chooseRhsFloats :: TopLevelFlag -> RecFlag -> Bool + -> SimplEnv -- Env for the let + -> SimplEnv -- Env for the RHS, with RHS floats in it + -> OutExpr -- ..and the RHS itself + -> SimplM (SimplEnv, OutExpr) -- New env for let, and RHS + +chooseRhsFloats top_lvl is_rec is_strict env rhs_env rhs + | not (isEmptyFloats rhs_env) -- Something to float + , canFloat top_lvl is_rec is_strict rhs_env -- ...that can float + , (isTopLevel top_lvl || exprIsCheap rhs) -- ...and we want to float + = do { tick LetFloatFromLet -- Float + ; return (addFloats env rhs_env, rhs) } -- Add the floats to the main env + | otherwise -- Don't float + = return (env, wrapFloats rhs_env rhs) -- Wrap the floats around the RHS +\end{code} + + +%************************************************************************ +%* * +\subsection{simplNonRec} +%* * +%************************************************************************ + +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 + = do { (env, bndr') <- simplBinder env bndr + ; completeNonRecX env NotTopLevel NonRecursive + (isStrictId bndr) bndr bndr' new_rhs } + +completeNonRecX :: SimplEnv + -> TopLevelFlag -> RecFlag -> Bool + -> InId -- Old binder + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv + +completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs + ; (env2, rhs2) <- chooseRhsFloats top_lvl is_rec is_strict env env1 rhs1 + ; 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 ... -- - -- 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) + -- 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. - else - completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) + 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 :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Adds new floats to the env iff that allows us to return a good RHS +prepareRhs env (Cast rhs co) -- Note [Float coercions] + = do { (env', rhs') <- makeTrivial env rhs + ; return (env', Cast rhs' co) } + +prepareRhs env rhs + = do { (is_val, env', rhs') <- go 0 env rhs + ; return (env', rhs') } + where + go n_val_args env (Cast rhs co) + = do { (is_val, env', rhs') <- go n_val_args env rhs + ; return (is_val, env', Cast rhs' co) } + go n_val_args env (App fun (Type ty)) + = do { (is_val, env', rhs') <- go n_val_args env fun + ; return (is_val, env', App rhs' (Type ty)) } + go n_val_args env (App fun arg) + = do { (is_val, env', fun') <- go (n_val_args+1) env fun + ; case is_val of + True -> do { (env'', arg') <- makeTrivial env' arg + ; return (True, env'', App fun' arg') } + False -> return (False, env, App fun arg) } + go n_val_args env (Var fun) + = return (is_val, env, Var fun) + where + is_val = n_val_args > 0 -- There is at least one arg + -- ...and the fun a constructor or PAP + && (isDataConWorkId fun || n_val_args < idArity fun) + go n_val_args 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 + + +\begin{code} +makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +makeTrivial env expr + | exprIsTrivial expr + = return (env, expr) + | otherwise -- See Note [Take care] below + = do { var <- newId FSLIT("a") (exprType expr) + ; env <- completeNonRecX env NotTopLevel NonRecursive + False var var expr + ; return (env, substExpr env (Var var)) } \end{code} @@ -555,11 +490,11 @@ demanded_float (Rec _) = False %* * %************************************************************************ -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,42 +503,44 @@ 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 + - 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 +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 | 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 + -- Inline and discard the binding + = do { tick (PostInlineUnconditionally old_bndr) + ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> 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 | otherwise = let - -- Add arity info + -- Arity info new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + -- Unfolding info -- Add the unfolding *only* for non-loop-breakers -- Making loop breakers not have an unfolding at all -- means that we can avoid tests in exprIsConApp, for example. -- This is important: if exprIsConApp says 'yes' for a recursive -- thing, then we can get into an infinite loop + -- 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 @@ -614,7 +551,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- 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 + -- 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... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding @@ -627,14 +564,14 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- 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) - + -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + return (addNonRec env final_id new_rhs) where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - loop_breaker = isLoopBreaker occ_info + loop_breaker = isNonRuleLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info -\end{code} +\end{code} @@ -696,24 +633,52 @@ simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') 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) + = -- 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' env (Var v) cont = simplVar 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 isTyVar 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 +simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) - simplType env ty `thenSmpl` \ ty' -> - rebuild env (Type ty') cont + do { ty' <- simplType env ty + ; rebuild env (Type ty') cont } -simplExprF env (Case scrut bndr case_ty alts) cont +simplExprF' env (Case scrut bndr case_ty alts) cont | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -721,32 +686,29 @@ simplExprF env (Case scrut bndr case_ty alts) 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 + 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 +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 - simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> - addFloats env floats $ \ env -> - simplExprF env body cont - --- 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 simplType env ty - = seqType new_ty `seq` returnSmpl new_ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` returnSmpl new_ty where new_ty = substTy env ty \end{code} @@ -754,74 +716,49 @@ simplType env ty %************************************************************************ %* * -\subsection{Lambdas} +\subsection{The main rebuilder} %* * %************************************************************************ \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 - 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 +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 cont + = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $ + case cont 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 fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info 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{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 +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplCast env body co cont + = do { co' <- simplType env co + ; simplExprF env body (addCoerce co' cont) } + where + 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 - addCoerce s1 k1 (CoerceIt t1 cont) - -- coerce T1 S1 (coerce S1 K1 e) + add_coerce co1 (s1, k2) (CoerceIt co2 cont) + | (l1, t1) <- coercionKind co2 + -- coerce T1 S1 (coerce S1 K1 e) -- ==> -- e, if T1=K1 -- coerce T1 K1 e, otherwise @@ -830,54 +767,137 @@ simplNote env (Coerce to from) body cont -- 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 + , 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 `cast` g) ty ---> (f ty) `cast` (g @ ty) + -- This implements the PushT rule from the paper + | Just (tyvar,_) <- splitForAllTy_maybe s1s2 + , not (isCoVar tyvar) + = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont) + where + ty' = substTy arg_se arg_ty + + -- ToDo: the PushC rule is not implemented at all + + 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 + -- co : s1s2 :=: t1t2 -- (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 + -- 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) + -- + -- Example of use: Trac #995 + = ApplyTo dup new_arg (zapSubstEnv env) (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 arg_se arg + + add_coerce co _ cont = CoerceIt co cont +\end{code} - --- 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 -simplNote env InlineCall e cont - = simplExprF env e (InlinePlease cont) +%************************************************************************ +%* * +\subsection{Lambdas} +%* * +%************************************************************************ + +\begin{code} +simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplLam env [] body cont = simplExprF env body cont + + -- Type-beta reduction +simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont) + = ASSERT( isTyVar bndr ) + do { tick (BetaReduction bndr) + ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg + ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } + + -- Ordinary 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 bndrs' body' + ; rebuild env new_lam cont } + +------------------ +simplNonRecE :: SimplEnv + -> InId -- The binder + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> ([InId], 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 ...) + +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 } + + | isStrictId bndr + = do { simplExprF (rhs_se `setFloats` env) rhs + (StrictBind bndr bndrs body env cont) } + + | otherwise + = do { (env, bndr') <- simplBinder env bndr + ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se + ; simplLam env bndrs body cont } +\end{code} + + +%************************************************************************ +%* * +\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 env (SCC cc) e cont + = do { e' <- simplExpr (setEnclosingCC env currentCCS) e + ; rebuild env (mkSCC cc e') cont } -- 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 + = do { -- Don't inline inside an INLINE expression + e' <- simplExpr (setMode inlineMode env) e + ; rebuild env (mkInlineMe e') cont } | otherwise -- Dissolve the InlineMe note if there's -- an interesting context of any kind to combine with @@ -901,7 +921,7 @@ simplVar 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 occ -> completeCall (zapSubstEnv env) var1 occ cont + DoneId var1 -> completeCall (zapSubstEnv env) var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -915,27 +935,21 @@ simplVar env var cont --------------------------------------------------------- -- 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 (interestingArgContext var call_cont) 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 +completeCall env var cont + = do { dflags <- getDOptsSmpl + ; let (args,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 + + ------------- First try rules ---------------- + -- Do this before trying inlining. Some functions have + -- rules *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 @@ -951,325 +965,135 @@ completeCall env var occ_info cont -- 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 + ; 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 + ; case maybe_rule of { + Just (rule, rule_rhs) -> + tick (RuleFired (ru_name rule)) `thenSmpl_` + (if dopt Opt_D_dump_rule_firings dflags then pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ftext rule_name, + text "Rule:" <+> ftext (ru_name rule), 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 ; + simplExprF env rule_rhs (dropArgs (ruleArity rule) cont) + -- The ruleArity says how many args the rule consumed - Nothing -> -- No rules - - -- Next, look for an inlining - let - arg_infos = [ interestingArg arg | arg <- args, isValArg arg] - interesting_cont = interestingCallContext (notNull args) - (notNull arg_infos) - call_cont - active_inline = activeInline env var occ_info - maybe_inline = callSiteInline dflags active_inline inline_call occ_info + ; Nothing -> do -- No rules + + ------------- Next try inlining ---------------- + { let arg_infos = [interestingArg arg | arg <- args, isValArg arg] + n_val_args = length arg_infos + interesting_cont = interestingCallContext (notNull args) + (notNull arg_infos) + call_cont + active_inline = activeInline env var + maybe_inline = callSiteInline dflags active_inline 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 - 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. - -makeThatCall env var fun args cont - = simplExprF env fun (pushContArgs env args cont) -\end{code} - - -%************************************************************************ -%* * -\subsection{Arguments} -%* * -%************************************************************************ - -\begin{code} ---------------------------------------------------------- --- Simplifying the arguments of a call - -simplifyArgs :: SimplEnv - -> OutType -- Type of the function - -> Bool -- True if the fn has RULES - -> [(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 has_rules 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 has_rules arg cont_ty $ \ env arg' -> - go env (applyTypeToArg fn_ty arg') args $ \ env args' -> - thing_inside env (arg':args') - -simplifyArg env fn_ty has_rules (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 has_rules (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 - (mkLazyArgStop arg_ty has_rules) `thenSmpl` \ arg1 -> - thing_inside env arg1 - 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 -\end{code} - - -%************************************************************************ -%* * -\subsection{mkAtomicArgs} -%* * -%************************************************************************ - -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 - -Strict - OK-unlifted - -N N Top-level or recursive Only bind args of lifted type - -N Y Non-top-level and non-recursive, Bind args of lifted type, or - but lazy unlifted-and-ok-for-speculation - -Y Y Non-top-level, non-recursive, Bind all args - and strict (demanded) - - -For example, given - - x = MkC (y div# z) - -there is no point in transforming to - - x = case (y div# z) of r -> MkC r - -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. - -\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 - -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 - - | otherwise = bale_out -- Give up + ; case maybe_inline of { + Just unfolding -- There is an inlining! + -> do { tick (UnfoldingDone var) + ; (if dopt Opt_D_dump_inlinings dflags then + pprTrace "Inlining done" (vcat [ + text "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr call_cont]) + else + id) + simplExprF env unfolding cont } + + ; Nothing -> -- No inlining! + + ------------- No inlining! ---------------- + -- Next, look for rules or specialisations that match + -- + rebuildCall env (Var var) (idType var) + (mkArgInfo var n_val_args call_cont) cont + }}}} +rebuildCall :: SimplEnv + -> OutExpr -> OutType -- Function and its type + -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo + -> SimplCont + -> SimplM (SimplEnv, OutExpr) +rebuildCall env fun fun_ty (has_rules, []) 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 thia if there is a non-trivial + = return (env, mk_coerce fun) -- contination to discard, else we do it + where -- again and again! + cont_ty = contResultType cont + co = mkUnsafeCoercion fun_ty cont_ty + mk_coerce expr | cont_ty `coreEqType` fun_ty = fun + | otherwise = mkCoerce co fun + +rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont) + = do { ty' <- simplType (se `setInScope` env) arg_ty + ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont } + +rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont) + | str || isStrictType arg_ty -- Strict argument + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setFloats` env) arg + (StrictArg fun fun_ty (has_rules, strs) 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 arg_ty has_rules) + ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont } 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)])) - - | otherwise - = addAuxiliaryBind env (NonRec v r) $ \ env -> - addAtomicBindsE env bs thing_inside -\end{code} - - -%************************************************************************ -%* * -\subsection{The main rebuilder} -%* * -%************************************************************************ + (arg_ty, res_ty) = splitFunTy fun_ty -\begin{code} -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr - -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 - -rebuildApp env fun arg cont - = simplExpr env arg `thenSmpl` \ arg' -> - rebuild env (App fun arg') cont - -rebuildDone env expr = returnSmpl (emptyFloats env, expr) +rebuildCall env fun fun_ty info cont + = rebuild env fun cont \end{code} +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{Functions dealing with a case} + Rebuilding a cse expression %* * %************************************************************************ @@ -1284,48 +1108,85 @@ rebuildCase :: SimplEnv -> InId -- Case binder -> [InAlt] -- Alternatives (inceasing order) -> SimplCont - -> SimplM FloatsWithExpr + -> 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 + = knownCon env scrut (DataAlt con) args 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 + = knownCon env scrut (LitAlt lit) [] case_bndr alts cont + + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont + -- See if we can get rid of the case altogether + -- See the extensive notes on case-elimination above + -- 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 (idNewDemandInfo case_bndr) + && not (isTickBoxOp v) + -- ugly hack; covering this case is what + -- exprOkForSpeculation was intended for. + var_demanded_later other = False - | 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 - -- Deal with case binder - simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') -> +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- - -- Deal with the case alternatives - simplAlts alt_env scrut case_bndr' alts dup_cont `thenSmpl` \ alts' -> +rebuildCase 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 - -- Put the case back together - mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr -> + -- Simplify the alternatives + ; (case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont + ; let res_ty' = contResultType dup_cont + ; case_expr <- mkCase scrut case_bndr' res_ty' alts' -- Notice that rebuildDone returns the in-scope set from env, not alt_env -- 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,8 +1194,8 @@ 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 -~~~~~~ +Note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~ There is a time we *don't* want to do that, namely when -fno-case-of-case is on. This happens in the first simplifier pass, and enhances full laziness. Here's the bad case: @@ -1345,9 +1206,10 @@ 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 +Note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another situation when it might make sense to suppress the +case-expression binde-swap. If we have case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } ...other cases .... } @@ -1383,8 +1245,8 @@ 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 -~~~~~~ +Note [zapOccInfo] +~~~~~~~~~~~~~~~~~ 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 @@ -1409,24 +1271,131 @@ The point is that we bring into the envt a binding after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (v `cast` co) of x { I# -> + ... (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 + + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> e[x#/y#] + y# -> e + +(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! + +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: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +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. + +We also make sure that we deal with this very common case: + + case e of + x -> ...x... + +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 + +Lastly, the code in SimplUtils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be elminated by the CaseElim transformation. + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +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: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +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} -simplCaseBinder env (Var v) case_bndr - | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) +simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId) +simplCaseBinder env scrut case_bndr + | switchIsOn (getSwitchChecker env) NoCaseOfCase + -- See Note [no-case-of-case] + = do { (env, case_bndr') <- simplBinder env case_bndr + ; return (env, case_bndr') } +simplCaseBinder env (Var v) case_bndr -- 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') + = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr) + ; return (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 (Cast (Var v) co) case_bndr -- Note [Case of cast] + = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr) + ; let rhs = Cast (Var case_bndr') (mkSymCoercion co) + ; return (addBinderUnfolding env v rhs, case_bndr') } + simplCaseBinder env other_scrut case_bndr - = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') -> - returnSmpl (env, case_bndr') + = do { (env, case_bndr') <- simplBinder env case_bndr + ; return (env, case_bndr') } + +zapOccInfo :: InId -> InId -- See Note [zapOccInfo] +zapOccInfo b = b `setIdOccInfo` NoOccInfo \end{code} @@ -1473,202 +1442,59 @@ of the inner case y, which give us nowhere to go! \begin{code} simplAlts :: SimplEnv -> OutExpr - -> OutId -- Case binder + -> InId -- 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 + -> SimplM (OutId, [OutAlt]) -- Includes the continuation +-- Like simplExpr, this just returns the simplified alternatives; +-- it not return an environment - [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'] } +simplAlts env scrut case_bndr alts cont' + = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ + do { let alt_env = zapFloats env + ; (alt_env, case_bndr') <- simplCaseBinder alt_env scrut case_bndr - two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons) + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts - | 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) } + ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts + ; return (case_bndr', alts') } +------------------------------------ simplAlt :: SimplEnv -> [AltCon] -- These constructors can't be present when - -- matching this alternative + -- matching the DEFAULT 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 + -> SimplM OutAlt -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 +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 imposs_deflt_cons 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') -> + do { let env' = addBinderUnfolding env case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (LitAlt lit, [], rhs') } - -- 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'))) +simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) + = do { -- Deal with the pattern-bound variables + (env, vs') <- simplBinders env (add_evals con vs) - | 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'))) } + -- Mark the ones that are in ! positions in the + -- data constructor as certainly-evaluated. + ; let vs'' = add_evals con vs' + + -- 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 @@ -1678,6 +1504,7 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) -- -- 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 dc vs = cat_evals dc vs (dataConRepStrictness dc) cat_evals dc vs strs @@ -1696,11 +1523,17 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) -- 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 zap_occ_info | isDeadBinder case_bndr' = \id -> id - | otherwise = \id -> id `setIdOccInfo` NoOccInfo + | otherwise = zapOccInfo -mk_rhs_env env case_bndr' case_bndr_unf - = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf) +addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv +addBinderUnfolding env bndr rhs + = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs) + +addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv +addBinderOtherCon env bndr cons + = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons) \end{code} @@ -1724,54 +1557,68 @@ and then All this should happen in one sweep. \begin{code} -knownCon :: SimplEnv -> AltCon -> [OutExpr] +knownCon :: SimplEnv -> OutExpr -> 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 + -> SimplM (SimplEnv, OutExpr) + +knownCon env scrut con args bndr alts cont + = do { tick (KnownBranch bndr) + ; knownAlt env scrut args bndr (findAlt con alts) cont } + +knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont + = ASSERT( null bs ) + do { env <- simplNonRecX env bndr scrut + -- This might give rise to a binding with non-atomic args + -- like x = Node (f x) (g x) + -- but simplNonRecX will atomic-ify it + ; simplExprF env rhs cont } + +knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont + = ASSERT( null bs ) + do { env <- simplNonRecX env bndr scrut + ; simplExprF env rhs cont } + +knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont + = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId + n_drop_tys = length (dataConUnivTyVars dc) + ; env <- bind_args env dead_bndr bs (drop n_drop_tys args) + ; let + -- 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 + bndr_rhs = case scrut of + Var v -> scrut + other -> con_app + 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 + + ; env <- simplNonRecX env bndr bndr_rhs + ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $ + simplExprF env rhs cont } -- Ugh! -bind_args env [] _ thing_inside = thing_inside env +bind_args env dead_bndr [] _ = return env -bind_args env (b:bs) (Type ty : args) thing_inside +bind_args env dead_bndr (b:bs) (Type ty : args) = ASSERT( isTyVar b ) - bind_args (extendTvSubst env b ty) bs args thing_inside + bind_args (extendTvSubst env b ty) dead_bndr bs args -bind_args env (b:bs) (arg : args) thing_inside +bind_args env dead_bndr (b:bs) (arg : args) = ASSERT( isId b ) - simplNonRecX env b arg $ \ env -> - bind_args env bs args thing_inside + do { let b' = if dead_bndr then b else zapOccInfo 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 dead_bndr bs args } + +bind_args _ _ _ _ = panic "bind_args" \end{code} @@ -1784,70 +1631,57 @@ bind_args env (b:bs) (arg : args) thing_inside \begin{code} prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (FloatsWith (SimplCont,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 [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) +prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont)) prepareCaseCont env alts cont = mkDupableCont env cont \end{code} \begin{code} mkDupableCont :: SimplEnv -> SimplCont - -> SimplM (FloatsWith (SimplCont, SimplCont)) + -> SimplM (SimplEnv, SimplCont, SimplCont) mkDupableCont env cont | contIsDupable cont - = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) + = returnSmpl (env, cont, mkBoringStop (contResultType cont)) + +mkDupableCont env (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 bndr _ _ se _) + = return (env, mkBoringStop (substTy se (idType bndr)), cont) + -- See Note [Duplicating strict continuations] + +mkDupableCont env cont@(StrictArg _ fun_ty _ _) + = return (env, mkBoringStop (funArgTy fun_ty), cont) + -- See Note [Duplicating strict continuations] 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)) }} + do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont + ; arg <- simplExpr (se `setInScope` env) arg + ; (env, arg) <- makeTrivial 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)] se case_cont) +-- See Note [Single-alternative case] +-- | not (exprIsDupable rhs && contIsDupable case_cont) +-- | not (isDeadBinder case_bndr) + | all isDeadBinder bs -- InIds + = return (env, mkBoringStop scrut_ty, cont) + where + scrut_ty = substTy se (idType case_bndr) mkDupableCont env (Select _ case_bndr alts se cont) = -- e.g. (case [...hole...] of { pi -> ei }) @@ -1855,187 +1689,242 @@ mkDupableCont env (Select _ case_bndr alts se cont) -- 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 + ; (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 - ; addFloats alt_env floats1 $ \ alt_env -> do - { (alt_env, case_bndr') <- simplBinder alt_env case_bndr + ; 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 { (# a,b #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# a,b #), + -- 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 - ; (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]) + ; (env, alts') <- mkDupableAlts env case_bndr' alts' + ; return (env, -- Note [Duplicated env] + Select OkToDup case_bndr' alts' (zapSubstEnv env) + (mkBoringStop (contResultType dup_cont)), + nodup_cont) } + + +mkDupableAlts :: SimplEnv -> OutId -> [InAlt] + -> SimplM (SimplEnv, [InAlt]) -- Absorbs the continuation into the new alternatives -mkDupableAlts env case_bndr' alts dupable_cont +mkDupableAlts env case_bndr' alts = go env alts where - go env [] = returnSmpl (emptyFloats env, []) + go env [] = return (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' - )}} + = do { (env, alt') <- mkDupableAlt env case_bndr' alt + ; (env, alts') <- go env alts + ; return (env, alt' : 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)) } -\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 +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' + used_bndrs' = filter abstract_over (case_bndr' : bndrs') + abstract_over bndr + | isTyVar 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] - j a' p = [p,w] - -and that's ill-typed, because (p::a') but (w::a). + ; 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 + + ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) } + -- See Note [Duplicated env] +\end{code} -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. +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 alterantive 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 strict continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* duplicate StrictBind and StritArg continuations. 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 x 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...] + +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. -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.