\section[Simplify]{The main module of the simplifier}
\begin{code}
-#include "HsVersions.h"
-
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-IMPORT_1_3(List(partition))
-
-IMP_Ubiq(){-uitous-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(SmplLoop) -- paranoia checking
-#endif
+#include "HsVersions.h"
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, exprIsTrivial, whnfOrBottom, FormSummary(..) )
+import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
+ exprIsTrivial, whnfOrBottom, inlineUnconditionally,
+ FormSummary(..)
+ )
import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
import CoreSyn
import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
)
import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
addIdArity, getIdArity,
- getIdDemandInfo, addIdDemandInfo,
- GenId{-instance NamedThing-}
+ getIdDemandInfo, addIdDemandInfo
)
-import Name ( isExported )
+import Name ( isExported, isLocallyDefined )
import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
atLeastArity, unknownArity )
import Literal ( isNoRepLit )
import Maybes ( maybeToBool )
-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 SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
- splitFunTy, splitFunTyExpandingDicts, 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 Outputable ( PprStyle(..), Outputable(..) )
-import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
- isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
+import Outputable
\end{code}
The controlling flags, and what they do
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') ->
+ 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')
--
-- 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) ->
+ 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')
- where
- binders = map fst pairs
- ids = map fst binders
\end{code}
%************************************************************************
\begin{code}
simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
- = -- ASSERT(not (isPrimType ty))
- tick TyBetaReduction `thenSmpl_`
- simplExpr (extendTyEnv env tyvar ty) body args result_ty
+ = tick TyBetaReduction `thenSmpl_`
+ simplExpr (bindTyVar env tyvar ty) body args result_ty
\end{code}
\begin{code}
simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
- = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
+ = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') ->
let
- new_ty = mkTyVarTy tyvar'
- new_env = extendTyEnv env tyvar new_ty
- new_result_ty = applyTy result_ty new_ty
+ new_result_ty = applyTy result_ty (mkTyVarTy tyvar')
in
simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
returnSmpl (Lam (TyBinder tyvar') body')
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
\begin{code}
simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
+ | 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
-> SmplM (OutExpr, ArityInfo)
\end{code}
+
+\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
+ simplTyBinders env tyvars `thenSmpl` \ (lam_env, tyvars') ->
+ let
+ 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) body_ty `thenSmpl` \ (lambda', arity) ->
+
+ -- Put on the big lambdas, trying to float out any bindings caught inside
+ mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
+
+ 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
+ = 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
+
+ (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
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 (like strictness) that v doesn't.
+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.
But now using the reasoning of this little section,
y wasn't inlined, because it was a let x=y form.
-\begin{code}
+
+ 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)
|| case lookupOutIdEnv env v' of
Just (_, _, InUnfolding _ _) -> True
other -> False
-\end{code}
-
-\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
- 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.
- simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
-
- -- Put on the big lambdas, trying to float out any bindings caught inside
- mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
-
- 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
- = 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}
+\end{pseudocode}
+
+ End of old, nuked, special case.
+------------------------------------------------------------------
%************************************************************************
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 [] body_ty `thenSmpl` \ 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
= -- 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,
+ pprTrace "simplValLam" (vcat [ppr expr,
+ ppr expr_ty,
+ ppr binders,
int no_of_extra_binders,
- ppr PprDebug potential_extra_binder_tys])
+ ppr potential_extra_binder_tys])
else \x -> x) $
tick EtaExpansion `thenSmpl_`
- cloneIds env binders `thenSmpl` \ binders' ->
- let
- new_env = extendIdEnvWithClones env binders binders'
- in
+ 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 (
where
(binders,body) = collectValBinders expr
no_of_binders = length binders
- (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
+ (arg_tys, res_ty) = splitFunTys 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])
+ 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
-- but usually doesn't
`max`
case potential_extra_binder_tys of
- [ty] | ty `eqTy` realWorldStateTy -> 1
+ [ty] | ty == realWorldStatePrimTy -> 1
other -> 0
\end{code}
-- Dead code is now discarded by the occurrence analyser,
simplNonRec env binder@(id,occ_info) rhs body_c body_ty
- | inlineUnconditionally ok_to_dup occ_info
+ | 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
- | 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
+
+ -- 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:
-- 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 (fix_up_demandedness will_be_demanded bind)
+ simplBind env (if will_be_demanded then bind
+ else un_demandify_bind bind)
(\env -> simpl_bind env rhs) body_ty
-- Try case-from-let; this deals with a strict let of error too
simpl_bind env rhs = complete_bind env rhs
complete_bind env rhs
- = cloneId env binder `thenSmpl` \ new_id ->
+ = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env binder
+ completeNonRec env_w_clone binder
(new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
body_c new_env `thenSmpl` \ body' ->
returnSmpl (mkCoLetsAny binds body')
@completeNonRec@ 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
+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.
+
+There are two cases when we can do this:
+
+ * 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.]
+
+ * 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}
+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
+
+
+completeBind :: SimplEnv
+ -> InBinder -> OutId -> OutExpr -- Id and RHS
+ -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
+
+completeBind env binder@(_,occ_info) new_id new_rhs
+ | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = (env, new_binds)
+
+ | atomic_rhs -- If rhs (after eta reduction) is atomic
+ && not (isExported new_id) -- and binder isn't exported
+ = -- Drop the binding completely
+ let
+ env1 = notInScope env new_id
+ env2 = bindIdToAtom env1 binder the_arg
+ in
+ (env2, [])
+
+ | 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)])
+
+ | 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
+
+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
-\begin{code}
-{- FAILED CODE
- The trouble is that we keep transforming
+ The trouble is that we kept transforming
let x = coerce e
y = coerce x
in ...
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)
(Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
returnSmpl (env2, binds1 ++ binds2)
--}
-
-
- -- 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 rhs@(Con con con_args)
- | switchIsSet env SimplReuseCon &&
- maybeToBool maybe_existing_con &&
- not (isExported new_id) -- Don't bother for exported things
- -- because we won't be able to drop
- -- its binding.
- = tick ConReused `thenSmpl_`
- returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
- where
- maybe_existing_con = lookForConstructor env con con_args
- Just it = maybe_existing_con
-
-
- -- Default case
- -- Check for atomic right-hand sides.
- -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
- -- than it's worth. For a top-level binding a = b, where a is exported,
- -- we can't drop the binding, so we get repeated AtomicRhs ticks
-completeNonRec env binder@(id,occ_info) new_id new_rhs
- | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
- = returnSmpl (atomic_env , [NonRec new_id eta'd_rhs])
-
- | otherwise -- Non atomic rhs (don't eta after all)
- = returnSmpl (non_atomic_env , [NonRec new_id new_rhs])
- where
- atomic_env = extendIdEnvWithAtom env binder the_arg
+\end{pseudocode}
+----------------------------------------------------------------------------
- non_atomic_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
- occ_info new_id new_rhs
- eta'd_rhs = etaCoreExpr new_rhs
- the_arg = case eta'd_rhs of
- Var v -> VarArg v
- Lit l -> LitArg l
-\end{code}
%************************************************************************
%* *
let
binders = map fst pairs'
in
- cloneIds env binders `thenSmpl` \ ids' ->
- let
- env_w_clones = extendIdEnvWithClones env binders ids'
- in
+ simplBinders env binders `thenSmpl` \ (env_w_clones, ids') ->
simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
- body_c new_env `thenSmpl` \ body' ->
+ body_c new_env `thenSmpl` \ body' ->
returnSmpl (Let (Rec pairs') body')
\end{code}
simplRecursiveGroup env new_ids []
= returnSmpl ([], env)
-simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs)
- | inlineUnconditionally ok_to_dup occ_info
+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
| otherwise
= 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
+ new_id' = new_id `withArity` arity
+ (new_env, new_binds') = completeBind env binder new_id' new_rhs
in
simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
- returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
+ returnSmpl (new_binds' ++ new_pairs, final_env)
where
ok_to_dup = switchIsSet env SimplOkToDupCode
\end{code}
returnSmpl binds'
where
- (binds', _, n_extras) = fltBind bind
+ 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 (un_demandify bndr) rhs'],
- leakFree bndr rhs',
- length binds)
+ = binds ++ [NonRec bndr rhs']
where
(binds, rhs') = fltRhs rhs
fltBind (Rec pairs)
- = ([Rec (extras
- ++
- binders `zip` rhss')],
- and (zipWith leakFree binders rhss'),
- length extras
- )
-
+ = [Rec pairs']
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
+ 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
-- fltExpr guarantees not to return leaky floats
= (binds' ++ body_binds, body')
where
- (body_binds, body') = fltExpr body
- (binds', binds_wont_leak, _) = fltBind bind
+ 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 rhs
+ other -> whnfOrBottom (mkFormSummary rhs)
\end{code}
\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` noDemandInfo, 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
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
+ go ty (a:args) | isValArg a = case (splitFunTy_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])
+ ppr (a:args),
+ ppr orig_args,
+ ppr expr_ty',
+ ppr ty])
in
go expr_ty' orig_args
projects / ghc-hetmet.git / blobdiff