SimplifierSwitch(..)
)
import SimplMonad
+import Type hiding ( substTy, extendTvSubst )
import SimplEnv
-import SimplUtils ( mkCase, mkLam,
- SimplCont(..), DupFlag(..), LetRhsFlag(..),
- mkRhsStop, mkBoringStop, pushContArgs,
- contResultType, countArgs, contIsDupable, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType,
- preInlineUnconditionally, postInlineUnconditionally,
- inlineMode, activeInline, activeRule
- )
-import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
- idUnfolding, setIdUnfolding, isDeadBinder,
- idNewDemandInfo, setIdInfo,
- setIdOccInfo, zapLamIdInfo, setOneShotLambda
- )
-import MkId ( eRROR_ID )
-import Literal ( mkStringLit )
-import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo, zapDemandInfo,
- setUnfoldingInfo,
- occInfo
- )
-import NewDemand ( isStrictDmd )
-import Unify ( coreRefineTys, dataConCanMatch )
-import DataCon ( DataCon, dataConTyCon, dataConRepStrictness, isVanillaDataCon,
- dataConInstArgTys, dataConTyVars )
+import SimplUtils
+import Id
+import IdInfo
+import Coercion
+import TcGadt ( dataConCanMatch )
+import DataCon ( dataConTyCon, dataConRepStrictness )
import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline )
-import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
- exprIsConApp_maybe, mkPiTypes, findAlt,
- exprType, exprIsHNF, findDefault, mergeAlts,
- exprOkForSpeculation, exprArity,
- mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
- )
+import 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
+ RecFlag(..), isNonRuleLoopBreaker )
import List ( nub )
import Maybes ( orElse )
import Outputable
-import Util ( notNull, filterOut )
+import Util
\end{code}
- 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]
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
+ ; 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}
+ 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 }
-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))
+ trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
+ trace False bind = \x -> x
- | 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
+ simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
+ simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
\end{code}
\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
\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.
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
+ (isStrictBndr 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.
+
+ 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)
+
+\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 coersions]
+ = do { (env', rhs') <- makeTrivial env rhs
+ ; return (env', Cast rhs' co) }
+
+prepareRhs env rhs
+ | (Var fun, args) <- collectArgs rhs -- It's an application
+ , let n_args = valArgCount args
+ , n_args > 0 -- ...but not a trivial one
+ , isDataConWorkId fun || n_args < idArity fun -- ...and it's a constructor or PAP
+ = go env (Var fun) args
+ where
+ go env fun [] = return (env, fun)
+ go env fun (arg : args) = do { (env', arg') <- makeTrivial env arg
+ ; go env' (App fun arg') args }
+
+prepareRhs env rhs -- The default case
+ = return (env, rhs)
+\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
- else
- completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
-#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
+\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}
%* *
%************************************************************************
-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
- 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
-- 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
-- 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}
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)
| 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
-
- simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
- addFloats env floats $ \ env ->
- simplExprF env body cont
+simplExprF' env (Let (Rec pairs) body) cont
+ = do { env <- simplRecBndrs env (map fst pairs)
+ -- NB: bndrs' don't have unfoldings or rules
+ -- We add them as we go down
--- A non-recursive let is dealt with by simplNonRecBind
-simplExprF env (Let (NonRec bndr rhs) body) cont
- = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
- simplExprF env body cont
+ ; env <- simplRecBind env NotTopLevel pairs
+ ; simplExprF env body cont }
+simplExprF' env (Let (NonRec bndr rhs) body) cont
+ = simplNonRecE env bndr (rhs, env) ([], body) cont
---------------------------------
simplType :: SimplEnv -> InType -> SimplM OutType
-- Kept monadic just so we can do the seqType
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}
%************************************************************************
%* *
-\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
-
- addCoerce s1 k1 (CoerceIt t1 cont)
- -- coerce T1 S1 (coerce S1 K1 e)
+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
+ | (s1, k1) <- coercionKind co
+ , s1 `coreEqType` k1 = cont
+ addCoerce co1 (CoerceIt co2 cont)
+ | (s1, k1) <- coercionKind co1
+ , (l1, t1) <- coercionKind co2
+ -- coerce T1 S1 (coerce S1 K1 e)
-- ==>
-- e, if T1=K1
-- coerce T1 K1 e, otherwise
-- 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
+
+ addCoerce co (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 (s1s2, t1t2) <- splitCoercionKind_maybe co
+ , isFunTy s1s2
+ -- 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)
+ = 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
+
+ addCoerce 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 }
+
+ | isStrictBndr 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
= 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
---------------------------------------------------------
-- Dealing with a call site
-completeCall env var occ_info cont
- = -- Simplify the arguments
- getDOptsSmpl `thenSmpl` \ dflags ->
- let
- chkr = getSwitchChecker env
- (args, call_cont, inline_call) = getContArgs chkr var cont
- fn_ty = idType var
- in
- simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args ->
-
- -- Next, look for rules or specialisations that match
- --
- -- It's important to simplify the args first, because the rule-matcher
- -- doesn't do substitution as it goes. We don't want to use subst_args
- -- (defined in the 'where') because that throws away useful occurrence info,
- -- and perhaps-very-important specialisations.
- --
- -- Some functions have specialisations *and* are strict; in this case,
- -- we don't want to inline the wrapper of the non-specialised thing; better
+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
-- 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_`
+ ; 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_inlinings 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
- -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
- -> OutType -- Type of the continuation
- -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
- -> SimplM FloatsWithExpr
-
--- [CPS-like because of strict arguments]
-
--- Simplify the arguments to a call.
--- This part of the simplifier may break the no-shadowing invariant
--- Consider
--- f (...(\a -> e)...) (case y of (a,b) -> e')
--- where f is strict in its second arg
--- If we simplify the innermost one first we get (...(\a -> e)...)
--- Simplifying the second arg makes us float the case out, so we end up with
--- case y of (a,b) -> f (...(\a -> e)...) e'
--- So the output does not have the no-shadowing invariant. However, there is
--- no danger of getting name-capture, because when the first arg was simplified
--- we used an in-scope set that at least mentioned all the variables free in its
--- static environment, and that is enough.
---
--- We can't just do innermost first, or we'd end up with a dual problem:
--- case x of (a,b) -> f e (...(\a -> e')...)
---
--- I spent hours trying to recover the no-shadowing invariant, but I just could
--- not think of an elegant way to do it. The simplifier is already knee-deep in
--- continuations. We have to keep the right in-scope set around; AND we have
--- to get the effect that finding (error "foo") in a strict arg position will
--- discard the entire application and replace it with (error "foo"). Getting
--- all this at once is TOO HARD!
-
-simplifyArgs env fn_ty args cont_ty thing_inside
- = go env fn_ty args thing_inside
- where
- go env fn_ty [] thing_inside = thing_inside env []
- go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' ->
- go env (applyTypeToArg fn_ty arg') args $ \ env args' ->
- thing_inside env (arg':args')
-
-simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside
- = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
- thing_inside env (Type new_ty_arg)
-
-simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
- | is_strict
- = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
-
- | otherwise -- Lazy argument
- -- DO NOT float anything outside, hence simplExprC
- -- There is no benefit (unlike in a let-binding), and we'd
- -- have to be very careful about bogus strictness through
- -- floating a demanded let.
- = simplExprC (setInScope arg_se env) val_arg
- (mkBoringStop arg_ty) `thenSmpl` \ arg1 ->
- thing_inside env arg1
- 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}
-%* *
-%************************************************************************
-
-\begin{code}
-rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
+ (arg_ty, res_ty) = splitFunTy fun_ty
-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
%* *
%************************************************************************
-> InId -- Case binder
-> [InAlt] -- Alternatives (inceasing order)
-> SimplCont
- -> SimplM FloatsWithExpr
+ -> SimplM (SimplEnv, OutExpr)
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
| 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# -> <blob>
- -- ===>
- -- let j a# = <blob>
- -- 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') ->
+ = do { -- Prepare the continuation;
+ -- The new subst_env is in place
+ (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
- -- Deal with the case alternatives
- simplAlts alt_env scrut case_bndr' alts dup_cont `thenSmpl` \ alts' ->
-
- -- 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,
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:
[(m,n) | m <- [1..max], n <- [1..max]]
Hence the check for NoCaseOfCase.
+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 2
~~~~~~
There is another situation when we don't want to do it. If we have
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
the case binder is guaranteed dead.
\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}
\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.
+ -> SimplM (OutId, [OutAlt]) -- Includes the continuation
+-- Like simplExpr, this just returns the simplified alternatives;
+-- it not return an environment
+
+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
+
+ ; default_alts <- prepareDefault alt_env case_bndr' imposs_deflt_cons cont' maybe_deflt
+
+ ; let inst_tys = tyConAppArgs (idType case_bndr')
+ trimmed_alts = filter (is_possible inst_tys) alts_wo_default
+ in_alts = mergeAlts default_alts trimmed_alts
+ -- We need the mergeAlts in case the new default_alt
+ -- has turned into a constructor alternative.
+
+ ; alts' <- mapM (simplAlt alt_env imposs_cons case_bndr' cont') in_alts
+ ; return (case_bndr', alts') }
where
(alts_wo_default, maybe_deflt) = findDefault alts
imposs_cons = case scrut of
-- 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
+ is_possible :: [Type] -> CoreAlt -> Bool
+ is_possible tys (con, _, _) | con `elem` imposs_cons = False
+ is_possible tys (DataAlt con, _, _) = dataConCanMatch tys con
+ is_possible tys alt = True
+
+------------------------------------
+prepareDefault :: 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
-
+ -> SimplM [InAlt] -- One branch or none; still unsimplified
+ -- We use a list because it's what mergeAlts expects
-simplDefault env case_bndr' imposs_cons cont Nothing
+prepareDefault env case_bndr' imposs_cons cont Nothing
= return [] -- No default branch
-simplDefault env case_bndr' imposs_cons cont (Just rhs)
+
+prepareDefault 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'),
-- 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
+ is_possible con = not (con `elem` imposs_data_cons)
+ && dataConCanMatch inst_tys con
+ = case filter is_possible all_cons of
+ [] -> return [] -- Eliminate the default alternative
-- altogether if it can't match
[con] -> -- It matches exactly one constructor, so fill it in
- do { con_alt <- mkDataConAlt case_bndr' con inst_tys rhs
- ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
- -- The simplAlt must succeed with Just because we have
- -- already filtered out construtors that can't match
- ; return [alt'] }
-
- two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
+ do { tick (FillInCaseDefault case_bndr')
+ ; us <- getUniquesSmpl
+ ; let (ex_tvs, co_tvs, arg_ids) =
+ dataConRepInstPat us con inst_tys
+ ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)] }
- | otherwise
- = simplify_default imposs_cons
- where
- cant_match tys data_con = not (dataConCanMatch data_con tys)
+ two_or_more -> return [(DEFAULT, [], rhs)]
- 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) }
+ | otherwise
+ = return [(DEFAULT, [], rhs)]
+------------------------------------
simplAlt :: SimplEnv
-> [AltCon] -- These constructors can't be present when
-- matching this alternative
-> OutId -- The case binder
-> SimplCont
-> InAlt
- -> SimplM (Maybe (TvSubstEnv, OutAlt))
+ -> SimplM (OutAlt)
-- Simplify an alternative, returning the type refinement for the
-- alternative, if the alternative does any refinement at all
--- Nothing => the alternative is inaccessible
-
-simplAlt env imposs_cons case_bndr' cont' (con, bndrs, rhs)
- | con `elem` imposs_cons -- This case can't match
- = return Nothing
simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
- -- TURGID DUPLICATION, needed only for the simplAlt call
- -- in mkDupableAlt. Clean this up when moving to FC
= 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' handled_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)
= 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))
+ do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
+ ; rhs' <- simplExprC env' rhs cont'
+ ; return (LitAlt lit, [], rhs') }
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 { -- 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
+ (env, vs') <- simplBinders env (add_evals con vs)
-- Bind the case-binder to (con args)
- let unf = mkUnfolding False (mkConApp con con_args)
- inst_tys' = tyConAppArgs (idType case_bndr')
- con_args = map Type inst_tys' ++ map varToCoreExpr vs'
- env' = mk_rhs_env env case_bndr' unf
- in
- simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
-
- | otherwise -- GADT case
- = let
- (tvs,ids) = span isTyVar vs
- in
- simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
- case coreRefineTys con tvs' (idType case_bndr') of {
- Nothing -- Inaccessible
- | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case
- -- so we can see it
- -> let rhs' = mkApps (Var eRROR_ID)
- [Type (substTy env (exprType rhs)),
- Lit (mkStringLit "Impossible alternative (GADT)")]
- in
- simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
- returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs')))
-
- | otherwise -- Filter out the inaccessible branch
- -> return Nothing ;
-
- Just refine@(tv_subst_env, _) -> -- The normal case
-
- let
- env2 = refineSimplEnv env1 refine
- -- Simplify the Ids in the refined environment, so their types
- -- reflect the refinement. Usually this doesn't matter, but it helps
- -- in mkDupableAlt, when we want to float a lambda that uses these binders
- -- Furthermore, it means the binders contain maximal type information
- in
- simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') ->
- let unf = mkUnfolding False con_app
- con_app = mkConApp con con_args
- con_args = map varToCoreExpr vs' -- NB: no inst_tys'
- env_w_unf = mk_rhs_env env3 case_bndr' unf
- vs' = tvs' ++ ids'
- in
- simplExprC env_w_unf rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) }
+ ; 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
--
-- 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
-- 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}
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
+ n_drop_tys = tyConArity (dataConTyCon 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}
\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
+ = 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 })
-- 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
-- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
-- In the new alts we build, we have the new case binder, so it must retain
-- its deadness.
+ -- NB: we don't use alt_env further; it has the substEnv for
+ -- the alternatives, and we don't want that
+
+ ; (env, alts') <- mkDupableAlts env case_bndr' alts'
+ ; return (env, -- Note [Duplicated env]
+ Select OkToDup case_bndr' alts' (zapSubstEnv env)
+ (mkBoringStop (contResultType dup_cont)),
+ nodup_cont) }
- ; (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])
+
+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.
projects / ghc-hetmet.git / blobdiff