%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
\begin{code}
-#include "HsVersions.h"
-
-module Simplify ( simplTopBinds, simplExpr, simplBind ) where
+module Simplify ( simplTopBinds, simplExpr ) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(SmplLoop) -- paranoia checking
+#include "HsVersions.h"
-import BinderInfo
-import CmdLineOpts ( SimplifierSwitch(..) )
-import ConFold ( completePrim )
-import CostCentre ( isSccCountCostCentre, cmpCostCentre )
+import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
+ SimplifierSwitch(..)
+ )
+import SimplMonad
+import SimplUtils ( mkCase, mkLam, newId,
+ simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
+ SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ mkStop, mkBoringStop,
+ contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg,
+ getContArgs, interestingCallContext, interestingArg, isStrictType
+ )
+import Var ( mustHaveLocalBinding )
+import VarEnv
+import Id ( Id, idType, idInfo, idArity, isDataConId,
+ idUnfolding, setIdUnfolding, isDeadBinder,
+ idNewDemandInfo, setIdInfo,
+ setIdOccInfo,
+ zapLamIdInfo, setOneShotLambda,
+ )
+import IdInfo ( OccInfo(..), isLoopBreaker,
+ setArityInfo,
+ setUnfoldingInfo,
+ occInfo
+ )
+import NewDemand ( isStrictDmd )
+import DataCon ( dataConNumInstArgs, dataConRepStrictness )
import CoreSyn
-import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
- unTagBinders, squashableDictishCcExpr,
- manifestlyWHNF
+import PprCore ( pprParendExpr, pprCoreExpr )
+import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
+import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+ exprType, coreAltsType, exprIsValue,
+ exprOkForSpeculation, exprArity,
+ mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
-import Id ( idType, idWantsToBeINLINEd,
- getIdDemandInfo, addIdDemandInfo,
- GenId{-instance NamedThing-}
+import Rules ( lookupRule )
+import BasicTypes ( isMarkedStrict )
+import CostCentre ( currentCCS )
+import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
+ funResultTy, splitFunTy_maybe, splitFunTy, eqType
)
-import IdInfo ( willBeDemanded, DemandInfo )
-import Literal ( isNoRepLit )
-import Maybes ( maybeToBool )
-import Name ( isLocallyDefined )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty ( ppAbove )
-import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
-import SimplCase ( simplCase, bindLargeRhs )
-import SimplEnv
-import SimplMonad
-import SimplVar ( completeVar )
-import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
- splitFunTy, getFunTy_maybe, eqTy
+import Subst ( mkSubst, substTy, substExpr,
+ isInScope, lookupIdSubst, simplIdInfo
+ )
+import TysPrim ( realWorldStatePrimTy )
+import PrelInfo ( realWorldPrimId )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ RecFlag(..), isNonRec
)
-import TysWiredIn ( realWorldStateTy )
-import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
+import OrdList
+import Maybe ( Maybe )
+import Outputable
\end{code}
-The controlling flags, and what they do
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-passes:
-------
--fsimplify = run the simplifier
--ffloat-inwards = runs the float lets inwards pass
--ffloat = runs the full laziness pass
- (ToDo: rename to -ffull-laziness)
--fupdate-analysis = runs update analyser
--fstrictness = runs strictness analyser
--fsaturate-apps = saturates applications (eta expansion)
-
-options:
--------
--ffloat-past-lambda = OK to do full laziness.
- (ToDo: remove, as the full laziness pass is
- useless without this flag, therefore
- it is unnecessary. Just -ffull-laziness
- should be kept.)
-
--ffloat-lets-ok = OK to float lets out of lets if the enclosing
- let is strict or if the floating will expose
- a WHNF [simplifier].
-
--ffloat-primops-ok = OK to float out of lets cases whose scrutinee
- is a primop that cannot fail [simplifier].
-
--fcode-duplication-ok = allows the previous option to work on cases with
- multiple branches [simplifier].
-
--flet-to-case = does let-to-case transformation [simplifier].
-
--fcase-of-case = does case of case transformation [simplifier].
-
--fpedantic-bottoms = does not allow:
- case x of y -> e ===> e[x/y]
- (which may turn bottom into non-bottom)
-
-
- NOTES ON INLINING
- ~~~~~~~~~~~~~~~~~
-
-Inlining is one of the delicate aspects of the simplifier. By
-``inlining'' we mean replacing an occurrence of a variable ``x'' by
-the RHS of x's definition. Thus
-
- let x = e in ...x... ===> let x = e in ...e...
-
-We have two mechanisms for inlining:
-
-1. Unconditional. The occurrence analyser has pinned an (OneOcc
-FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
-certainly safe to inline this variable, and to drop its binding''.
-(...Umm... if n <= 1; if n > 1, it is still safe, provided you are
-happy to be duplicating code...) When it encounters such a beast, the
-simplifer binds the variable to its RHS (in the id_env) and continues.
-It doesn't even look at the RHS at that stage. It also drops the
-binding altogether.
-
-2. Conditional. In all other situations, the simplifer simplifies
-the RHS anyway, and keeps the new binding. It also binds the new
-(cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
-
-Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
-info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
-the variable has an INLINE pragma on it). The idea is that anything
-in the UnfoldEnv is safe to use, but also has an enclosing binding if
-you decide not to use it.
-
-Head normal forms
-~~~~~~~~~~~~~~~~~
-We *never* put a non-HNF unfolding in the UnfoldEnv except in the
-INLINE-pragma case.
-
-At one time I thought it would be OK to put non-HNF unfoldings in for
-variables which occur only once [if they got inlined at that
-occurrence the RHS of the binding would become dead, so no duplication
-would occur]. But consider:
-@
- let x = <expensive>
- f = \y -> ...y...y...y...
- in f x
-@
-Now, it seems that @x@ appears only once, but even so it is NOT safe
-to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
-duplicate the references to @x@.
-
-Because of this, the "unconditional-inline" mechanism above is the
-only way in which non-HNFs can get inlined.
-
-INLINE pragmas
-~~~~~~~~~~~~~~
-
-When a variable has an INLINE pragma on it --- which includes wrappers
-produced by the strictness analyser --- we treat it rather carefully.
-For a start, we are careful not to substitute into its RHS, because
-that might make it BIG, and the user said "inline exactly this", not
-"inline whatever you get after inlining other stuff inside me". For
-example
+The guts of the simplifier is in this module, but the driver loop for
+the simplifier is in SimplCore.lhs.
+
+
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more. (Actually, it never did!) The reason is
+documented with simplifyArgs.
+
+
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+Many parts of the simplifier return a bunch of "floats" as well as an
+expression. This is wrapped as a datatype SimplUtils.FloatsWith.
+
+All "floats" are let-binds, not case-binds, but some non-rec lets may
+be unlifted (with RHS ok-for-speculation).
+
+
+
+-----------------------------------------
+ ORGANISATION OF FUNCTIONS
+-----------------------------------------
+simplTopBinds
+ - simplify all top-level binders
+ - for NonRec, call simplRecOrTopPair
+ - for Rec, call simplRecBind
+
+
+ ------------------------------
+simplExpr (applied lambda) ==> simplNonRecBind
+simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
+simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
+
+ ------------------------------
+simplRecBind [binders already simplfied]
+ - use simplRecOrTopPair on each pair in turn
+
+simplRecOrTopPair [binder already simplified]
+ Used for: recursive bindings (top level and nested)
+ top-level non-recursive bindings
+ Returns:
+ - check for PreInlineUnconditionally
+ - simplLazyBind
+
+simplNonRecBind
+ Used for: non-top-level non-recursive bindings
+ beta reductions (which amount to the same thing)
+ Because it can deal with strict arts, it takes a
+ "thing-inside" and returns an expression
+
+ - check for PreInlineUnconditionally
+ - simplify binder, including its IdInfo
+ - if strict binding
+ simplStrictArg
+ mkAtomicArgs
+ completeNonRecX
+ else
+ simplLazyBind
+ addFloats
+
+simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
+ Used for: binding case-binder and constr args in a known-constructor case
+ - check for PreInLineUnconditionally
+ - simplify binder
+ - completeNonRecX
+
+ ------------------------------
+simplLazyBind: [binder already simplified, RHS not]
+ Used for: recursive bindings (top level and nested)
+ top-level non-recursive bindings
+ non-top-level, but *lazy* non-recursive bindings
+ [must not be strict or unboxed]
+ Returns floats + an augmented environment, not an expression
+ - substituteIdInfo and add result to in-scope
+ [so that rules are available in rec rhs]
+ - simplify rhs
+ - mkAtomicArgs
+ - float if exposes constructor or PAP
+ - completeLazyBind
+
+
+completeNonRecX: [binder and rhs both simplified]
+ - if the the thing needs case binding (unlifted and not ok-for-spec)
+ build a Case
+ else
+ completeLazyBind
+ addFloats
+
+completeLazyBind: [given a simplified RHS]
+ [used for both rec and non-rec bindings, top level and not]
+ - try PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
+
+
+
+Right hand sides and arguments
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In many ways we want to treat
+ (a) the right hand side of a let(rec), and
+ (b) a function argument
+in the same way. But not always! In particular, we would
+like to leave these arguments exactly as they are, so they
+will match a RULE more easily.
+
+ f (g x, h x)
+ g (+ x)
+
+It's harder to make the rule match if we ANF-ise the constructor,
+or eta-expand the PAP:
+
+ f (let { a = g x; b = h x } in (a,b))
+ g (\y. + x y)
+
+On the other hand if we see the let-defns
+
+ p = (g x, h x)
+ q = + x
+
+then we *do* want to ANF-ise and eta-expand, so that p and q
+can be safely inlined.
+
+Even floating lets out is a bit dubious. For let RHS's we float lets
+out if that exposes a value, so that the value can be inlined more vigorously.
+For example
+
+ r = let x = e in (x,x)
+
+Here, if we float the let out we'll expose a nice constructor. We did experiments
+that showed this to be a generally good thing. But it was a bad thing to float
+lets out unconditionally, because that meant they got allocated more often.
+
+For function arguments, there's less reason to expose a constructor (it won't
+get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
+So for the moment we don't float lets out of function arguments either.
+
+
+Eta expansion
+~~~~~~~~~~~~~~
+For eta expansion, we want to catch things like
- let f = BIG
- in {-# INLINE y #-} y = f 3
- in ...y...y...
+ case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
-Here we don't want to substitute BIG for the (single) occurrence of f,
-because then we'd duplicate BIG when we inline'd y. (Exception:
-things in the UnfoldEnv with UnfoldAlways flags, which originated in
-other INLINE pragmas.)
+If the \x was on the RHS of a let, we'd eta expand to bring the two
+lambdas together. And in general that's a good thing to do. Perhaps
+we should eta expand wherever we find a (value) lambda? Then the eta
+expansion at a let RHS can concentrate solely on the PAP case.
-So, we clean out the UnfoldEnv of all GenForm inlinings before
-going into such an RHS.
-What about imports? They don't really matter much because we only
-inline relatively small things via imports.
+%************************************************************************
+%* *
+\subsection{Bindings}
+%* *
+%************************************************************************
-We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
-INLINE pragma. We also do this for the RHSs of recursive decls,
-before looking at the recursive decls. That way we achieve the effect
-of inlining a wrapper in the body of its worker, in the case of a
-mutually-recursive worker/wrapper split.
+\begin{code}
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
+
+simplTopBinds env binds
+ = -- Put all the top-level binders into scope at the start
+ -- so that if a transformation rule has unexpectedly brought
+ -- anything into scope, then we don't get a complaint about that.
+ -- It's rather as if the top-level binders were imported.
+ simplRecIds env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
+ freeTick SimplifierDone `thenSmpl_`
+ returnSmpl (floatBinds floats)
+ where
+ -- We need to track the zapped top-level binders, because
+ -- they should have their fragile IdInfo zapped (notably occurrence info)
+ -- That's why we run down binds and bndrs' simultaneously.
+ simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
+ simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
+ simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) ->
+ addFloats env floats $ \env ->
+ simpl_binds env binds (drop_bs bind bs)
+
+ drop_bs (NonRec _ _) (_ : bs) = bs
+ drop_bs (Rec prs) bs = drop (length prs) bs
+
+ simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+ simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
+\end{code}
%************************************************************************
%* *
-\subsection[Simplify-simplExpr]{The main function: simplExpr}
+\subsection{simplNonRec}
%* *
%************************************************************************
-At the top level things are a little different.
+simplNonRecBind is used for
+ * non-top-level non-recursive lets in expressions
+ * beta reduction
- * No cloning (not allowed for exported Ids, unnecessary for the others)
+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
- * No floating. Case floating is obviously out. Let floating is
- theoretically OK, but dangerous because of space leaks.
- The long-distance let-floater lifts these lets.
-
-\begin{code}
-simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
+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...)
-simplTopBinds env [] = returnSmpl []
+It needs to turn unlifted bindings into a @case@. They can arise
+from, say: (\x -> e) (4# + 3#)
--- Dead code is now discarded by the occurrence analyser,
+\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
-simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
- | inlineUnconditionally ok_to_dup_code occ_info
- = let
- new_env = extendIdEnvWithInlining env env binder rhs
- in
- simplTopBinds new_env binds
- where
- ok_to_dup_code = switchIsSet env SimplOkToDupCode
+simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
+
+
+ | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
+ = -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
+
+ -- Make the arguments atomic if necessary,
+ -- adding suitable bindings
+ mkAtomicArgs True True rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+ addAtomicBindsE env aux_binds $ \ env ->
+
+ -- Now complete the binding and simplify the body
+ completeNonRecX env bndr bndr' rhs2 thing_inside
+
+ | otherwise -- Normal, lazy case
+ = -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplLazyBind env NotTopLevel NonRecursive
+ bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
+\end{code}
-simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
- = -- No cloning necessary at top level
- -- Process the binding
- simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- let
- new_env = case rhs' of
- Var v -> extendIdEnvWithAtom env binder (VarArg v)
- Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
- other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
- in
- -- Process the other bindings
- simplTopBinds new_env binds `thenSmpl` \ binds' ->
+A specialised variant of simplNonRec used when the RHS is already simplified, notably
+in knownCon. It uses case-binding where necessary.
- -- Glue together and return ...
- -- We leave it to susequent occurrence analysis to throw away
- -- an unused atom binding. This localises the decision about
- -- discarding top-level bindings.
- returnSmpl (NonRec in_id rhs' : binds')
+\begin{code}
+simplNonRecX :: SimplEnv
+ -> InId -- Old binder
+ -> OutExpr -- Simplified RHS
+ -> (SimplEnv -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+simplNonRecX env bndr new_rhs thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr
+ -- 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 (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
-simplTopBinds env (Rec pairs : binds)
- = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
+ | otherwise
+ = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
+ completeNonRecX env bndr bndr' new_rhs thing_inside
- -- Process the other bindings
- simplTopBinds new_env binds `thenSmpl` \ binds' ->
+completeNonRecX env old_bndr new_bndr new_rhs thing_inside
+ | needsCaseBinding (idType new_bndr) new_rhs
+ = thing_inside env `thenSmpl` \ (floats, body) ->
+ returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
- -- Glue together and return
- returnSmpl (bind' : binds')
- where
- triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
- -- No cloning necessary at top level
+ | otherwise
+ = completeLazyBind env NotTopLevel
+ old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
\end{code}
+
%************************************************************************
%* *
-\subsection[Simplify-simplExpr]{The main function: simplExpr}
+\subsection{Lazy bindings}
%* *
%************************************************************************
+simplRecBind is used for
+ * recursive bindings only
\begin{code}
-simplExpr :: SimplEnv
- -> InExpr -> [OutArg]
- -> SmplM OutExpr
+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)
+ where
+ go env [] _ = returnSmpl (emptyFloats env, env)
+
+ go env ((bndr, rhs) : pairs) (bndr' : bndrs')
+ = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats (\env -> go env pairs bndrs')
\end{code}
-The expression returned has the same meaning as the input expression
-applied to the specified arguments.
+simplRecOrTopPair is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
-Variables
-~~~~~~~~~
-Check if there's a macro-expansion, and if so rattle on. Otherwise do
-the more sophisticated stuff.
+It assumes the binder has already been simplified, but not its IdInfo.
\begin{code}
-simplExpr env (Var v) args
- = case (lookupId env v) of
- Nothing -> let
- new_v = simplTyInId env v
- in
- completeVar env new_v args
-
- Just info ->
- case info of
- ItsAnAtom (LitArg lit) -- A boring old literal
- -- Paranoia check for args empty
- -> case args of
- [] -> returnSmpl (Lit lit)
- other -> panic "simplExpr:coVar"
-
- ItsAnAtom (VarArg var) -- More interesting! An id!
- -- No need to substitute the type env here,
- -- because we already have!
- -> completeVar env var args
-
- InlineIt id_env ty_env in_expr -- A macro-expansion
- -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
-\end{code}
+simplRecOrTopPair :: SimplEnv
+ -> TopLevelFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
-Literals
-~~~~~~~~
+simplRecOrTopPair env top_lvl bndr bndr' rhs
+ | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
-\begin{code}
-simplExpr env (Lit l) [] = returnSmpl (Lit l)
-#ifdef DEBUG
-simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
-#endif
+ | otherwise
+ = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
+ -- May not actually be recursive, but it doesn't matter
\end{code}
-Primitive applications are simple.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB: Prim expects an empty argument list! (Because it should be
-saturated and not higher-order. ADR)
+simplLazyBind is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+ * non-top-level *lazy* non-recursive bindings
-\begin{code}
-simplExpr env (Prim op prim_args) args
- = ASSERT (null args)
- let
- prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
- op' = simpl_op op
- in
- completePrim env op' prim_args'
- where
- -- PrimOps just need any types in them renamed.
+[Thus it deals with the lazy cases from simplNonRecBind, and all cases
+from SimplRecOrTopBind]
- simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
- = let
- arg_tys' = map (simplTy env) arg_tys
- result_ty' = simplTy env result_ty
- in
- CCallOp label is_asm may_gc arg_tys' result_ty'
+Nota bene:
+ 1. It assumes that the binder is *already* simplified,
+ and is in scope, but not its IdInfo
- simpl_op other_op = other_op
-\end{code}
+ 2. It assumes that the binder type is lifted.
-Constructor applications
-~~~~~~~~~~~~~~~~~~~~~~~~
-Nothing to try here. We only reuse constructors when they appear as the
-rhs of a let binding (see completeLetBinding).
+ 3. It does not check for pre-inline-unconditionallly;
+ that should have been done already.
\begin{code}
-simplExpr env (Con con con_args) args
- = ASSERT( null args )
- returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
+simplLazyBind :: SimplEnv
+ -> TopLevelFlag -> RecFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -> SimplEnv -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
+
+simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
+ = -- Substitute IdInfo on binder, in the light of earlier
+ -- substitutions in this very letrec, and extend the
+ -- in-scope env, so that the IdInfo for this binder extends
+ -- over the RHS for the binder itself.
+ --
+ -- This is important. Manuel found cases where he really, really
+ -- wanted a RULE for a recursive function to apply in that function's
+ -- own right-hand side.
+ --
+ -- NB: does no harm for non-recursive bindings
+ let
+ bndr_ty' = idType bndr'
+ bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
+ env1 = modifyInScope env bndr'' bndr''
+ rhs_env = setInScope rhs_se env1
+ ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
+ rhs_cont = mkStop bndr_ty' AnRhs
+ in
+ -- Simplify the RHS; note the mkStop, which tells
+ -- the simplifier that this is the RHS of a let.
+ simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
+
+ -- If any of the floats can't be floated, give up now
+ -- (The allLifted predicate says True for empty floats.)
+ if (not ok_float_unlifted && not (allLifted floats)) then
+ completeLazyBind env1 top_lvl bndr bndr''
+ (wrapFloats floats rhs1)
+ else
+
+ -- ANF-ise a constructor or PAP rhs
+ mkAtomicArgs False {- Not strict -}
+ ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+
+ -- If the result is a PAP, float the floats out, else wrap them
+ -- By this time it's already been ANF-ised (if necessary)
+ if isEmptyFloats floats && null aux_binds then -- Shortcut a common case
+ completeLazyBind env1 top_lvl bndr bndr'' rhs2
+
+ -- 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.
+ -- exprIsValue definitely isn't right for that.
+ --
+ -- BUT we can't use "exprIsCheap", 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 exprIsValue for the test, which ensures that the
+ -- thing is non-strict. I think. The WARN below tests for this
+ else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if arg' is a WHNF,
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the assert
+ WARN( any demanded_float (floatBinds floats),
+ ppr (filter demanded_float (floatBinds floats)) )
+
+ tick LetFloatFromLet `thenSmpl_` (
+ addFloats env1 floats $ \ env2 ->
+ addAtomicBinds env2 aux_binds $ \ env3 ->
+ completeLazyBind env3 top_lvl bndr bndr'' rhs2)
+
+ else
+ completeLazyBind env1 top_lvl bndr bndr'' (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
\end{code}
-Applications are easy too:
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Just stuff 'em in the arg stack
+%************************************************************************
+%* *
+\subsection{Completing a lazy binding}
+%* *
+%************************************************************************
-\begin{code}
-simplExpr env (App fun arg) args
- = simplExpr env fun (simplArg env arg : args)
-\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
-Type lambdas
-~~~~~~~~~~~~
+It does the following:
+ - tries discarding a dead binding
+ - tries PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
-We only eta-reduce a type lambda if all type arguments in the body can
-be eta-reduced. This requires us to collect up all tyvar parameters so
-we can pass them all to @mkTyLamTryingEta@.
+It does *not* attempt to do let-to-case. Why? Because it is used for
+ - top-level bindings (when let-to-case is impossible)
+ - many situations where the "rhs" is known to be a WHNF
+ (so let-to-case is inappropriate).
\begin{code}
-simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
- = -- ASSERT(not (isPrimType ty))
- let
- new_env = extendTyEnv env tyvar ty
+completeLazyBind :: SimplEnv
+ -> TopLevelFlag -- Flag stuck into unfolding
+ -> InId -- Old binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM (FloatsWith SimplEnv)
+-- We return a new SimplEnv, because completeLazyBind may choose to do its work
+-- by extending the substitution (e.g. let x = y in ...)
+-- The new binding (if any) is returned as part of the floats.
+-- NB: the returned SimplEnv has the right SubstEnv, but you should
+-- (as usual) use the in-scope-env from the floats
+
+completeLazyBind env top_lvl old_bndr new_bndr new_rhs
+ | postInlineUnconditionally env new_bndr loop_breaker new_rhs
+ = -- Drop the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+
+ | otherwise
+ = let
+ -- Add arity info
+ new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+ info_w_unf | loop_breaker = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
in
- tick TyBetaReduction `thenSmpl_`
- simplExpr new_env body args
+ -- 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)
-simplExpr env tylam@(Lam (TyBinder tyvar) body) []
- = do_tylambdas env [] tylam
- where
- do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
- = -- Clone the type variable
- cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
- let
- new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
- in
- do_tylambdas new_env (tyvar':tyvars') body
+ where
+ loop_breaker = isLoopBreaker occ_info
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+\end{code}
- do_tylambdas env tyvars' body
- = simplExpr env body [] `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) (reverse tyvars') body'
- )
-#ifdef DEBUG
-simplExpr env (Lam (TyBinder _) _) (_ : _)
- = panic "simplExpr:TyLam with non-TyArg"
-#endif
-\end{code}
+%************************************************************************
+%* *
+\subsection[Simplify-simplExpr]{The main function: simplExpr}
+%* *
+%************************************************************************
-Ordinary lambdas
-~~~~~~~~~~~~~~~~
-
-\begin{code}
-simplExpr env (Lam (ValBinder binder) body) args
- | null leftover_binders
- = -- The lambda is saturated (or over-saturated)
- tick BetaReduction `thenSmpl_`
- simplExpr env_for_enough_args body leftover_args
-
- | otherwise
- = -- Too few args to saturate the lambda
- ASSERT( null leftover_args )
+The reason for this OutExprStuff stuff is that we want to float *after*
+simplifying a RHS, not before. If we do so naively we get quadratic
+behaviour as things float out.
- (if not (null args) -- ah, we must've gotten rid of some...
- then tick BetaReduction
- else returnSmpl (panic "BetaReduction")
- ) `thenSmpl_`
+To see why it's important to do it after, consider this (real) example:
- simplLam env_for_too_few_args leftover_binders body
- 0 {- Guaranteed applied to at least 0 args! -}
+ let t = f x
+ in fst t
+==>
+ let t = let a = e1
+ b = e2
+ in (a,b)
+ in fst t
+==>
+ let a = e1
+ b = e2
+ t = (a,b)
+ in
+ a -- Can't inline a this round, cos it appears twice
+==>
+ e1
- where
- (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
-
- env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
-
- env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
-
- -- Since there aren't enough args the binders we are cancelling with
- -- the args supplied are, in effect, ocurring inside a lambda.
- -- So we modify their occurrence info to reflect this fact.
- -- Example: (\ x y z -> e) p q
- -- ==> (\z -> e[p/x, q/y])
- -- but we should behave as if x and y are marked "inside lambda".
- -- The occurrence analyser does not mark them so itself because then we
- -- do badly on the very common case of saturated lambdas applications:
- -- (\ x y z -> e) p q r
- -- ==> e[p/x, q/y, r/z]
- --
- zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
- | ((id, occ_info), arg) <- binder_args_pairs ]
-
- collect_val_args :: InBinder -- Binder
- -> [OutArg] -- Arguments
- -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
- [InBinder], -- Leftover binders (ToDo: a maybe)
- [OutArg]) -- Leftover args
-
- -- collect_val_args strips off the leading ValArgs from
- -- the current arg list, returning them along with the
- -- depleted list
- collect_val_args binder [] = ([], [binder], [])
- collect_val_args binder (arg : args) | isValArg arg
- = ([(binder,arg)], [], args)
+Each of the ==> steps is a round of simplification. We'd save a
+whole round if we float first. This can cascade. Consider
-#ifdef DEBUG
- collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
- -- TyArg should never meet a Lam
-#endif
-\end{code}
+ let f = g d
+ in \x -> ...f...
+==>
+ let f = let d1 = ..d.. in \y -> e
+ in \x -> ...f...
+==>
+ let d1 = ..d..
+ in \x -> ...(\y ->e)...
+Only in this second round can the \y be applied, and it
+might do the same again.
-Let expressions
-~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env (Let bind body) args
+simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
+ where
+ expr_ty' = substTy (getSubst env) (exprType expr)
+ -- The type in the Stop continuation, expr_ty', is usually not used
+ -- It's only needed when discarding continuations after finding
+ -- a function that returns bottom.
+ -- Hence the lazy substitution
+
+
+simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
+ -- Simplify an expression, given a continuation
+simplExprC env expr cont
+ = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
+ returnSmpl (wrapFloats floats expr)
+
+simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
+ -- Simplify an expression, returning floated binds
+
+simplExprF env (Var v) cont = simplVar env v cont
+simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
+simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
+simplExprF env (Note note expr) cont = simplNote env note expr cont
+simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
+
+simplExprF env (Type ty) cont
+ = ASSERT( contIsRhsOrArg cont )
+ simplType env ty `thenSmpl` \ ty' ->
+ rebuild env (Type ty') cont
+
+simplExprF env (Case scrut bndr alts) cont
+ | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+ = -- Simplify the scrutinee with a Select continuation
+ simplExprF env scrut (Select NoDup bndr alts env cont)
-{- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
- and it doesn't seem worth retaining the ability to not float applications
- into let/case
-
- | switchIsSet env SimplNoLetFromApp
- = simplBind env bind (\env -> simplExpr env body [])
- (computeResultType env body []) `thenSmpl` \ let_expr' ->
- returnSmpl (mkGenApp let_expr' args)
+ | 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
+ where
+ case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
- | otherwise -- No float from application
--}
+simplExprF env (Let (Rec pairs) body) cont
+ = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
+ -- NB: bndrs' don't have unfoldings or spec-envs
+ -- We add them as we go down, using simplPrags
- = simplBind env bind (\env -> simplExpr env body args)
- (computeResultType env body args)
-\end{code}
+ simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
+ addFloats env floats $ \ env ->
+ simplExprF env body cont
-Case expressions
-~~~~~~~~~~~~~~~~
+-- 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
-\begin{code}
-simplExpr env expr@(Case scrut alts) args
- = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
- (computeResultType env expr args)
-\end{code}
-
-Coercions
-~~~~~~~~~
-\begin{code}
-simplExpr env (Coerce coercion ty body) args
- = simplCoerce env coercion ty body args
+---------------------------------
+simplType :: SimplEnv -> InType -> SimplM OutType
+ -- Kept monadic just so we can do the seqType
+simplType env ty
+ = seqType new_ty `seq` returnSmpl new_ty
+ where
+ new_ty = substTy (getSubst env) ty
\end{code}
-Set-cost-centre
-~~~~~~~~~~~~~~~
-
-1) Eliminating nested sccs ...
-We must be careful to maintain the scc counts ...
+%************************************************************************
+%* *
+\subsection{Lambdas}
+%* *
+%************************************************************************
\begin{code}
-simplExpr env (SCC cc1 (SCC cc2 expr)) args
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
- -- eliminate inner scc if no call counts and same cc as outer
- = simplExpr env (SCC cc1 expr) args
-
- | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
- -- eliminate outer scc if no call counts associated with either ccs
- = simplExpr env (SCC cc2 expr) args
-\end{code}
+simplLam env fun cont
+ = go env fun cont
+ where
+ zap_it = mkLamBndrZapper fun 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 (extendSubst env bndr (DoneTy 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 zapped_bndr arg arg_se cont_ty $ \ env ->
+ go env body body_cont
+ where
+ zapped_bndr = zap_it bndr
+
+ -- Not enough args, so there are real lambdas left to put in the result
+ go env lam@(Lam _ _) cont
+ = simplLamBinders 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
-2) Moving sccs inside lambdas ...
-
-\begin{code}
-simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
- | not (isSccCountCostCentre cc)
- -- move scc inside lambda only if no call counts
- = simplExpr env (Lam binder (SCC cc body)) args
-
-simplExpr env (SCC cc (Lam binder body)) args
- -- always ok to move scc inside type/usage lambda
- = simplExpr env (Lam binder (SCC cc body)) args
-\end{code}
+ -- Exactly enough args
+ go env expr cont = simplExprF env expr cont
-3) Eliminating dict sccs ...
+mkLamBndrZapper :: CoreExpr -- Function
+ -> SimplCont -- The context
+ -> Id -> Id -- Use this to zap the binders
+mkLamBndrZapper fun cont
+ | 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_args = countArgs cont
-\begin{code}
-simplExpr env (SCC cc expr) args
- | squashableDictishCcExpr cc expr
- -- eliminate dict cc if trivial dict expression
- = simplExpr env expr args
+ n_params (Note _ e) = n_params e
+ n_params (Lam b e) = 1 + n_params e
+ n_params other = 0::Int
\end{code}
-4) Moving arguments inside the body of an scc ...
-This moves the cost of doing the application inside the scc
-(which may include the cost of extracting methods etc)
+
+%************************************************************************
+%* *
+\subsection{Notes}
+%* *
+%************************************************************************
\begin{code}
-simplExpr env (SCC cost_centre body) args
+simplNote env (Coerce to from) body cont
= let
- new_env = setEnclosingCC env (EnclosingCC cost_centre)
+ in_scope = getInScope env
+
+ addCoerce s1 k1 (CoerceIt t1 cont)
+ -- coerce T1 S1 (coerce S1 K1 e)
+ -- ==>
+ -- e, if T1=K1
+ -- coerce T1 K1 e, otherwise
+ --
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+ | t1 `eqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
+
+ addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
+ | Just (s1, s2) <- splitFunTy_maybe s1s2
+ -- (coerce (T1->T2) (S1->S2) F) E
+ -- ===>
+ -- coerce T2 S2 (F (coerce S1 T1 E))
+ --
+ -- t1t2 must be a function type, T1->T2
+ -- but s1s2 might conceivably not be
+ --
+ -- When we build the ApplyTo we can't mix the out-types
+ -- with the InExpr in the argument, so we simply substitute
+ -- to make it all consistent. It's a bit messy.
+ -- But it isn't a common case.
+ = let
+ (t1,t2) = splitFunTy t1t2
+ new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ in
+ ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
+
+ addCoerce to' _ cont = CoerceIt to' cont
in
- simplExpr new_env body args `thenSmpl` \ body' ->
- returnSmpl (SCC cost_centre body')
+ simplType env to `thenSmpl` \ to' ->
+ simplType env from `thenSmpl` \ from' ->
+ simplExprF env body (addCoerce to' from' cont)
+
+
+-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplNote 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)
+
+-- See notes with SimplMonad.inlineMode
+simplNote env InlineMe e cont
+ | contIsRhsOrArg cont -- Totally boring continuation; see notes above
+ = -- Don't inline inside an INLINE expression
+ simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' ->
+ rebuild env (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF env e cont
\end{code}
+
%************************************************************************
%* *
-\subsection{Simplify RHS of a Let/Letrec}
+\subsection{Dealing with calls}
%* *
%************************************************************************
-simplRhsExpr does arity-expansion. That is, given:
+\begin{code}
+simplVar env var cont
+ = case lookupIdSubst (getSubst env) var of
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx se e -> simplExprF (setSubstEnv env se) e cont
+ DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
+ text "simplVar:" <+> ppr var )
+ completeCall (zapSubstEnv env) var1 occ cont
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
+
+---------------------------------------------------------
+-- Dealing with a call
+
+completeCall env var occ_info cont
+ = getDOptsSmpl `thenSmpl` \ dflags ->
+ let
+ in_scope = getInScope env
+ chkr = getSwitchChecker env
- * a right hand side /\ tyvars -> \a1 ... an -> e
- * the information (stored in BinderInfo) that the function will always
- be applied to at least k arguments
+ (args, call_cont, inline_call) = getContArgs chkr var cont
-it transforms the rhs to
+ arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env)
+ | (arg, arg_env, _) <- args, isValArg arg]
- /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
+ interesting_cont = interestingCallContext (not (null args))
+ (not (null arg_infos))
+ call_cont
-This is a Very Good Thing!
+ inline_cont | inline_call = discardInline cont
+ | otherwise = cont
-\begin{code}
-simplRhsExpr
- :: SimplEnv
- -> InBinder
- -> InExpr
- -> SmplM OutExpr
-
-simplRhsExpr env binder@(id,occ_info) rhs
- | dont_eta_expand rhs
- = simplExpr rhs_env rhs []
-
- | otherwise -- Have a go at eta expansion
- = -- Deal with the big lambda part
- mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
- let
- lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
+ active_inline = activeInline env var
+ maybe_inline = callSiteInline dflags active_inline inline_call occ_info
+ var arg_infos interesting_cont
in
- -- Deal with the little lambda part
- -- Note that we call simplLam even if there are no binders, in case
- -- it can do arity expansion.
- simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
-
- -- Put it back together
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) tyvars' lambda'
- )
- where
- -- Note from ANDY:
- -- If you say {-# INLINE #-} then you get what's coming to you;
- -- you are saying inline the rhs, please.
- -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
- rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
- | otherwise = env
-
- (uvars, tyvars, binders, body) = collectBinders rhs
-
- min_no_of_args | not (null binders) && -- It's not a thunk
- switchIsSet env SimplDoArityExpand -- Arity expansion on
- = getBinderInfoArity occ_info - length binders
-
- | otherwise -- Not a thunk
- = 0 -- Play safe!
-
- -- dont_eta_expand prevents eta expansion in silly situations.
- -- For example, consider the defn
- -- x = y
- -- It would be silly to eta expand the "y", because it would just
- -- get eta-reduced back to y. Furthermore, if this was a top level defn,
- -- and x was exported, then the defn won't be eliminated, so this
- -- silly expand/reduce cycle will happen every time, which makes the
- -- simplifier loop!.
- -- The solution is to not even try eta expansion unless the rhs looks
- -- non-trivial.
- dont_eta_expand (Lit _) = True
- dont_eta_expand (Var _) = True
- dont_eta_expand (Con _ _) = True
- dont_eta_expand (App f a)
- | notValArg a = dont_eta_expand f
- dont_eta_expand (Lam x b)
- | notValBinder x = dont_eta_expand b
- dont_eta_expand _ = False
-\end{code}
+ -- First, look for an inlining
+ case maybe_inline of {
+ Just unfolding -- There is an inlining!
+ -> tick (UnfoldingDone var) `thenSmpl_`
+ simplExprF env unfolding inline_cont
+ ;
+ Nothing -> -- No inlining!
-%************************************************************************
-%* *
-\subsection{Simplify a lambda abstraction}
-%* *
-%************************************************************************
-Simplify (\binders -> body) trying eta expansion and reduction, given that
-the abstraction will always be applied to at least min_no_of_args.
+ simplifyArgs env args (contResultType call_cont) $ \ env args' ->
+
+ -- Next, look for rules or specialisations that match
+ --
+ -- It's important to simplify the args first, because the rule-matcher
+ -- doesn't do substitution as it goes. We don't want to use subst_args
+ -- (defined in the 'where') because that throws away useful occurrence info,
+ -- and perhaps-very-important specialisations.
+ --
+ -- Some functions have specialisations *and* are strict; in this case,
+ -- we don't want to inline the wrapper of the non-specialised thing; better
+ -- to call the specialised thing instead.
+ -- But the black-listing mechanism means that inlining of the wrapper
+ -- won't occur for things that have specialisations till a later phase, so
+ -- it's ok to try for inlining first.
+ --
+ -- You might think that we shouldn't apply rules for a loop breaker:
+ -- doing so might give rise to an infinite loop, because a RULE is
+ -- rather like an extra equation for the function:
+ -- RULE: f (g x) y = x+y
+ -- Eqn: f a y = a-y
+ --
+ -- But it's too drastic to disable rules for loop breakers.
+ -- Even the foldr/build rule would be disabled, because foldr
+ -- is recursive, and hence a loop breaker:
+ -- foldr k z (build g) = g k z
+ -- So it's up to the programmer: rules can cause divergence
-\begin{code}
-simplLam env binders body min_no_of_args
- | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
- null potential_extra_binder_tys || -- or ain't a function
- no_of_extra_binders == 0 -- or no extra binders needed
- = cloneIds env binders `thenSmpl` \ binders' ->
- let
- new_env = extendIdEnvWithClones env binders binders'
- in
- simplExpr new_env body [] `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) binders' body'
- )
-
- | otherwise -- Eta expansion possible
- = tick EtaExpansion `thenSmpl_`
- cloneIds env binders `thenSmpl` \ binders' ->
let
- new_env = extendIdEnvWithClones env binders binders'
+ maybe_rule = case activeRule env of
+ Nothing -> Nothing -- No rules apply
+ Just act_fn -> lookupRule act_fn in_scope var args'
in
- newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) (binders' ++ extra_binders') body'
- )
-
- where
- (potential_extra_binder_tys, res_ty)
- = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
- -- Note: it's possible that simplLam will be applied to something
- -- with a forall type. Eg when being applied to the rhs of
- -- let x = wurble
- -- where wurble has a forall-type, but no big lambdas at the top.
- -- We could be clever an insert new big lambdas, but we don't bother.
-
- extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
-
- no_of_extra_binders = -- First, use the info about how many args it's
- -- always applied to in its scope
- min_no_of_args
-
- -- Next, try seeing if there's a lambda hidden inside
- -- something cheap
- `max`
- etaExpandCount body
-
- -- Finally, see if it's a state transformer, in which
- -- case we eta-expand on principle! This can waste work,
- -- but usually doesn't
- `max`
- case potential_extra_binder_tys of
- [ty] | ty `eqTy` realWorldStateTy -> 1
- other -> 0
-
-\end{code}
-
+ case maybe_rule of {
+ Just (rule_name, rule_rhs) ->
+ tick (RuleFired rule_name) `thenSmpl_`
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ptext rule_name,
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
+ text "After: " <+> pprCoreExpr rule_rhs])
+ else
+ id) $
+ simplExprF env rule_rhs call_cont ;
+
+ Nothing -> -- No rules
+
+ -- Done
+ rebuild env (mkApps (Var var) args') call_cont
+ }}
+\end{code}
%************************************************************************
%* *
-\subsection[Simplify-coerce]{Coerce expressions}
+\subsection{Arguments}
%* *
%************************************************************************
\begin{code}
--- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
-simplCoerce env coercion ty expr@(Case scrut alts) args
- = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
- (computeResultType env expr args)
-
--- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
-simplCoerce env coercion ty (Let bind body) args
- = simplBind env bind (\env -> simplCoerce env coercion ty body args)
- (computeResultType env body args)
-
--- Default case
-simplCoerce env coercion ty expr args
- = simplExpr env expr [] `thenSmpl` \ expr' ->
- returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
+---------------------------------------------------------
+-- Simplifying the arguments of a call
+
+simplifyArgs :: SimplEnv
+ -> [(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 args cont_ty thing_inside
+ = go env args thing_inside
where
+ go env [] thing_inside = thing_inside env []
+ go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
+ go env args $ \ env args' ->
+ thing_inside env (arg':args')
+
+simplifyArg env (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)
- -- Try cancellation; we do this "on the way up" because
- -- I think that's where it'll bite best
- mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
- mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
- mkCoerce coercion ty body = Coerce coercion ty body
+simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
+ | is_strict
+ = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
+
+ | otherwise
+ = let
+ arg_env = setInScope arg_se env
+ in
+ simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
+ simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
+ addFloats env floats $ \ env ->
+ thing_inside env arg1
+
+
+simplStrictArg :: SimplEnv -- The env of the call
+ -> LetRhsFlag
+ -> InExpr -> SimplEnv -- The arg plus its env
+ -> 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 call_env is_rhs arg arg_env cont_ty thing_inside
+ = simplExprF (setInScope arg_env call_env) arg
+ (ArgOf NoDup is_rhs 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[Simplify-let]{Let-expressions}
+\subsection{mkAtomicArgs}
%* *
%************************************************************************
-\begin{code}
-simplBind :: SimplEnv
- -> InBinding
- -> (SimplEnv -> SmplM OutExpr)
- -> OutType
- -> SmplM OutExpr
-\end{code}
-
-When floating cases out of lets, remember this:
+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)
- let x* = case e of alts
- in <small expr>
+There are three sorts of binding context, specified by the two
+boolean arguments
-where x* is sure to be demanded or e is a cheap operation that cannot
-fail, e.g. unboxed addition. Here we should be prepared to duplicate
-<small expr>. A good example:
+Strict
+ OK-unlifted
- let x* = case y of
- p1 -> build e1
- p2 -> build e2
- in
- foldr c n x*
-==>
- case y of
- p1 -> foldr c n (build e1)
- p2 -> foldr c n (build e2)
+N N Top-level or recursive Only bind args of lifted type
-NEW: We use the same machinery that we use for case-of-case to
-*always* do case floating from let, that is we let bind and abstract
-the original let body, and let the occurrence analyser later decide
-whether the new let should be inlined or not. The example above
-becomes:
+N Y Non-top-level and non-recursive, Bind args of lifted type, or
+ but lazy unlifted-and-ok-for-speculation
-==>
- let join_body x' = foldr c n x'
- in case y of
- p1 -> let x* = build e1
- in join_body x*
- p2 -> let x* = build e2
- in join_body x*
+Y Y Non-top-level, non-recursive, Bind all args
+ and strict (demanded)
+
-note that join_body is a let-no-escape.
-In this particular example join_body will later be inlined,
-achieving the same effect.
-ToDo: check this is OK with andy
+For example, given
+ x = MkC (y div# z)
+there is no point in transforming to
-\begin{code}
--- Dead code is now discarded by the occurrence analyser,
+ x = case (y div# z) of r -> MkC r
-simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
- | inlineUnconditionally ok_to_dup occ_info
- = body_c (extendIdEnvWithInlining env env binder rhs)
-
--- Try let-to-case
--- It's important to try let-to-case before floating. Consider
---
--- let a*::Int = case v of {p1->e1; p2->e2}
--- in b
---
--- (The * means that a is sure to be demanded.)
--- If we do case-floating first we get this:
---
--- let k = \a* -> b
--- in case v of
--- p1-> let a*=e1 in k a
--- p2-> let a*=e2 in k a
---
--- Now watch what happens if we do let-to-case first:
---
--- case (case v of {p1->e1; p2->e2}) of
--- Int a# -> let a*=I# a# in b
--- ===>
--- let k = \a# -> let a*=I# a# in b
--- in case v of
--- p1 -> case e1 of I# a# -> k a#
--- p1 -> case e1 of I# a# -> k a#
---
--- The latter is clearly better. (Remember the reboxing let-decl
--- for a is likely to go away, because after all b is strict in a.)
-
- | will_be_demanded &&
- try_let_to_case &&
- type_ok_for_let_to_case rhs_ty &&
- not (manifestlyWHNF rhs)
- -- note: no "manifestlyBottom rhs" in there... (comment below)
- = tick Let2Case `thenSmpl_`
- mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
- simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
- {-
- We do not do let to case for WHNFs, e.g.
-
- let x = a:b in ...
- =/=>
- case a:b of x in ...
-
- as this is less efficient.
- but we don't mind doing let-to-case for "bottom", as that
- will
- allow us to remove more dead code, if anything:
- let x = error in ...
- ===>
- case error of x -> ...
- ===>
- error
-
- Notice that let to case occurs only if x is used strictly in
- its body (obviously).
- -}
-
- | (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
- floatExposesHNF float_lets float_primops ok_to_dup rhs
- = try_float env rhs body_c
+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.
- | otherwise
- = done_float env rhs body_c
+\begin{code}
+mkAtomicArgs :: Bool -- A strict binding
+ -> Bool -- OK to float unlifted args
+ -> OutExpr
+ -> SimplM ([(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
+ = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
+ case maybe_stuff of
+ Nothing -> returnSmpl ([], rhs)
+ Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
where
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- rhs_ty = idType id
-
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- float_primops = switchIsSet env SimplOkToFloatPrimOps
- ok_to_dup = switchIsSet env SimplOkToDupCode
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
- try_let_to_case = switchIsSet env SimplLetToCase
- no_float = switchIsSet env SimplNoLetFromStrictLet
-
- -------------------------------------------
- done_float env rhs body_c
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeLet env binder rhs' body_c body_ty
-
- ---------------------------------------
- try_float env (Let bind rhs) body_c
- = tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
- (\env -> try_float env rhs body_c) body_ty
-
- try_float env (Case scrut alts) body_c
- | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
- = tick CaseFloatFromLet `thenSmpl_`
-
- -- First, bind large let-body if necessary
- if no_need_to_bind_large_body then
- simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
- else
- bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
- let
- body_c' = \env -> simplExpr env new_body []
- in
- simplCase env scrut alts
- (\env rhs -> try_float env rhs body_c')
- body_ty `thenSmpl` \ case_expr ->
-
- returnSmpl (Let extra_binding case_expr)
- where
- no_need_to_bind_large_body
- = ok_to_dup || isSingleton (nonErrorRHSs alts)
+ mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
+ -- Nothing => no change
+ mk_atomic_args rhs
+ | (Var fun, args) <- collectArgs rhs, -- It's an application
+ isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
+ = -- Worth a try
+ go nilOL [] args `thenSmpl` \ maybe_stuff ->
+ case maybe_stuff of
+ Nothing -> returnSmpl Nothing
+ Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
+
+ | otherwise
+ = returnSmpl Nothing
+
+ go binds rev_args []
+ = returnSmpl (Just (binds, reverse rev_args))
+ go binds rev_args (arg : args)
+ | exprIsTrivial arg -- Easy case
+ = go binds (arg:rev_args) args
+
+ | not can_float_arg -- Can't make this arg atomic
+ = returnSmpl Nothing -- ... so give up
+
+ | otherwise -- Don't forget to do it recursively
+ -- E.g. x = a:b:c:[]
+ = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
+ case maybe_anf of {
+ Nothing -> returnSmpl Nothing ;
+ Just (arg_binds,arg') ->
+
+ newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
+ go ((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 )
+ returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
- try_float env other_rhs body_c = done_float env other_rhs body_c
+ | otherwise
+ = addAuxiliaryBind env (NonRec v r) $ \ env ->
+ addAtomicBindsE env bs thing_inside
\end{code}
-Letrec expressions
-~~~~~~~~~~~~~~~~~~
-
-Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
-on and it'll expose a HNF), and bang the whole resulting mess together
-into a huge letrec.
-1. Any "macros" should be expanded. The main application of this
-macro-expansion is:
-
- letrec
- f = ....g...
- g = ....f...
- in
- ....f...
+%************************************************************************
+%* *
+\subsection{The main rebuilder}
+%* *
+%************************************************************************
-Here we would like the single call to g to be inlined.
+\begin{code}
+rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
-We can spot this easily, because g will be tagged as having just one
-occurrence. The "inlineUnconditionally" predicate is just what we want.
+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 (exprType expr) 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
-A worry: could this lead to non-termination? For example:
+rebuildApp env fun arg cont
+ = simplExpr env arg `thenSmpl` \ arg' ->
+ rebuild env (App fun arg') cont
- letrec
- f = ...g...
- g = ...f...
- h = ...h...
- in
- ..h..
+rebuildDone env expr = returnSmpl (emptyFloats env, expr)
+\end{code}
-Here, f and g call each other (just once) and neither is used elsewhere.
-But it's OK:
-* the occurrence analyser will drop any (sub)-group that isn't used at
- all.
+%************************************************************************
+%* *
+\subsection{Functions dealing with a case}
+%* *
+%************************************************************************
-* If the group is used outside itself (ie in the "in" part), then there
- can't be a cyle.
+Blob of helper functions for the "case-of-something-else" situation.
-** IMPORTANT: check that NewOccAnal has the property that a group of
- bindings like the above has f&g dropped.! ***
+\begin{code}
+---------------------------------------------------------
+-- Eliminate the case if possible
+
+rebuildCase :: SimplEnv
+ -> OutExpr -- Scrutinee
+ -> InId -- Case binder
+ -> [InAlt] -- Alternatives
+ -> SimplCont
+ -> SimplM FloatsWithExpr
+
+rebuildCase env scrut case_bndr alts cont
+ | Just (con,args) <- exprIsConApp_maybe scrut
+ -- Works when the scrutinee is a variable with a known unfolding
+ -- as well as when it's an explicit constructor application
+ = knownCon env (DataAlt con) args case_bndr alts cont
+
+ | Lit lit <- scrut -- No need for same treatment as constructors
+ -- because literals are inlined more vigorously
+ = knownCon env (LitAlt lit) [] case_bndr alts cont
+ | otherwise
+ = -- Prepare case alternatives
+ -- Filter out alternatives that can't possibly match
+ let
+ impossible_cons = case scrut of
+ Var v -> otherCons (idUnfolding v)
+ other -> []
+ better_alts = case impossible_cons of
+ [] -> alts
+ other -> [alt | alt@(con,_,_) <- alts,
+ not (con `elem` impossible_cons)]
+ in
-2. We'd also like to pull out any top-level let(rec)s from the
-rhs of the defns:
+ -- Deal with the case binder, and prepare the continuation;
+ -- The new subst_env is in place
+ prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
- letrec
- f = let h = ... in \x -> ....h...f...h...
- in
- ...f...
-====>
- letrec
- h = ...
- f = \x -> ....h...f...h...
- in
- ...f...
+ -- Deal with variable scrutinee
+ simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
-But floating cases is less easy? (Don't for now; ToDo?)
+ -- Deal with the case alternatives
+ simplAlts alt_env zap_occ_info impossible_cons
+ case_bndr' better_alts cont' `thenSmpl` \ alts' ->
+ -- Put the case back together
+ mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
-3. We'd like to arrange that the RHSs "know" about members of the
-group that are bound to constructors. For example:
+ -- Notice that rebuildDone returns the in-scope set from env, not alt_env
+ -- The case binder *not* scope over the whole returned case-expression
+ rebuildDone env case_expr
+\end{code}
- let rec
- d.Eq = (==,/=)
- f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
- /= a b = unpack tuple a, unpack tuple b, call f
- in d.Eq
+simplCaseBinder checks whether the scrutinee is a variable, v. If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
-here, by knowing about d.Eq in f's rhs, one could get rid of
-the case (and break out the recursion completely).
-[This occurred with more aggressive inlining threshold (4),
-nofib/spectral/knights]
+Note 1
+~~~~~~
+There is a time we *don't* want to do that, namely when
+-fno-case-of-case is on. This happens in the first simplifier pass,
+and enhances full laziness. Here's the bad case:
+ f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
+If we eliminate the inner case, we trap it inside the I# v -> arm,
+which might prevent some full laziness happening. I've seen this
+in action in spectral/cichelli/Prog.hs:
+ [(m,n) | m <- [1..max], n <- [1..max]]
+Hence the check for NoCaseOfCase.
-How to do it?
- 1: we simplify constructor rhss first.
- 2: we record the "known constructors" in the environment
- 3: we simplify the other rhss, with the knowledge about the constructors
+Note 2
+~~~~~~
+There is another situation when we don't want to do it. If we have
+ case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+We'll perform the binder-swap for the outer case, giving
-\begin{code}
-simplBind env (Rec pairs) body_c body_ty
- = -- Do floating, if necessary
- (if float_lets || always_float_let_from_let
- then
- mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
- returnSmpl (concat floated_pairs_s)
- else
- returnSmpl pairs
- ) `thenSmpl` \ floated_pairs ->
- let
- binders = map fst floated_pairs
- in
- cloneIds env binders `thenSmpl` \ ids' ->
- let
- env_w_clones = extendIdEnvWithClones env binders ids'
- triples = zipEqual "simplBind" ids' floated_pairs
- in
+ case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
- simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
+But there is no point in doing it for the inner case,
+because w1 can't be inlined anyway. Furthermore, doing the case-swapping
+involves zapping w2's occurrence info (see paragraphs that follow),
+and that forces us to bind w2 when doing case merging. So we get
- body_c new_env `thenSmpl` \ body' ->
+ case x of w1 { A -> let w2 = w1 in e1
+ B -> let w2 = w1 in e2
+ ...other cases .... }
- returnSmpl (Let binding body')
+This is plain silly in the common case where w2 is dead.
- where
- ------------ Floating stuff -------------------
+Even so, I can't see a good way to implement this idea. I tried
+not doing the binder-swap if the scrutinee was already evaluated
+but that failed big-time:
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+ data T = MkT !Int
- float (binder,rhs)
- = let
- pairs_s = float_pair (binder,rhs)
- in
- case pairs_s of
- [_] -> returnSmpl pairs_s
- more_than_one
- -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
- -- It's important to increment the tick counts if we
- -- do any floating. A situation where this turns out
- -- to be important is this:
- -- Float in produces:
- -- letrec x = let y = Ey in Ex
- -- in B
- -- Now floating gives this:
- -- letrec x = Ex
- -- y = Ey
- -- in B
- --- We now want to iterate once more in case Ey doesn't
- -- mention x, in which case the y binding can be pulled
- -- out as an enclosing let(rec), which in turn gives
- -- the strictness analyser more chance.
- returnSmpl pairs_s
-
- float_pairs pairs = concat (map float_pair pairs)
-
- float_pair (binder, rhs)
- | always_float_let_from_let ||
- floatExposesHNF True False False rhs
- = (binder,rhs') : pairs'
-
- | otherwise
- = [(binder,rhs)]
- where
- (pairs', rhs') = do_float rhs
-
- -- Float just pulls out any top-level let(rec) bindings
- do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
- do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
- where
- (pairs', body') = do_float body
- do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
- where
- (pairs', body') = do_float body
- do_float other = ([], other)
-
-simplRecursiveGroup env triples
- = -- Toss out all the dead pairs? No, there shouldn't be any!
- -- Dead code is discarded by the occurrence analyser
- let
- -- Separate the live triples into "inline"able and
- -- "ordinary" We're paranoid about duplication!
- (inline_triples, ordinary_triples)
- = partition is_inline_triple triples
+ case v of w { MkT x ->
+ case x of x1 { I# y1 ->
+ case x of x2 { I# y2 -> ...
- is_inline_triple (_, ((_,occ_info),_))
- = inlineUnconditionally False {-not ok_to_dup-} occ_info
+Notice that because MkT is strict, x is marked "evaluated". But to
+eliminate the last case, we must either make sure that x (as well as
+x1) has unfolding MkT y1. THe straightforward thing to do is to do
+the binder-swap. So this whole note is a no-op.
- -- Now add in the inline_pairs info (using "env_w_clones"),
- -- so that we will save away suitably-clone-laden envs
- -- inside the InlineIts...).
+Note 3
+~~~~~~
+If we replace the scrutinee, v, by tbe case binder, then we have to nuke
+any occurrence info (eg IAmDead) in the case binder, because the
+case-binder now effectively occurs whenever v does. AND we have to do
+the same for the pattern-bound variables! Example:
- -- NOTE ALSO that we tie a knot here, because the
- -- saved-away envs must also include these very inlinings
- -- (they aren't stored anywhere else, and a late one might
- -- be used in an early one).
+ (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
- env_w_inlinings = foldl add_inline env inline_triples
+Here, b and p are dead. But when we move the argment inside the first
+case RHS, and eliminate the second case, we get
- add_inline env (id', (binder,rhs))
- = extendIdEnvWithInlining env env_w_inlinings binder rhs
+ case x or { (a,b) -> a b }
- -- Separate the remaining bindings into the ones which
- -- need to be dealt with first (the "early" ones)
- -- and the others (the "late" ones)
- (early_triples, late_triples)
- = partition is_early_triple ordinary_triples
+Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
+happened. Hence the zap_occ_info function returned by simplCaseBinder
- is_early_triple (_, (_, Con _ _)) = True
- is_early_triple (i, _ ) = idWantsToBeINLINEd i
- in
- -- Process the early bindings first
- mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
+\begin{code}
+simplCaseBinder env (Var v) case_bndr
+ | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
- -- Now further extend the environment to record our knowledge
- -- about the form of the binders bound in the constructor bindings
- let
- env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
- add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
- in
- -- Now process the non-constructor bindings
- mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
+-- Failed try [see Note 2 above]
+-- not (isEvaldUnfolding (idUnfolding v))
- -- Phew! We're done
- let
- binding = Rec (map snd early_triples' ++ map snd late_triples')
- in
- returnSmpl (binding, env_w_early_info)
+ = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
+ returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
+ -- 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 just just as well.
where
-
- do_one_binding env (id', (binder,rhs))
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- returnSmpl (binder, (id', rhs'))
+ zap b = b `setIdOccInfo` NoOccInfo
+
+simplCaseBinder env other_scrut case_bndr
+ = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
+ returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
\end{code}
-@completeLet@ looks at the simplified post-floating RHS of the
-let-expression, and decides what to do. There's one interesting
-aspect to this, namely constructor reuse. Consider
-@
- f = \x -> case x of
- (y:ys) -> y:ys
- [] -> ...
-@
-Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
-bit on the compiler technology, but in general I believe not. For
-example, here's some code from a real program:
-@
-const.Int.max.wrk{-s2516-} =
- \ upk.s3297# upk.s3298# ->
- let {
- a.s3299 :: Int
- _N_ {-# U(P) #-}
- a.s3299 = I#! upk.s3297#
- } in
- case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
- _LT -> I#! upk.s3298#
- _EQ -> a.s3299
- _GT -> a.s3299
- }
-@
-The a.s3299 really isn't doing much good. We'd be better off inlining
-it. (Actually, let-no-escapery means it isn't as bad as it looks.)
-
-So the current strategy is to inline all known-form constructors, and
-only do the reverse (turn a constructor application back into a
-variable) when we find a let-expression:
-@
- let x = C a1 .. an
- in
- ... (let y = C a1 .. an in ...) ...
-@
-where it is always good to ditch the binding for y, and replace y by
-x. That's just what completeLetBinding does.
\begin{code}
-completeLet
- :: SimplEnv
- -> InBinder
- -> OutExpr -- The simplified RHS
- -> (SimplEnv -> SmplM OutExpr) -- Body handler
- -> OutType -- Type of body
- -> SmplM OutExpr
-
-completeLet env binder new_rhs body_c body_ty
- -- See if RHS is an atom, or a reusable constructor
- | maybeToBool maybe_atomic_rhs
- = let
- new_env = extendIdEnvWithAtom env binder rhs_atom
- in
- tick atom_tick_type `thenSmpl_`
- body_c new_env
+simplAlts :: SimplEnv
+ -> (InId -> InId) -- Occ-info zapper
+ -> [AltCon] -- Alternatives the scrutinee can't be
+ -> OutId -- Case binder
+ -> [InAlt] -> SimplCont
+ -> SimplM [OutAlt] -- Includes the continuation
+
+simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
+ = mapSmpl simpl_alt alts
where
- maybe_atomic_rhs :: Maybe (OutArg, TickType)
- maybe_atomic_rhs = exprToAtom env new_rhs
- -- If the RHS is atomic, we return Just (atom, tick type)
- -- otherwise Nothing
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
-completeLet env binder@(id,_) new_rhs body_c body_ty
- -- Maybe the rhs is an application of error, and sure to be demanded
- | will_be_demanded &&
- maybeToBool maybe_error_app
- = tick CaseOfError `thenSmpl_`
- returnSmpl retyped_error_app
- where
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
- Just retyped_error_app = maybe_error_app
-
-{-
-completeLet env binder (Coerce coercion ty rhs) body_c body_ty
- -- Rhs is a coercion
- | maybeToBool maybe_atomic_coerce_rhs
- = tick tick_type `thenSmpl_`
- complete_coerce env rhs_atom rhs
- where
- maybe_atomic_coerce_rhs = exprToAtom env rhs
- Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
-
- returnSmpl (CoerceForm coercion rhs_atom, env)
- Nothing
- newId (coreExprType rhs) `thenSmpl` \ inner_id ->
-
- complete_coerce env atom rhs
- = cloneId env binder `thenSmpl` \ id' ->
- let
- env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
- in
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
--}
-
-completeLet env binder new_rhs body_c body_ty
- -- The general case
- = cloneId env binder `thenSmpl` \ id' ->
- let
- env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
- in
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec id' new_rhs) body')
+ inst_tys' = tyConAppArgs (idType case_bndr')
+
+ -- handled_cons is all the constructors that are dealt
+ -- with, either by being impossible, or by there being an alternative
+ (con_alts,_) = findDefault alts
+ handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
+
+ simpl_alt (DEFAULT, _, rhs)
+ = let
+ -- In the default case we record the constructors that the
+ -- case-binder *can't* be.
+ -- We take advantage of any OtherCon info in the case scrutinee
+ case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
+ env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
+ in
+ simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (DEFAULT, [], rhs')
+
+ simpl_alt (con, vs, rhs)
+ = -- Deal with the pattern-bound variables
+ -- Mark the ones that are in ! positions in the data constructor
+ -- as certainly-evaluated.
+ -- NB: it happens that simplBinders does *not* erase the OtherCon
+ -- form of unfolding, so it's ok to add this info before
+ -- doing simplBinders
+ simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
+
+ -- Bind the case-binder to (con args)
+ let
+ unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
+ env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
+ in
+ simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (con, vs', rhs')
+
+
+ -- add_evals records the evaluated-ness of the bound variables of
+ -- a case pattern. This is *important*. Consider
+ -- data T = T !Int !Int
+ --
+ -- case x of { T a b -> T (a+1) b }
+ --
+ -- We really must record that b is already evaluated so that we don't
+ -- go and re-evaluate it when constructing the result.
+
+ add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
+ add_evals other_con vs = vs
+
+ cat_evals [] [] = []
+ cat_evals (v:vs) (str:strs)
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isMarkedStrict str = evald_v : cat_evals vs strs
+ | otherwise = zapped_v : cat_evals vs strs
+ where
+ zapped_v = zap_occ_info v
+ evald_v = zapped_v `setIdUnfolding` mkOtherCon []
\end{code}
+
%************************************************************************
%* *
-\subsection[Simplify-atoms]{Simplifying atoms}
+\subsection{Known constructor}
%* *
%************************************************************************
-\begin{code}
-simplArg :: SimplEnv -> InArg -> OutArg
+We are a bit careful with occurrence info. Here's an example
-simplArg env (LitArg lit) = LitArg lit
-simplArg env (TyArg ty) = TyArg (simplTy env ty)
+ (\x* -> case x of (a*, b) -> f a) (h v, e)
-simplArg env (VarArg id)
- | isLocallyDefined id
- = case lookupId env id of
- Just (ItsAnAtom atom) -> atom
- Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
- Nothing -> VarArg id -- Must be an uncloned thing
-
- | otherwise
- = -- Not locally defined, so no change
- VarArg id
-\end{code}
+where the * means "occurs once". This effectively becomes
+ case (h v, e) of (a*, b) -> f a)
+and then
+ let a* = h v; b = e in f a
+and then
+ f (h v)
+All this should happen in one sweep.
\begin{code}
-exprToAtom env (Var var)
- = Just (VarArg var, AtomicRhs)
-
-exprToAtom env (Lit lit)
- | not (isNoRepLit lit)
- = Just (LitArg lit, AtomicRhs)
-
-exprToAtom env (Con con con_args)
- | switchIsSet env SimplReuseCon
- -- Look out for
- -- let v = C args
- -- in
- --- ...(let w = C same-args in ...)...
- -- Then use v instead of w. This may save
- -- re-constructing an existing constructor.
- = case (lookForConstructor env con con_args) of
- Nothing -> Nothing
- Just var -> Just (VarArg var, ConReused)
-
-exprToAtom env other
- = Nothing
+knownCon :: SimplEnv -> AltCon -> [OutExpr]
+ -> InId -> [InAlt] -> SimplCont
+ -> SimplM FloatsWithExpr
+
+knownCon env con args bndr alts cont
+ = tick (KnownBranch bndr) `thenSmpl_`
+ case findAlt con alts of
+ (DEFAULT, bs, rhs) -> ASSERT( null bs )
+ simplNonRecX env bndr scrut $ \ env ->
+ -- This might give rise to a binding with non-atomic args
+ -- like x = Node (f x) (g x)
+ -- but no harm will be done
+ simplExprF env rhs cont
+ where
+ scrut = case con of
+ LitAlt lit -> Lit lit
+ DataAlt dc -> mkConApp dc args
+
+ (LitAlt lit, bs, rhs) -> ASSERT( null bs )
+ simplNonRecX env bndr (Lit lit) $ \ env ->
+ simplExprF env rhs cont
+
+ (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
+ bind_args env bs (drop n_tys args) $ \ env ->
+ let
+ con_app = mkConApp dc (take n_tys args ++ con_args)
+ con_args = [substExpr (getSubst 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_tys = dataConNumInstArgs dc -- Non-existential type args
+-- Ugh!
+bind_args env [] _ thing_inside = thing_inside env
+
+bind_args env (b:bs) (Type ty : args) thing_inside
+ = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
+
+bind_args env (b:bs) (arg : args) thing_inside
+ = simplNonRecX env b arg $ \ env ->
+ bind_args env bs args thing_inside
\end{code}
+
%************************************************************************
%* *
-\subsection[Simplify-quickies]{Some local help functions}
+\subsection{Duplicating continuations}
%* *
%************************************************************************
+\begin{code}
+prepareCaseCont :: SimplEnv
+ -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
+ -- plus some extra bindings
+
+prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
+ -- No need to make it duplicatable if there's only one alternative
+
+prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
+ mkDupableCont env alts_ty cont
+ -- At one time I passed in the un-simplified type, and simplified
+ -- it only if we needed to construct a join binder, but that
+ -- didn't work because we have to decompse function types
+ -- (using funResultTy) in mkDupableCont.
+\end{code}
\begin{code}
--- fix_up_demandedness switches off the willBeDemanded Info field
--- for bindings floated out of a non-demanded let
-fix_up_demandedness True {- Will be demanded -} bind
- = bind -- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
- = NonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (Rec pairs)
- = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
-
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
-
-is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
-is_cheap_prim_app other = False
-
-computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
-computeResultType env expr args
- = go expr_ty' args
+mkDupableCont :: SimplEnv
+ -> OutType -- Type of the thing to be given to the continuation
+ -> SimplCont
+ -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
+ -- plus some extra bindings
+
+mkDupableCont env ty cont
+ | contIsDupable cont
+ = returnSmpl (emptyFloats env, cont)
+
+mkDupableCont env _ (CoerceIt ty cont)
+ = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
+ returnSmpl (floats, CoerceIt ty cont')
+
+mkDupableCont env ty (InlinePlease cont)
+ = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
+ returnSmpl (floats, InlinePlease cont')
+
+mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
+ = -- e.g. (...strict-fn...) [...hole...]
+ -- ==>
+ -- let $j = \a -> ...strict-fn...
+ -- in $j [...hole...]
+
+ -- Build the join Id and continuation
+ -- We give it a "$j" name just so that for later amusement
+ -- we can identify any join points that don't end up as let-no-escapes
+ -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
+ newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
+ newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
+
+ cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
+ let
+ cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
+ join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
+ in
+
+ tick (CaseOfCase join_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
+
+ returnSmpl (unitFloat env join_id join_rhs,
+ ArgOf OkToDup is_rhs cont_ty cont_fn)
+
+mkDupableCont env ty (ApplyTo _ arg se cont)
+ = -- e.g. [...hole...] (...arg...)
+ -- ==>
+ -- let a = ...arg...
+ -- in [...hole...] a
+ mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
+
+ simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
+ if exprIsDupable arg' then
+ returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
+ else
+ newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
+
+ tick (CaseOfCase arg_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code.
+ -- Not strictly CaseOfCase, but never mind
+
+ returnSmpl (unitFloat env arg_id arg',
+ ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
+ -- But 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.
+
+
+mkDupableCont env ty (Select _ case_bndr alts se cont)
+ = -- e.g. (case [...hole...] of { pi -> ei })
+ -- ===>
+ -- let ji = \xij -> ei
+ -- in case [...hole...] of { pi -> ji xij }
+ tick (CaseOfCase case_bndr) `thenSmpl_`
+ let
+ alt_env = setInScope se env
+ in
+ prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
+ addFloats alt_env floats1 $ \ alt_env ->
+
+ simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
+ -- NB: simplBinder does not zap deadness occ-info, so
+ -- a dead case_bndr' will still advertise its deadness
+ -- This is really important because in
+ -- case e of b { (# a,b #) -> ... }
+ -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
+ -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
+ -- In the new alts we build, we have the new case binder, so it must retain
+ -- its deadness.
+
+ mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
+ addFloats alt_env floats2 $ \ alt_env ->
+ returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
+ (mkBoringStop (contResultType cont)))
+
+mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith [InAlt])
+-- Absorbs the continuation into the new alternatives
+
+mkDupableAlts env case_bndr' alts dupable_cont
+ = go env alts
where
- expr_ty = coreExprType (unTagBinders expr)
- expr_ty' = simplTy env expr_ty
-
- go ty [] = ty
- go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
- go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
- Just (_, res_ty) -> go res_ty args
- Nothing -> panic "computeResultType"
+ go env [] = returnSmpl (emptyFloats env, [])
+ go env (alt:alts)
+ = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
+ addFloats env floats1 $ \ env ->
+ go env alts `thenSmpl` \ (floats2, alts') ->
+ returnSmpl (floats2, alt' : alts')
+
+mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ simplExprC env rhs cont `thenSmpl` \ rhs' ->
+
+ if exprIsDupable rhs' then
+ returnSmpl (emptyFloats env, (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 (not . isDeadBinder) (case_bndr' : bndrs')
+ -- The deadness info on the new binders is unscathed
+ 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 null used_bndrs'
+ then newId SLIT("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 SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
+ -- join point is sure to be applied at most once, and doing so
+ -- prevents the body of the join point being floated out by
+ -- the full laziness pass
+ 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, (con, bndrs', join_call))
\end{code}
-
projects / ghc-hetmet.git / blobdiff