\section[Simplify]{The main module of the simplifier}
\begin{code}
-#include "HsVersions.h"
-
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(SmplLoop) -- paranoia checking
-IMPORT_1_3(List(partition))
+#include "HsVersions.h"
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, FormSummary(..) )
-import CostCentre ( isSccCountCostCentre, cmpCostCentre )
+import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
+ exprIsTrivial, whnfOrBottom, inlineUnconditionally,
+ FormSummary(..)
+ )
+import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
import CoreSyn
import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
unTagBinders, squashableDictishCcExpr
)
-import Id ( idType, idWantsToBeINLINEd,
- getIdDemandInfo, addIdDemandInfo,
- GenId{-instance NamedThing-}
+import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
+ addIdArity, getIdArity,
+ getIdDemandInfo, addIdDemandInfo
)
-import IdInfo ( willBeDemanded, DemandInfo )
+import Name ( isExported, isLocallyDefined )
+import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
+ atLeastArity, unknownArity )
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 SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
- splitFunTy, getFunTy_maybe, eqTy
+import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
+ mkFunTys, splitAlgTyConApp_maybe,
+ splitFunTys, splitFunTy_maybe, isUnpointedType
+ )
+import TysPrim ( realWorldStatePrimTy )
+import Util ( Eager, appEager, returnEager, runEager, mapEager,
+ isSingleton, zipEqual, zipWithEqual, mapAndUnzip
)
-import TysWiredIn ( realWorldStateTy )
-import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
+import Outputable
\end{code}
The controlling flags, and what they do
At the top level things are a little different.
* No cloning (not allowed for exported Ids, unnecessary for the others)
-
- * 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.
+ * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
\begin{code}
simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
-simplTopBinds env [] = returnSmpl []
-
-- Dead code is now discarded by the occurrence analyser,
-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' ->
- completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds1') ->
-
- -- Process the other bindings
- simplTopBinds new_env binds `thenSmpl` \ binds2' ->
-
- -- Glue together and return ...
- returnSmpl (binds1' ++ binds2')
-
-simplTopBinds env (Rec pairs : binds)
- = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) ->
-
- -- Process the other bindings
- simplTopBinds new_env binds `thenSmpl` \ binds' ->
-
- -- Glue together and return
- returnSmpl (bind' : binds')
+simplTopBinds env binds
+ = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
+ simpl_top_binds env (concat binds_s)
where
- ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level
+ simpl_top_binds env [] = returnSmpl []
+
+ simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
+ = --- No cloning necessary at top level
+ simplBinder env binder `thenSmpl` \ (env1, out_id) ->
+ simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
+ simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
+ returnSmpl (binds1' ++ binds2')
+
+ simpl_top_binds env (Rec pairs : binds)
+ = -- No cloning necessary at top level, but we nevertheless
+ -- add the Ids to the environment. This makes sure that
+ -- info carried on the Id (such as arity info) gets propagated
+ -- to occurrences.
+ --
+ -- This may seem optional, but I found an occasion when it Really matters.
+ -- Consider foo{n} = ...foo...
+ -- baz* = foo
+ --
+ -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
+ -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
+ -- thing: baz*{n} = ...baz...
+ --
+ -- Sure we could have made the indirection-shorting a bit cleverer, but
+ -- propagating pragma info is a Good Idea anyway.
+ simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) ->
+ simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) ->
+ simpl_top_binds new_env binds `thenSmpl` \ binds' ->
+ returnSmpl (Rec bind' : binds')
\end{code}
%************************************************************************
\begin{code}
simplExpr :: SimplEnv
-> InExpr -> [OutArg]
+ -> OutType -- Type of (e args); i.e. type of overall result
-> SmplM OutExpr
\end{code}
the more sophisticated stuff.
\begin{code}
-simplExpr env (Var v) args
- = case (lookupId env v) of
+simplExpr env (Var v) args result_ty
+ = case (runEager $ lookupId env v) of
LitArg lit -- A boring old literal
-> ASSERT( null args )
returnSmpl (Lit lit)
VarArg var -- More interesting! An id!
- -> completeVar env var args
+ -> completeVar env var args result_ty
-- Either Id is in the local envt, or it's a global.
-- In either case we don't need to apply the type
-- environment to it.
~~~~~~~~
\begin{code}
-simplExpr env (Lit l) [] = returnSmpl (Lit l)
+simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
#ifdef DEBUG
-simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
+simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
#endif
\end{code}
saturated and not higher-order. ADR)
\begin{code}
-simplExpr env (Prim op prim_args) args
+simplExpr env (Prim op prim_args) args result_ty
= ASSERT (null args)
- let
- prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
- op' = simpl_op op
- in
+ mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
+ simpl_op op `appEager` \ op' ->
completePrim env op' prim_args'
where
-- PrimOps just need any types in them renamed.
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'
+ = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
+ simplTy env result_ty `appEager` \ result_ty' ->
+ returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
- simpl_op other_op = other_op
+ simpl_op other_op = returnEager other_op
\end{code}
Constructor applications
rhs of a let binding (see completeLetBinding).
\begin{code}
-simplExpr env (Con con con_args) args
+simplExpr env (Con con con_args) args result_ty
= ASSERT( null args )
- returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
+ mapEager (simplArg env) con_args `appEager` \ con_args' ->
+ returnSmpl (Con con con_args')
\end{code}
Just stuff 'em in the arg stack
\begin{code}
-simplExpr env (App fun arg) args
- = simplExpr env fun (simplArg env arg : args)
+simplExpr env (App fun arg) args result_ty
+ = simplArg env arg `appEager` \ arg' ->
+ simplExpr env fun (arg' : args) result_ty
\end{code}
Type lambdas
~~~~~~~~~~~~
-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@.
+First the case when it's applied to an argument.
\begin{code}
-simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
- = -- ASSERT(not (isPrimType ty))
- tick TyBetaReduction `thenSmpl_`
- simplExpr (extendTyEnv env tyvar ty) body args
-
-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
+simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
+ = tick TyBetaReduction `thenSmpl_`
+ simplExpr (bindTyVar env tyvar ty) body args result_ty
+\end{code}
- do_tylambdas env tyvars' body
- = simplExpr env body [] `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) (reverse tyvars') body'
- )
+\begin{code}
+simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
+ = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') ->
+ let
+ new_result_ty = applyTy result_ty (mkTyVarTy tyvar')
+ in
+ simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
+ returnSmpl (Lam (TyBinder tyvar') body')
#ifdef DEBUG
-simplExpr env (Lam (TyBinder _) _) (_ : _)
+simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
= panic "simplExpr:TyLam with non-TyArg"
#endif
\end{code}
instead, the simplifier is careful when partially applying lambdas.
\begin{code}
-simplExpr env expr@(Lam (ValBinder binder) body) orig_args
+simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
= go 0 env expr orig_args
where
go n env (Lam (ValBinder binder) body) (val_arg : args)
| isValArg val_arg -- The lambda has an argument
= tick BetaReduction `thenSmpl_`
- go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
+ go (n+1) (bindIdToAtom env binder val_arg) body args
go n env expr@(Lam (ValBinder binder) body) args
-- The lambda is un-saturated, so we must zap the occurrence info
let
new_env = markDangerousOccs env (take n orig_args)
in
- simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
+ simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
+ `thenSmpl` \ (expr', arity) ->
+ returnSmpl expr'
go n env non_val_lam_expr args -- The lambda had enough arguments
- = simplExpr env non_val_lam_expr args
+ = simplExpr env non_val_lam_expr args result_ty
\end{code}
~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env (Let bind body) args
- = simplBind env bind (\env -> simplExpr env body args)
- (computeResultType env body args)
+simplExpr env (Let bind body) args result_ty
+ = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
\end{code}
Case expressions
~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env expr@(Case scrut alts) args
- = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
- (computeResultType env expr args)
+simplExpr env expr@(Case scrut alts) args result_ty
+ = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
\end{code}
Coercions
~~~~~~~~~
\begin{code}
-simplExpr env (Coerce coercion ty body) args
- = simplCoerce env coercion ty body args
+simplExpr env (Coerce coercion ty body) args result_ty
+ = simplCoerce env coercion ty body args result_ty
\end{code}
We must be careful to maintain the scc counts ...
\begin{code}
-simplExpr env (SCC cc1 (SCC cc2 expr)) args
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
+simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
+ | 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
+ = simplExpr env (SCC cc1 expr) args result_ty
| not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
-- eliminate outer scc if no call counts associated with either ccs
- = simplExpr env (SCC cc2 expr) args
+ = simplExpr env (SCC cc2 expr) args result_ty
\end{code}
2) Moving sccs inside lambdas ...
\begin{code}
-simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
+simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
| not (isSccCountCostCentre cc)
-- move scc inside lambda only if no call counts
- = simplExpr env (Lam binder (SCC cc body)) args
+ = simplExpr env (Lam binder (SCC cc body)) args result_ty
-simplExpr env (SCC cc (Lam binder body)) args
+simplExpr env (SCC cc (Lam binder body)) args result_ty
-- always ok to move scc inside type/usage lambda
- = simplExpr env (Lam binder (SCC cc body)) args
+ = simplExpr env (Lam binder (SCC cc body)) args result_ty
\end{code}
3) Eliminating dict sccs ...
\begin{code}
-simplExpr env (SCC cc expr) args
+simplExpr env (SCC cc expr) args result_ty
| squashableDictishCcExpr cc expr
-- eliminate dict cc if trivial dict expression
- = simplExpr env expr args
+ = simplExpr env expr args result_ty
\end{code}
4) Moving arguments inside the body of an scc ...
(which may include the cost of extracting methods etc)
\begin{code}
-simplExpr env (SCC cost_centre body) args
+simplExpr env (SCC cost_centre body) args result_ty
= let
new_env = setEnclosingCC env cost_centre
in
- simplExpr new_env body args `thenSmpl` \ body' ->
+ simplExpr new_env body args result_ty `thenSmpl` \ body' ->
returnSmpl (SCC cost_centre body')
\end{code}
:: SimplEnv
-> InBinder
-> InExpr
- -> SmplM OutExpr
+ -> OutId -- The new binder (used only for its type)
+ -> SmplM (OutExpr, ArityInfo)
+\end{code}
-simplRhsExpr env binder@(id,occ_info) rhs
- | dont_eta_expand rhs
- = simplExpr rhs_env rhs []
- | otherwise -- Have a go at eta expansion
+\begin{code}
+simplRhsExpr env binder@(id,occ_info) rhs new_id
+ | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
+ -- Deal with the data type case, in which case the elaborate
+ -- eta-expansion nonsense is really quite a waste of time.
+ = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
+ returnSmpl (rhs', ArityExactly 0)
+
+ | otherwise -- OK, use the big hammer
= -- Deal with the big lambda part
- ASSERT( null uvars ) -- For now
-
- mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
+ simplTyBinders env tyvars `thenSmpl` \ (lam_env, tyvars') ->
let
- lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
+ body_ty = applyTys rhs_ty (mkTyVarTys tyvars')
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.
- simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' ->
+ simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
- -- Put it back together
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) tyvars' lambda'
- )
- where
+ -- Put on the big lambdas, trying to float out any bindings caught inside
+ mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
- rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
- idWantsToBeINLINEd id
- = switchOffInlining env
+ returnSmpl (rhs', arity)
+ where
+ rhs_ty = idType new_id
+ rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
+ = switchOffInlining env1 -- See comments with switchOffInlining
| otherwise
- = env
+ = env1
- -- Switch off all inlining in the RHS of things that have an INLINE pragma.
- -- They are going to be inlined wherever they are used, and then all the
- -- inlining will take effect. Meanwhile, there isn't
- -- much point in doing anything to the as-yet-un-INLINEd rhs.
- -- It's very important to switch off inlining! Consider:
- --
- -- let f = \pq -> BIG
- -- in
- -- let g = \y -> f y y
- -- {-# INLINE g #-}
- -- in ...g...g...g...g...g...
- --
- -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
- -- and thence copied multiple times when g is inlined.
+ -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
+ -- for the rhs of top level defs is "OST_CENTRE". Consider
+ -- f = \x -> e
+ -- g = \y -> let v = f y in scc "x" (v ...)
+ -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
+ -- want to inline "v" since its CC is dynamically determined.
- -- Andy disagrees! Example:
- -- all xs = foldr (&&) True xs
- -- any p = all . map p {-# INLINE any #-}
- --
- -- Problem: any won't get deforested, and so if it's exported and
- -- the importer doesn't use the inlining, (eg passes it as an arg)
- -- then we won't get deforestation at all.
- -- We havn't solved this problem yet!
-
- (uvars, tyvars, body) = collectUsageAndTyBinders rhs
-
- -- 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
+ current_cc = getEnclosingCC env
+ env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
+ | otherwise = env
+
+ (tyvars, body) = collectTyBinders rhs
\end{code}
+----------------------------------------------------------------
+ An old special case that is now nuked.
+
+First a special case for variable right-hand sides
+ v = w
+It's OK to simplify the RHS, but it's often a waste of time. Often
+these v = w things persist because v is exported, and w is used
+elsewhere. So if we're not careful we'll eta expand the rhs, only
+to eta reduce it in competeNonRec.
+
+If we leave the binding unchanged, we will certainly replace v by w at
+every occurrence of v, which is good enough.
+
+In fact, it's *better* to replace v by w than to inline w in v's rhs,
+even if this is the only occurrence of w. Why? Because w might have
+IdInfo (such as strictness) that v doesn't.
+
+Furthermore, there might be other uses of w; if so, inlining w in
+v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
+
+HOWEVER, we have to be careful if w is something that *must* be
+inlined. In particular, its binding may have been dropped. Here's
+an example that actually happened:
+ let x = let y = e in y
+ in f x
+The "let y" was floated out, and then (since y occurs once in a
+definitely inlinable position) the binding was dropped, leaving
+ {y=e} let x = y in f x
+But now using the reasoning of this little section,
+y wasn't inlined, because it was a let x=y form.
+
+
+ HOWEVER
+
+This "optimisation" turned out to be a bad idea. If there's are
+top-level exported bindings like
+
+ y = I# 3#
+ x = y
+
+then y wasn't getting inlined in x's rhs, and we were getting
+bad code. So I've removed the special case from here, and
+instead we only try eta reduction and constructor reuse
+in completeNonRec if the thing is *not* exported.
+
+
+\begin{pseudocode}
+simplRhsExpr env binder@(id,occ_info) (Var v) new_id
+ | maybeToBool maybe_stop_at_var
+ = returnSmpl (Var the_var, getIdArity the_var)
+ where
+ maybe_stop_at_var
+ = case (runEager $ lookupId env v) of
+ VarArg v' | not (must_unfold v') -> Just v'
+ other -> Nothing
+
+ Just the_var = maybe_stop_at_var
+
+ must_unfold v' = idMustBeINLINEd v'
+ || case lookupOutIdEnv env v' of
+ Just (_, _, InUnfolding _ _) -> True
+ other -> False
+\end{pseudocode}
+
+ End of old, nuked, special case.
+------------------------------------------------------------------
+
+
%************************************************************************
%* *
\subsection{Simplify a lambda abstraction}
the abstraction will always be applied to at least min_no_of_args.
\begin{code}
-simplValLam env expr min_no_of_args
+simplValLam env expr min_no_of_args expr_ty
| not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
- null binders || -- or it's a thunk
+
+ exprIsTrivial expr || -- or it's a trivial RHS
+ -- No eta expansion for trivial RHSs
+ -- It's rather a Bad Thing to expand
+ -- g = f alpha beta
+ -- to
+ -- g = \a b c -> f alpha beta a b c
+ --
+ -- The original RHS is "trivial" (exprIsTrivial), because it generates
+ -- no code (renames f to g). But the new RHS isn't.
+
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'
- )
+ = simplBinders env binders `thenSmpl` \ (new_env, binders') ->
+ simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
+ returnSmpl (mkValLam binders' body', final_arity)
| otherwise -- Eta expansion possible
- = tick EtaExpansion `thenSmpl_`
- cloneIds env binders `thenSmpl` \ binders' ->
- let
- new_env = extendIdEnvWithClones env binders binders'
- in
- newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
+ = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
+ (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
+ pprTrace "simplValLam" (vcat [ppr expr,
+ ppr expr_ty,
+ ppr binders,
+ int no_of_extra_binders,
+ ppr potential_extra_binder_tys])
+ else \x -> x) $
+
+ tick EtaExpansion `thenSmpl_`
+ simplBinders env binders `thenSmpl` \ (new_env, binders') ->
+ newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
+ simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
returnSmpl (
- (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) (binders' ++ extra_binders') body'
+ mkValLam (binders' ++ extra_binders') body',
+ final_arity
)
where
- (binders,body) = collectValBinders expr
- (potential_extra_binder_tys, res_ty)
- = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
+ (binders,body) = collectValBinders expr
+ no_of_binders = length binders
+ (arg_tys, res_ty) = splitFunTys expr_ty
+ potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
+ pprTrace "simplValLam" (vcat [ppr expr,
+ ppr expr_ty,
+ ppr binders])
+ else \x->x) $
+ drop no_of_binders arg_tys
+ body_ty = mkFunTys potential_extra_binder_tys res_ty
+
-- Note: it's possible that simplValLam 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
+ etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
+ extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
+ final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
no_of_extra_binders = -- First, use the info about how many args it's
- -- always applied to in its scope
- (min_no_of_args - length binders)
+ -- always applied to in its scope; but ignore this
+ -- info for thunks. To see why we ignore it for thunks,
+ -- consider let f = lookup env key in (f 1, f 2)
+ -- We'd better not eta expand f just because it is
+ -- always applied!
+ (min_no_of_args - no_of_binders)
-- Next, try seeing if there's a lambda hidden inside
- -- something cheap
+ -- something cheap.
+ -- etaExpandCount can reuturn a huge number (like 10000!) if
+ -- it finds that the body is a call to "error"; hence
+ -- the use of "min" here.
`max`
- etaExpandCount body
+ (etaExpandCount body `min` length potential_extra_binder_tys)
-- 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
+ [ty] | ty == realWorldStatePrimTy -> 1
other -> 0
-
\end{code}
\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)
+simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
+ = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
-- (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)
+simplCoerce env coercion ty (Let bind body) args result_ty
+ = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
-- Default case
-simplCoerce env coercion ty expr args
- = simplExpr env expr [] `thenSmpl` \ expr' ->
- returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
+simplCoerce env coercion ty expr args result_ty
+ = simplTy env ty `appEager` \ ty' ->
+ simplTy env expr_ty `appEager` \ expr_ty' ->
+ simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
+ returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
where
+ expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
-- Try cancellation; we do this "on the way up" because
-- I think that's where it'll bite best
%************************************************************************
%* *
-\subsection[Simplify-let]{Let-expressions}
+\subsection[Simplify-bind]{Binding groups}
%* *
%************************************************************************
-> (SimplEnv -> SmplM OutExpr)
-> OutType
-> SmplM OutExpr
+
+simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
+simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection[Simplify-let]{Let-expressions}
+%* *
+%************************************************************************
+
+Float switches
+~~~~~~~~~~~~~~
+The booleans controlling floating have to be set with a little care.
+Here's one performance bug I found:
+
+ let x = let y = let z = case a# +# 1 of {b# -> E1}
+ in E2
+ in E3
+ in E4
+
+Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
+Before case_floating_ok included float_exposes_hnf, the case expression was floated
+*one level per simplifier iteration* outwards. So it made th s
+
+
+Floating case from let
+~~~~~~~~~~~~~~~~~~~~~~
When floating cases out of lets, remember this:
let x* = case e of alts
ToDo: check this is OK with andy
+Let to case: two points
+~~~~~~~~~~~
-\begin{code}
--- Dead code is now discarded by the occurrence analyser,
+Point 1. We defer let-to-case for all data types except single-constructor
+ones. Suppose we change
-simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
- = simpl_bind env rhs
- where
- -- Try let-to-case; see notes below about let-to-case
- simpl_bind env rhs | will_be_demanded &&
- try_let_to_case &&
- type_ok_for_let_to_case rhs_ty &&
- rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
- = tick Let2Case `thenSmpl_`
- mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
- simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty
+ let x* = e in b
+to
+ case e of x -> b
- -- Try let-from-let
- simpl_bind env (Let bind rhs) | let_floating_ok
- = tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
- (\env -> simpl_bind env rhs) body_ty
+It can be the case that we find that b ultimately contains ...(case x of ..)....
+and this is the only occurrence of x. Then if we've done let-to-case
+we can't inline x, which is a real pain. On the other hand, we lose no
+transformations by not doing this transformation, because the relevant
+case-of-X transformations are also implemented by simpl_bind.
- -- Try case-from-let; this deals with a strict let of error too
- simpl_bind env (Case scrut alts) | will_be_demanded ||
- (float_primops && is_cheap_prim_app scrut)
- = tick CaseFloatFromLet `thenSmpl_`
+If x is a single-constructor type, then we go ahead anyway, giving
- -- First, bind large let-body if necessary
- if ok_to_dup || isSingleton (nonErrorRHSs alts)
- then
- simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
- else
- bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
- let
- body_c' = \env -> simplExpr env new_body []
- case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
- in
- simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
- returnSmpl (Let extra_binding case_expr)
+ case e of (y,z) -> let x = (y,z) in b
- -- None of the above; simplify rhs and tidy up
- simpl_bind env rhs
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (mkCoLetsAny binds body')
+because now we can squash case-on-x wherever they occur in b.
+We do let-to-case on multi-constructor types in the tidy-up phase
+(tidyCoreExpr) mainly so that the code generator doesn't need to
+spot the demand-flag.
- -- All this stuff is computed at the start of the simpl_bind loop
- 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
-
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- rhs_ty = idType id
-
- rhs_is_whnf = case mkFormSummary rhs of
- VarForm -> True
- ValueForm -> True
- other -> False
-
- let_floating_ok = (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
- floatExposesHNF float_lets float_primops ok_to_dup rhs
-\end{code}
-Let to case
-~~~~~~~~~~~
-It's important to try let-to-case before floating. Consider
+Point 2. It's important to try let-to-case before doing the
+strict-let-of-case transformation, which happens in the next equation
+for simpl_bind.
let a*::Int = case v of {p1->e1; p2->e2}
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#
+ p1 -> case e2 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.)
(obviously).
-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...
-
-Here we would like the single call to g to be inlined.
+\begin{code}
+-- Dead code is now discarded by the occurrence analyser,
-We can spot this easily, because g will be tagged as having just one
-occurrence. The "inlineUnconditionally" predicate is just what we want.
+simplNonRec env binder@(id,occ_info) rhs body_c body_ty
+ | inlineUnconditionally ok_to_dup id occ_info
+ = -- The binder is used in definitely-inline way in the body
+ -- So add it to the environment, drop the binding, and continue
+ body_c (extendEnvGivenInlining env id occ_info rhs)
+
+ | idWantsToBeINLINEd id
+ = complete_bind env rhs -- Don't mess about with floating or let-to-case on
+ -- INLINE things
+
+ -- Do let-to-case right away for unpointed types
+ -- These shouldn't occur much, but do occur right after desugaring,
+ -- because we havn't done dependency analysis at that point, so
+ -- we can't trivially do let-to-case (because there may be some unboxed
+ -- things bound in letrecs that aren't really recursive).
+ | isUnpointedType rhs_ty && not rhs_is_whnf
+ = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
+ (\env rhs -> complete_bind env rhs) body_ty
+
+ -- Try let-to-case; see notes below about let-to-case
+ | try_let_to_case &&
+ will_be_demanded &&
+ ( rhs_is_bot
+ || (not rhs_is_whnf && singleConstructorType rhs_ty)
+ -- Don't do let-to-case if the RHS is a constructor application.
+ -- Even then only do it for single constructor types.
+ -- For other types we defer doing it until the tidy-up phase at
+ -- the end of simplification.
+ )
+ = tick Let2Case `thenSmpl_`
+ simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
+ (\env rhs -> complete_bind env rhs) body_ty
+ -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
+ -- NB: it's tidier to call complete_bind not simpl_bind, else
+ -- we nearly end up in a loop. Consider:
+ -- let x = rhs in b
+ -- ==> case rhs of (p,q) -> let x=(p,q) in b
+ -- This effectively what the above simplCase call does.
+ -- Now, the inner let is a let-to-case target again! Actually, since
+ -- the RHS is in WHNF it won't happen, but it's a close thing!
+
+ | otherwise
+ = simpl_bind env rhs
+ where
+ -- Try let-from-let
+ simpl_bind env (Let bind rhs) | let_floating_ok
+ = tick LetFloatFromLet `thenSmpl_`
+ simplBind env (if will_be_demanded then bind
+ else un_demandify_bind bind)
+ (\env -> simpl_bind env rhs) body_ty
-A worry: could this lead to non-termination? For example:
+ -- Try case-from-let; this deals with a strict let of error too
+ simpl_bind env (Case scrut alts) | case_floating_ok scrut
+ = tick CaseFloatFromLet `thenSmpl_`
- letrec
- f = ...g...
- g = ...f...
- h = ...h...
- in
- ..h..
+ -- First, bind large let-body if necessary
+ if ok_to_dup || isSingleton (nonErrorRHSs alts)
+ then
+ simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
+ else
+ bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
+ let
+ body_c' = \env -> simplExpr env new_body [] body_ty
+ case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
+ in
+ simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
+ returnSmpl (Let extra_binding case_expr)
-Here, f and g call each other (just once) and neither is used elsewhere.
-But it's OK:
+ -- None of the above; simplify rhs and tidy up
+ simpl_bind env rhs = complete_bind env rhs
+
+ complete_bind env rhs
+ = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
+ simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env_w_clone binder
+ (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
+ body_c new_env `thenSmpl` \ body' ->
+ returnSmpl (mkCoLetsAny binds body')
-* the occurrence analyser will drop any (sub)-group that isn't used at
- all.
-* If the group is used outside itself (ie in the "in" part), then there
- can't be a cyle.
+ -- All this stuff is computed at the start of the simpl_bind loop
+ 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
-** IMPORTANT: check that NewOccAnal has the property that a group of
- bindings like the above has f&g dropped.! ***
+ demand_info = getIdDemandInfo id
+ will_be_demanded = willBeDemanded demand_info
+ rhs_ty = idType id
+ form = mkFormSummary rhs
+ rhs_is_bot = case form of
+ BottomForm -> True
+ other -> False
+ rhs_is_whnf = case form of
+ VarForm -> True
+ ValueForm -> True
+ other -> False
-2. We'd also like to pull out any top-level let(rec)s from the
-rhs of the defns:
+ float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
- letrec
- f = let h = ... in \x -> ....h...f...h...
- in
- ...f...
-====>
- letrec
- h = ...
- f = \x -> ....h...f...h...
- in
- ...f...
+ let_floating_ok = (will_be_demanded && not no_float) ||
+ always_float_let_from_let ||
+ float_exposes_hnf
-But floating cases is less easy? (Don't for now; ToDo?)
+ case_floating_ok scrut = (will_be_demanded && not no_float) ||
+ (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
+ -- See note below
+\end{code}
-3. We'd like to arrange that the RHSs "know" about members of the
-group that are bound to constructors. For example:
+@completeNonRec@ looks at the simplified post-floating RHS of the
+let-expression, with a view to turning
+ x = e
+into
+ x = y
+where y is just a variable. Now we can eliminate the binding
+altogether, and replace x by y throughout.
- 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
+There are two cases when we can do this:
-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]
+ * When e is a constructor application, and we have
+ another variable in scope bound to the same
+ constructor application. [This is just a special
+ case of common-subexpression elimination.]
-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
+ * When e can be eta-reduced to a variable. E.g.
+ x = \a b -> y a b
+HOWEVER, if x is exported, we don't attempt this at all. Why not?
+Because then we can't remove the x=y binding, in which case we
+have just made things worse, perhaps a lot worse.
\begin{code}
-simplBind env (Rec pairs) body_c body_ty
- = -- Do floating, if necessary
- let
- floated_pairs | do_floating = float_pairs pairs
- | otherwise = pairs
-
- ticks | do_floating = length floated_pairs - length pairs
- | otherwise = 0
-
- binders = map fst floated_pairs
- in
- tickN LetFloatFromLet ticks `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.
-
- cloneIds env binders `thenSmpl` \ ids' ->
- let
- env_w_clones = extendIdEnvWithClones env binders ids'
- in
- simplRecursiveGroup env ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
+completeNonRec env binder new_id new_rhs
+ = returnSmpl (env', [NonRec b r | (b,r) <- binds])
+ where
+ (env', binds) = completeBind env binder new_id new_rhs
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (Let binding body')
+completeBind :: SimplEnv
+ -> InBinder -> OutId -> OutExpr -- Id and RHS
+ -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
- where
- ------------ Floating stuff -------------------
+completeBind env binder@(_,occ_info) new_id new_rhs
+ | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = (env, new_binds)
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
- do_floating = float_lets || always_float_let_from_let
-
- 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 new_ids pairs
- = -- Add unfoldings to the new_ids corresponding to their RHS
+ | atomic_rhs -- If rhs (after eta reduction) is atomic
+ && not (isExported new_id) -- and binder isn't exported
+ = -- Drop the binding completely
let
- occs = [occ | ((_,occ), _) <- pairs]
- new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
- rhs_env = foldl extendEnvForRecBinding
- env new_ids_w_pairs
+ env1 = notInScope env new_id
+ env2 = bindIdToAtom env1 binder the_arg
in
+ (env2, [])
- mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
+ | atomic_rhs -- Rhs is atomic, and new_id is exported
+ && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
+ = -- The local variable v will be eliminated next time round
+ -- in favour of new_id, so it's a waste to replace all new_id's with v's
+ -- this time round.
+ -- This case is an optional improvement; saves a simplifier iteration
+ (env, [(new_id, eta'd_rhs)])
- let
- new_pairs = zipEqual "simplRecGp" new_ids new_rhss
- occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
- new_env = foldl (\env (occ_info,(new_id,new_rhs)) ->
- extendEnvGivenBinding env occ_info new_id new_rhs)
- env occs_w_new_pairs
- in
- returnSmpl (Rec new_pairs, new_env)
+ | otherwise -- Non-atomic
+ = let
+ env1 = extendEnvGivenBinding env occ_info new_id new_rhs
+ in
+ (env1, new_binds)
+
+ where
+ new_binds = [(new_id, new_rhs)]
+ atomic_rhs = is_atomic eta'd_rhs
+ eta'd_rhs = case lookForConstructor env new_rhs of
+ Just v -> Var v
+ other -> etaCoreExpr new_rhs
+
+ the_arg = case eta'd_rhs of
+ Var v -> VarArg v
+ Lit l -> LitArg l
\end{code}
+----------------------------------------------------------------------------
+ A digression on constructor CSE
-@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
+Consider
@
f = \x -> case x of
(y:ys) -> y:ys
... (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.
+x.
+ End of digression
+----------------------------------------------------------------------------
+
+----------------------------------------------------------------------------
+ A digression on "optimising" coercions
+
+ The trouble is that we kept transforming
+ let x = coerce e
+ y = coerce x
+ in ...
+ to
+ let x' = coerce e
+ y' = coerce x'
+ in ...
+ and counting a couple of ticks for this non-transformation
+\begin{pseudocode}
+ -- We want to ensure that all let-bound Coerces have
+ -- atomic bodies, so they can freely be inlined.
+completeNonRec env binder new_id (Coerce coercion ty rhs)
+ | not (is_atomic rhs)
+ = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
+ completeNonRec env
+ (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
+ -- Dangerous occ because, like constructor args,
+ -- it can be duplicated easily
+ let
+ atomic_rhs = case runEager $ lookupId env1 inner_id of
+ LitArg l -> Lit l
+ VarArg v -> Var v
+ in
+ completeNonRec env1 binder new_id
+ (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
+
+ returnSmpl (env2, binds1 ++ binds2)
+\end{pseudocode}
+----------------------------------------------------------------------------
+
+
+
+%************************************************************************
+%* *
+\subsection[Simplify-letrec]{Letrec-expressions}
+%* *
+%************************************************************************
+
+Letrec expressions
+~~~~~~~~~~~~~~~~~~
+Here's the game plan
+
+1. Float any let(rec)s out of the RHSs
+2. Clone all the Ids and extend the envt with these clones
+3. Simplify one binding at a time, adding each binding to the
+ environment once it's done.
+
+This relies on the occurrence analyser to
+ a) break all cycles with an Id marked MustNotBeInlined
+ b) sort the decls into topological order
+The former prevents infinite inlinings, and the latter means
+that we get maximum benefit from working top to bottom.
\begin{code}
- -- Sigh: rather disgusting case for coercions. We want to
- -- ensure that all let-bound Coerces have atomic bodies, so
- -- they can freely be inlined.
-completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
- = (case rhs of
- Var v -> returnSmpl (env, [], rhs)
- Lit l -> returnSmpl (env, [], rhs)
- other -> newId (coreExprType rhs) `thenSmpl` \ inner_id ->
- completeNonRec env
- (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) ->
- -- Dangerous occ because, like constructor args,
- -- it can be duplicated easily
- let
- atomic_rhs = case lookupId env1 inner_id of
- LitArg l -> Lit l
- VarArg v -> Var v
- in
- returnSmpl (env1, extra_bind, atomic_rhs)
- ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) ->
- -- Tiresome to do all this, but we must treat the lit/var cases specially
- -- or we get a tick for atomic rhs when effectively it's a no-op.
-
- cloneId env1 binder `thenSmpl` \ new_id ->
- let
- new_rhs = Coerce coercion ty atomic_rhs
- env2 = extendIdEnvWithClone env1 binder new_id
- new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs
- in
- returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
-
-completeNonRec env binder new_rhs
- -- See if RHS is an atom, or a reusable constructor
- | maybeToBool maybe_atomic_rhs
- = let
- new_env = extendIdEnvWithAtom env binder rhs_atom
+simplRec env pairs body_c body_ty
+ = -- Do floating, if necessary
+ floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
+ let
+ binders = map fst pairs'
in
- tick atom_tick_type `thenSmpl_`
- returnSmpl (new_env, [])
- where
- maybe_atomic_rhs = exprToAtom env new_rhs
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
+ simplBinders env binders `thenSmpl` \ (env_w_clones, ids') ->
+ simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
-completeNonRec env binder@(_,occ_info) new_rhs
- = cloneId env binder `thenSmpl` \ new_id ->
+ body_c new_env `thenSmpl` \ body' ->
+
+ returnSmpl (Let (Rec pairs') body')
+\end{code}
+
+\begin{code}
+-- The env passed to simplRecursiveGroup already has
+-- bindings that clone the variables of the group.
+simplRecursiveGroup env new_ids []
+ = returnSmpl ([], env)
+
+simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
+ | inlineUnconditionally ok_to_dup id occ_info
+ = -- Single occurrence, so drop binding and extend env with the inlining
+ -- This is a little delicate, because what if the unique occurrence
+ -- is *before* this binding? This'll never happen, because
+ -- either it'll be marked "never inline" or else its occurrence will
+ -- occur after its binding in the group.
+ --
+ -- If these claims aren't right Core Lint will spot an unbound
+ -- variable. A quick fix is to delete this clause for simplRecursiveGroup
+ let
+ new_env = extendEnvGivenInlining env new_id occ_info rhs
+ in
+ simplRecursiveGroup new_env new_ids pairs
+
+ | otherwise
+ = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
let
- env1 = extendIdEnvWithClone env binder new_id
- new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
+ new_id' = new_id `withArity` arity
+ (new_env, new_binds') = completeBind env binder new_id' new_rhs
in
- returnSmpl (new_env, [NonRec new_id new_rhs])
+ simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
+ returnSmpl (new_binds' ++ new_pairs, final_env)
+ where
+ ok_to_dup = switchIsSet env SimplOkToDupCode
\end{code}
+
+
+\begin{code}
+floatBind :: SimplEnv
+ -> Bool -- True <=> Top level
+ -> InBinding
+ -> SmplM [InBinding]
+
+floatBind env top_level bind
+ | not float_lets ||
+ n_extras == 0
+ = returnSmpl [bind]
+
+ | otherwise
+ = tickN LetFloatFromLet n_extras `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 binds'
+
+ where
+ binds' = fltBind bind
+ n_extras = sum (map no_of_binds binds') - no_of_binds bind
+
+ float_lets = switchIsSet env SimplFloatLetsExposingWHNF
+ always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+
+ -- fltBind guarantees not to return leaky floats
+ -- and all the binders of the floats have had their demand-info zapped
+ fltBind (NonRec bndr rhs)
+ = binds ++ [NonRec bndr rhs']
+ where
+ (binds, rhs') = fltRhs rhs
+
+ fltBind (Rec pairs)
+ = [Rec pairs']
+ where
+ pairs' = concat [ let
+ (binds, rhs') = fltRhs rhs
+ in
+ foldr get_pairs [(bndr, rhs')] binds
+ | (bndr, rhs) <- pairs
+ ]
+
+ get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
+ get_pairs (Rec pairs) rest = pairs ++ rest
+
+ -- fltRhs has same invariant as fltBind
+ fltRhs rhs
+ | (always_float_let_from_let ||
+ floatExposesHNF True False False rhs)
+ = fltExpr rhs
+
+ | otherwise
+ = ([], rhs)
+
+
+ -- fltExpr has same invariant as fltBind
+ fltExpr (Let bind body)
+ | not top_level || binds_wont_leak
+ -- fltExpr guarantees not to return leaky floats
+ = (binds' ++ body_binds, body')
+ where
+ binds_wont_leak = all leakFreeBind binds'
+ (body_binds, body') = fltExpr body
+ binds' = fltBind (un_demandify_bind bind)
+
+ fltExpr expr = ([], expr)
+
+-- Crude but effective
+no_of_binds (NonRec _ _) = 1
+no_of_binds (Rec pairs) = length pairs
+
+leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
+leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
+
+leakFree (id,_) rhs = case getIdArity id of
+ ArityAtLeast n | n > 0 -> True
+ ArityExactly n | n > 0 -> True
+ other -> whnfOrBottom (mkFormSummary rhs)
+\end{code}
+
+
%************************************************************************
%* *
\subsection[Simplify-atoms]{Simplifying atoms}
%************************************************************************
\begin{code}
-simplArg :: SimplEnv -> InArg -> OutArg
+simplArg :: SimplEnv -> InArg -> Eager ans OutArg
-simplArg env (LitArg lit) = LitArg lit
-simplArg env (TyArg ty) = TyArg (simplTy env ty)
+simplArg env (LitArg lit) = returnEager (LitArg lit)
+simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
+ returnEager (TyArg ty')
simplArg env (VarArg id) = lookupId env id
\end{code}
-
-\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
-\end{code}
-
%************************************************************************
%* *
\subsection[Simplify-quickies]{Some local help functions}
\begin{code}
--- fix_up_demandedness switches off the willBeDemanded Info field
+-- un_demandify_bind 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_bind (NonRec binder rhs)
+ = NonRec (un_demandify_bndr binder) rhs
+un_demandify_bind (Rec pairs)
+ = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
+un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, 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
- 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"
+computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
+computeResultType env expr_ty orig_args
+ = simplTy env expr_ty `appEager` \ expr_ty' ->
+ let
+ go ty [] = ty
+ go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
+ go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
+ Just (_, res_ty) -> go res_ty args
+ Nothing ->
+ pprPanic "computeResultType" (vcat [
+ ppr (a:args),
+ ppr orig_args,
+ ppr expr_ty',
+ ppr ty])
+ in
+ go expr_ty' orig_args
+
+
+var `withArity` UnknownArity = var
+var `withArity` arity = var `addIdArity` arity
+
+is_atomic (Var v) = True
+is_atomic (Lit l) = not (isNoRepLit l)
+is_atomic other = False
\end{code}