import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
unTagBinders, squashableDictishCcExpr
)
-import Id ( idType, idWantsToBeINLINEd,
+import Id ( idType, idWantsToBeINLINEd, addIdArity,
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 Name ( isExported )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import Pretty ( ppAbove )
splitFunTy, getFunTy_maybe, eqTy
)
import TysWiredIn ( realWorldStateTy )
-import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
+import Util ( isSingleton, zipEqual, zipWithEqual, panic, pprPanic, assertPanic )
\end{code}
The controlling flags, and what they do
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 True env binder rhs' `thenSmpl` \ (new_env, binds1') ->
+ simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds2' ->
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
-
- do_tylambdas env tyvars' body
- = simplExpr env body [] `thenSmpl` \ body' ->
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) (reverse tyvars') body'
- )
+ = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
+ let
+ new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
+ in
+ simplExpr new_env body [] `thenSmpl` \ body' ->
+ returnSmpl (Lam (TyBinder tyvar') body')
#ifdef DEBUG
simplExpr env (Lam (TyBinder _) _) (_ : _)
new_env = markDangerousOccs env (take n orig_args)
in
simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
+ `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
:: SimplEnv
-> InBinder
-> InExpr
- -> SmplM OutExpr
+ -> SmplM (OutExpr, ArityInfo)
simplRhsExpr env binder@(id,occ_info) rhs
- | dont_eta_expand rhs
- = simplExpr rhs_env rhs []
-
- | otherwise -- Have a go at eta expansion
= -- Deal with the big lambda part
ASSERT( null uvars ) -- For now
-- 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) `thenSmpl` \ (lambda', arity) ->
-- Put it back together
- returnSmpl (
- (if switchIsSet env SimplDoEtaReduction
- then mkTyLamTryingEta
- else mkTyLam) tyvars' lambda'
- )
+ returnSmpl (mkTyLam tyvars' lambda', arity)
where
- rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
+ rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) &&
+ -- No! Don't ever inline in a INLINE thing's rhs, because
+ -- doing so will inline a worker straight back into its wrapper!
idWantsToBeINLINEd id
= switchOffInlining env
| otherwise
-- 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
\end{code}
\begin{code}
simplValLam env expr min_no_of_args
| not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
- null binders || -- or it's a thunk
+
+-- We used to disable eta expansion for thunks, but I don't see why.
+-- null binders || -- or it's a thunk
+
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' ->
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'
- )
+ returnSmpl (mkValLam binders' body', atLeastArity no_of_binders)
| otherwise -- Eta expansion possible
= tick EtaExpansion `thenSmpl_`
newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
returnSmpl (
- (if switchIsSet new_env SimplDoEtaReduction
- then mkValLamTryingEta
- else mkValLam) (binders' ++ extra_binders') body'
+ mkValLam (binders' ++ extra_binders') body',
+ atLeastArity (no_of_binders + no_of_extra_binders)
)
where
(binders,body) = collectValBinders expr
+ no_of_binders = length binders
(potential_extra_binder_tys, res_ty)
= splitFunTy (simplTy env (coreExprType (unTagBinders body)))
-- Note: it's possible that simplValLam will be applied to something
extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
no_of_extra_binders = -- First, use the info about how many args it's
- -- always applied to in its scope
- (min_no_of_args - length binders)
+ -- always applied to in its scope; but ignore this
+ -- if it's a thunk! 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!
+ (if null binders
+ then 0
+ else min_no_of_args - no_of_binders)
-- Next, try seeing if there's a lambda hidden inside
-- something cheap
case potential_extra_binder_tys of
[ty] | ty `eqTy` realWorldStateTy -> 1
other -> 0
-
\end{code}
-- Dead code is now discarded by the occurrence analyser,
simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
+ | idWantsToBeINLINEd id
+ = complete_bind env rhs -- Don't messa bout 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 = complete_bind env rhs
complete_bind env rhs
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec False env binder rhs' `thenSmpl` \ (new_env, binds) ->
+ = simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
+ cloneId env binder `thenSmpl` \ new_id ->
+ completeNonRec env binder
+ (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
body_c new_env `thenSmpl` \ body' ->
returnSmpl (mkCoLetsAny binds body')
(pairs', body') = do_float body
do_float other = ([], other)
+
+-- The env passed to simplRecursiveGroup already has
+-- bindings that clone the variables of the group.
simplRecursiveGroup env new_ids pairs
= -- Add unfoldings to the new_ids corresponding to their RHS
let
env new_ids_w_pairs
in
- mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
+ mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss_w_arities ->
let
- new_pairs = zipEqual "simplRecGp" new_ids new_rhss
+ new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities
+ mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs)
+ -- NB: the new arity isn't used when processing its own
+ -- right hand sides, nor in the subsequent code
+ -- The latter is something of a pity, and not hard to fix; but
+ -- the info will percolate on the next iteration anyway
+
+{- THE NEXT FEW LINES ARE PLAIN WRONG
occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
new_env = foldl add_binding env occs_w_new_pairs
add_binding env (occ_info,(new_id,new_rhs))
= extendEnvGivenBinding env occ_info new_id new_rhs
+
+Here's why it's wrong: consider
+ let f x = ...f x'...
+ in
+ f 3
+
+If the RHS is small we'll inline f in the body of the let, then
+again, then again...URK
+-}
in
- returnSmpl (Rec new_pairs, new_env)
+ returnSmpl (Rec new_pairs, rhs_env)
\end{code}
\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 top_level 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 top_level 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 top_level env binder@(id,_) new_rhs
- -- See if RHS is an atom, or a reusable constructor
- | maybeToBool maybe_atomic_rhs
- = let
- new_env = extendIdEnvWithAtom env binder rhs_atom
- result_binds | top_level = [NonRec id new_rhs] -- Don't discard top-level bindings
- -- (they'll be dropped later if not
- -- exported and dead)
- | otherwise = []
- in
- tick atom_tick_type `thenSmpl_`
- returnSmpl (new_env, result_binds)
- where
- maybe_atomic_rhs = exprToAtom env new_rhs
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
-completeNonRec top_level env binder@(old_id,occ_info) new_rhs
- = (if top_level then
- returnSmpl old_id -- Only clone local binders
- else
- cloneId env binder
- ) `thenSmpl` \ new_id ->
+ -- 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 new_id
- new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
+ atomic_rhs = case lookupId env1 inner_id of
+ LitArg l -> Lit l
+ VarArg v -> Var v
in
- returnSmpl (new_env, [NonRec new_id new_rhs])
+ completeNonRec env1 binder new_id
+ (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
+ = returnSmpl (new_env , [NonRec new_id new_rhs])
+ where
+ new_env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
+ = extendIdEnvWithAtom env binder the_arg
+
+ | otherwise -- Non-atomic
+ = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
+ 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
\end{code}
%************************************************************************
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}
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
go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
Just (_, res_ty) -> go res_ty args
Nothing -> panic "computeResultType"
+
+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