module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-import Ubiq{-uitous-}
-import SmplLoop -- paranoia checking
+IMPORT_1_3(List(partition))
+
+IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(SmplLoop) -- paranoia checking
+#endif
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
+import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
+ exprIsTrivial, whnfOrBottom, inlineUnconditionally,
+ FormSummary(..)
+ )
+import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
import CoreSyn
import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
- unTagBinders, squashableDictishCcExpr,
- manifestlyWHNF
+ unTagBinders, squashableDictishCcExpr
)
-import Id ( idType, idWantsToBeINLINEd,
+import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
+ addIdArity, getIdArity,
getIdDemandInfo, addIdDemandInfo,
GenId{-instance NamedThing-}
)
-import IdInfo ( willBeDemanded, DemandInfo )
+import Name ( isExported )
+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 PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
+#if __GLASGOW_HASKELL__ <= 30
+import PprCore ( GenCoreArg, GenCoreExpr )
+#endif
+import TyVar ( GenTyVar {- instance Eq -} )
+import Pretty --( ($$) )
import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
import SimplCase ( simplCase, bindLargeRhs )
import SimplEnv
import SimplMonad
import SimplVar ( completeVar )
+import Unique ( Unique )
import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
- splitFunTy, getFunTy_maybe, eqTy
+import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
+ splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
)
import TysWiredIn ( realWorldStateTy )
-import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
+import Outputable ( PprStyle(..), Outputable(..) )
+import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
+ isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
\end{code}
The controlling flags, and what they do
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.
+(cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
-Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
+Here, ``suitable'' might mean NoUnfolding (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
things in the UnfoldEnv with UnfoldAlways flags, which originated in
other INLINE pragmas.)
-So, we clean out the UnfoldEnv of all GenForm inlinings before
+So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
going into such an RHS.
What about imports? They don't really matter much because we only
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)
- | 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
-
-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' ->
-
- -- 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')
-
-simplTopBinds env (Rec pairs : binds)
- = simplRecursiveGroup env triples `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
- triples = [(id, (binder, rhs)) | (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
+ simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env binder (in_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.
+ let
+ env1 = extendIdEnvWithClones env binders ids
+ in
+ simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
+ simpl_top_binds new_env binds `thenSmpl` \ binds' ->
+ returnSmpl (Rec bind' : binds')
+ where
+ binders = map fst pairs
+ ids = map fst binders
\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
- 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
+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 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.
\end{code}
Literals
~~~~~~~~
\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)
+simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
= -- ASSERT(not (isPrimType ty))
- let
- new_env = extendTyEnv env tyvar ty
- in
tick TyBetaReduction `thenSmpl_`
- simplExpr new_env 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 (extendTyEnv 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
+ = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
+ let
+ new_ty = mkTyVarTy tyvar'
+ new_env = extendTyEnv env tyvar new_ty
+ new_result_ty = applyTy result_ty new_ty
+ 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}
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 )
+There's a complication with lambdas that aren't saturated.
+Suppose we have:
- (if not (null args) -- ah, we must've gotten rid of some...
- then tick BetaReduction
- else returnSmpl (panic "BetaReduction")
- ) `thenSmpl_`
+ (\x. \y. ...x...)
- simplLam env_for_too_few_args leftover_binders body
- 0 {- Guaranteed applied to at least 0 args! -}
+If we did nothing, x is used inside the \y, so would be marked
+as dangerous to dup. But in the common case where the abstraction
+is applied to two arguments this is over-pessimistic.
+So instead we don't take account of the \y when dealing with x's usage;
+instead, the simplifier is careful when partially applying lambdas.
+\begin{code}
+simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
+ = go 0 env expr orig_args
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)
-
-#ifdef DEBUG
- collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
- -- TyArg should never meet a Lam
-#endif
+ 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 env expr@(Lam (ValBinder binder) body) args
+ -- The lambda is un-saturated, so we must zap the occurrence info
+ -- on the arguments we've already beta-reduced into the body of the lambda
+ = ASSERT( null args ) -- Value lambda must match value argument!
+ let
+ new_env = markDangerousOccs env (take n orig_args)
+ in
+ 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 result_ty
\end{code}
~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env (Let bind body) args
-
-{- 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 -- No float from application
--}
-
- = 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}
Set-cost-centre
~~~~~~~~~~~~~~~
-A special case we do:
-\begin{verbatim}
- scc "foo" (\x -> e) ===> \x -> scc "foo" e
-\end{verbatim}
-Simon thinks it's OK, at least for lexical scoping; and it makes
-interfaces change less (arities).
+1) Eliminating nested sccs ...
+We must be careful to maintain the scc counts ...
\begin{code}
-simplExpr env (SCC cc (Lam binder body)) args
- = simplExpr env (Lam binder (SCC cc body)) args
+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 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 result_ty
\end{code}
-Some other slightly turgid SCC tidying-up cases:
+2) Moving sccs inside lambdas ...
+
\begin{code}
-simplExpr env (SCC cc1 expr@(SCC _ _)) args
- = simplExpr env expr args
- -- the outer _scc_ serves no purpose
+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 result_ty
+
+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 result_ty
+\end{code}
+
+3) Eliminating dict sccs ...
-simplExpr env (SCC cc expr) args
+\begin{code}
+simplExpr env (SCC cc expr) args result_ty
| squashableDictishCcExpr cc expr
- = simplExpr env expr args
- -- the DICT-ish CC is no longer serving any purpose
+ -- eliminate dict cc if trivial dict expression
+ = simplExpr env expr args result_ty
\end{code}
-NB: for other set-cost-centre we move arguments inside the body.
-ToDo: check with Patrick that this is ok.
+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)
\begin{code}
-simplExpr env (SCC cost_centre body) args
+simplExpr env (SCC cost_centre body) args result_ty
= let
- new_env = setEnclosingCC env (EnclosingCC cost_centre)
+ 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 (maybeAppDataTyCon 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' ->
let
- lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
+ new_tys = mkTyVarTys tyvars'
+ body_ty = foldl applyTy rhs_ty new_tys
+ lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
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' ->
+ -- 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) body_ty `thenSmpl` \ (lambda', arity) ->
- -- Put it back together
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) tyvars' lambda'
- )
+ -- Put on the big lambdas, trying to float out any bindings caught inside
+ mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
+
+ returnSmpl (rhs', arity)
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
+ 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
+ = env1
+
+ -- 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.
+
+ current_cc = getEnclosingCC env
+ env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
+ | otherwise = env
+
+ (uvars, tyvars, body) = collectUsageAndTyBinders 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}
-simplLam env binders body min_no_of_args
+simplValLam env expr min_no_of_args expr_ty
| not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
+
+ 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
+ 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'
- )
+ simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
+ returnSmpl (mkValLam binders' body', final_arity)
| otherwise -- Eta expansion possible
- = tick EtaExpansion `thenSmpl_`
+ = -- 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 PprDebug expr,
+ ppr PprDebug expr_ty,
+ ppr PprDebug binders,
+ int no_of_extra_binders,
+ ppr PprDebug potential_extra_binder_tys])
+ else \x -> x) $
+
+ 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' ->
+ 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
- (potential_extra_binder_tys, res_ty)
- = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
- -- Note: it's possible that simplLam will be applied to something
+ (binders,body) = collectValBinders expr
+ no_of_binders = length binders
+ (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
+ potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
+ pprTrace "simplValLam" (vcat [ppr PprDebug expr,
+ ppr PprDebug expr_ty,
+ ppr PprDebug 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
+ -- 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,
case potential_extra_binder_tys of
[ty] | ty `eqTy` realWorldStateTy -> 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
- 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
\end{code}
%************************************************************************
%* *
-\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
+
+ let x* = e in b
+to
+ case e of x -> b
+
+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.
+
+If x is a single-constructor type, then we go ahead anyway, giving
+
+ case e of (y,z) -> let x = (y,z) in b
+
+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.
+
+
+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
+
+(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:
-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.
+ 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 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.)
+
+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:
+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).
- -}
+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
-
- | otherwise
- = done_float env rhs body_c
- 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
+\begin{code}
+-- Dead code is now discarded by the occurrence analyser,
- -------------------------------------------
- done_float env rhs body_c
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeLet env binder rhs' body_c body_ty
+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)
- ---------------------------------------
- try_float env (Let bind rhs) body_c
+ | idWantsToBeINLINEd id
+ = complete_bind env rhs -- Don't mess about with floating or let-to-case on
+ -- INLINE things
+ | otherwise
+ = simpl_bind env rhs
+ where
+ -- Try let-to-case; see notes below about let-to-case
+ simpl_bind env rhs | try_let_to_case &&
+ will_be_demanded &&
+ (rhs_is_bot ||
+ not rhs_is_whnf &&
+ singleConstructorType rhs_ty
+ -- Only do let-to-case 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!
+
+ -- 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 -> try_float env rhs body_c) body_ty
+ (\env -> simpl_bind env rhs) body_ty
- try_float env (Case scrut alts) body_c
- | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
+ -- 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_`
-- 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
+ 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_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
- (\env rhs -> try_float env rhs body_c')
- body_ty `thenSmpl` \ case_expr ->
-
+ simplCase env scrut alts case_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)
-
- try_float env other_rhs body_c = done_float env other_rhs body_c
-\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...
-
-Here we would like the single call to g to be inlined.
-
-We can spot this easily, because g will be tagged as having just one
-occurrence. The "inlineUnconditionally" predicate is just what we want.
-
-A worry: could this lead to non-termination? For example:
-
- letrec
- f = ...g...
- g = ...f...
- h = ...h...
- in
- ..h..
-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
+ = cloneId env binder `thenSmpl` \ new_id ->
+ simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env 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
- (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
-
- simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
-
- body_c new_env `thenSmpl` \ body' ->
-
- returnSmpl (Let binding body')
-
+ -- Right hand sides that are constructors
+ -- 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.
+completeNonRec env binder new_id new_rhs
+ | not (isExported new_id) -- Don't bother for exported things
+ -- because we won't be able to drop
+ -- its binding.
+ && maybeToBool maybe_atomic_rhs
+ = tick tick_type `thenSmpl_`
+ returnSmpl (extendIdEnvWithAtom env binder rhs_arg, [])
where
- ------------ Floating stuff -------------------
-
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
-
- 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
-
- is_inline_triple (_, ((_,occ_info),_))
- = inlineUnconditionally False {-not ok_to_dup-} occ_info
-
- -- 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 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).
-
- env_w_inlinings = foldl add_inline env inline_triples
-
- add_inline env (id', (binder,rhs))
- = extendIdEnvWithInlining env env_w_inlinings binder rhs
-
- -- 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
-
- 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' ->
-
- -- 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' ->
-
- -- Phew! We're done
- let
- binding = Rec (map snd early_triples' ++ map snd late_triples')
- in
- returnSmpl (binding, env_w_early_info)
+ Just (rhs_arg, tick_type) = maybe_atomic_rhs
+ maybe_atomic_rhs
+ = -- Try first for an existing constructor application
+ case maybe_con new_rhs of {
+ Just con -> Just (VarArg con, ConReused);
+
+ Nothing -> -- No good; try eta-reduction
+ case etaCoreExpr new_rhs of {
+ Var v -> Just (VarArg v, AtomicRhs);
+ Lit l -> Just (LitArg l, AtomicRhs);
+
+ other -> Nothing -- Neither worked, so return Nothing
+ }}
+
+
+ maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
+ = lookForConstructor env con con_args
+ maybe_con other_rhs = Nothing
+
+completeNonRec env binder@(id,occ_info) new_id new_rhs
+ = returnSmpl (new_env , [NonRec new_id new_rhs])
where
-
- do_one_binding env (id', (binder,rhs))
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- returnSmpl (binder, (id', rhs'))
+ new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
+ occ_info new_id new_rhs
\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.
-
-\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
- 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' ->
+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
- env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
+ atomic_rhs = case runEager $ lookupId env1 inner_id of
+ LitArg l -> Lit l
+ VarArg v -> Var v
in
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec id' new_rhs) body')
-\end{code}
+ completeNonRec env1 binder new_id
+ (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
+
+ returnSmpl (env2, binds1 ++ binds2)
+\end{pseudocode}
+----------------------------------------------------------------------------
+
+
%************************************************************************
%* *
-\subsection[Simplify-atoms]{Simplifying atoms}
+\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}
-simplArg :: SimplEnv -> InArg -> OutArg
+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
+ cloneIds env binders `thenSmpl` \ ids' ->
+ let
+ env_w_clones = extendIdEnvWithClones env binders ids'
+ in
+ simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
+
+ body_c new_env `thenSmpl` \ body' ->
-simplArg env (LitArg lit) = LitArg lit
-simplArg env (TyArg ty) = TyArg (simplTy env ty)
+ returnSmpl (Let (Rec pairs') body')
+\end{code}
-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
+\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
- = -- Not locally defined, so no change
- VarArg id
+ = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
+ let
+ new_id' = new_id `withArity` arity
+
+ -- ToDo: this next bit could usefully share code with completeNonRec
+
+ new_env
+ | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = env
+
+ | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
+ = extendIdEnvWithAtom env binder the_arg
+
+ | otherwise -- Non-atomic
+ = extendEnvGivenBinding env occ_info new_id new_rhs
+ -- Don't eta if it doesn't eliminate the binding
+
+ eta'd_rhs = etaCoreExpr new_rhs
+ the_arg = case eta'd_rhs of
+ Var v -> VarArg v
+ Lit l -> LitArg l
+ in
+ simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
+ returnSmpl ((new_id', new_rhs) : 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', _, n_extras) = fltBind 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 (un_demandify bndr) rhs'],
+ leakFree bndr rhs',
+ length binds)
+ where
+ (binds, rhs') = fltRhs rhs
+
+ fltBind (Rec pairs)
+ = ([Rec (extras
+ ++
+ binders `zip` rhss')],
+ and (zipWith leakFree binders rhss'),
+ length extras
+ )
+
+ where
+ (binders, rhss) = unzip pairs
+ (binds_s, rhss') = mapAndUnzip fltRhs rhss
+ extras = concat (map get_pairs (concat binds_s))
+
+ get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
+ get_pairs (Rec pairs) = pairs
+
+ -- 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
+ (body_binds, body') = fltExpr body
+ (binds', binds_wont_leak, _) = fltBind bind
+
+ fltExpr expr = ([], expr)
+
+-- Crude but effective
+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}
-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
+simplArg :: SimplEnv -> InArg -> Eager ans OutArg
+
+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}
%************************************************************************
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)
+un_demandify (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 (getFunTy_maybe ty) of
+ Just (_, res_ty) -> go res_ty args
+ Nothing ->
+ pprPanic "computeResultType" (vcat [
+ ppr PprDebug (a:args),
+ ppr PprDebug orig_args,
+ ppr PprDebug expr_ty',
+ ppr PprDebug 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}
projects / ghc-hetmet.git / blobdiff