X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=91e1c779cf749304856962c93d6da1acec97e495;hb=afc7564e0bcd27ff98775648bb2308b25710d20f;hp=5f00a8e9e7c939dac3d22317591fb1f8890f9ac9;hpb=12899612693163154531da3285ec99c1c8ca2226;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 5f00a8e..91e1c77 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,41 +8,55 @@ 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 -IMPORT_1_3(List(partition)) +#endif import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, FormSummary(..) ) -import CostCentre ( isSccCountCostCentre, cmpCostCentre ) +import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, + exprIsTrivial, whnfOrBottom, inlineUnconditionally, + FormSummary(..) + ) +import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre ) import CoreSyn import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) -import Id ( idType, idWantsToBeINLINEd, +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 @@ -178,40 +192,51 @@ mutually-recursive worker/wrapper split. At the top level things are a little different. * No cloning (not allowed for exported Ids, unnecessary for the others) - - * No floating. Case floating is obviously out. Let floating is - theoretically OK, but dangerous because of space leaks. - The long-distance let-floater lifts these lets. + * Floating is done a bit differently (no case floating; check for leaks; handle letrec) \begin{code} simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding] -simplTopBinds env [] = returnSmpl [] - -- Dead code is now discarded by the occurrence analyser, -simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds) - = -- No cloning necessary at top level - -- Process the binding - simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> - completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds1') -> - - -- Process the other bindings - simplTopBinds new_env binds `thenSmpl` \ binds2' -> - - -- Glue together and return ... - returnSmpl (binds1' ++ binds2') - -simplTopBinds env (Rec pairs : binds) - = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) -> - - -- Process the other bindings - simplTopBinds new_env binds `thenSmpl` \ binds' -> - - -- Glue together and return - returnSmpl (bind' : binds') +simplTopBinds env binds + = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s -> + simpl_top_binds env (concat binds_s) where - ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level + simpl_top_binds env [] = returnSmpl [] + + simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds) + = --- No cloning necessary at top level + 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} %************************************************************************ @@ -224,6 +249,7 @@ simplTopBinds env (Rec pairs : binds) \begin{code} simplExpr :: SimplEnv -> InExpr -> [OutArg] + -> OutType -- Type of (e args); i.e. type of overall result -> SmplM OutExpr \end{code} @@ -237,14 +263,14 @@ Check if there's a macro-expansion, and if so rattle on. Otherwise do the more sophisticated stuff. \begin{code} -simplExpr env (Var v) args - = case (lookupId env v) of +simplExpr env (Var v) args result_ty + = case (runEager $ lookupId env v) of LitArg lit -- A boring old literal -> ASSERT( null args ) returnSmpl (Lit lit) VarArg var -- More interesting! An id! - -> completeVar env var args + -> completeVar env var args result_ty -- Either Id is in the local envt, or it's a global. -- In either case we don't need to apply the type -- environment to it. @@ -254,9 +280,9 @@ 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} @@ -267,24 +293,20 @@ NB: Prim expects an empty argument list! (Because it should be 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 @@ -293,9 +315,10 @@ Nothing to try here. We only reuse constructors when they appear as the 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} @@ -304,44 +327,36 @@ Applications are easy too: 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)) tick TyBetaReduction `thenSmpl_` - simplExpr (extendTyEnv env tyvar ty) body args - -simplExpr env tylam@(Lam (TyBinder tyvar) body) [] - = do_tylambdas env [] tylam - where - do_tylambdas env tyvars' (Lam (TyBinder tyvar) body) - = -- Clone the type variable - cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> - let - new_env = extendTyEnv env tyvar (mkTyVarTy tyvar') - in - do_tylambdas new_env (tyvar':tyvars') body + simplExpr (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} @@ -362,7 +377,7 @@ 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 +simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty = go 0 env expr orig_args where go n env (Lam (ValBinder binder) body) (val_arg : args) @@ -377,10 +392,12 @@ simplExpr env expr@(Lam (ValBinder binder) body) orig_args let new_env = markDangerousOccs env (take n orig_args) in - simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} + simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty + `thenSmpl` \ (expr', arity) -> + returnSmpl expr' go n env non_val_lam_expr args -- The lambda had enough arguments - = simplExpr env non_val_lam_expr args + = simplExpr env non_val_lam_expr args result_ty \end{code} @@ -388,26 +405,24 @@ Let expressions ~~~~~~~~~~~~~~~ \begin{code} -simplExpr env (Let bind body) args - = simplBind env bind (\env -> simplExpr env body args) - (computeResultType env body args) +simplExpr env (Let bind body) args result_ty + = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty \end{code} Case expressions ~~~~~~~~~~~~~~~~ \begin{code} -simplExpr env expr@(Case scrut alts) args - = simplCase env scrut alts (\env rhs -> simplExpr env rhs args) - (computeResultType env expr args) +simplExpr env expr@(Case scrut alts) args result_ty + = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty \end{code} Coercions ~~~~~~~~~ \begin{code} -simplExpr env (Coerce coercion ty body) args - = simplCoerce env coercion ty body args +simplExpr env (Coerce coercion ty body) args result_ty + = simplCoerce env coercion ty body args result_ty \end{code} @@ -418,36 +433,36 @@ Set-cost-centre We must be careful to maintain the scc counts ... \begin{code} -simplExpr env (SCC cc1 (SCC cc2 expr)) 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 + = simplExpr env (SCC cc1 expr) args result_ty | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1) -- eliminate outer scc if no call counts associated with either ccs - = simplExpr env (SCC cc2 expr) args + = simplExpr env (SCC cc2 expr) args result_ty \end{code} 2) Moving sccs inside lambdas ... \begin{code} -simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args +simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty | not (isSccCountCostCentre cc) -- move scc inside lambda only if no call counts - = simplExpr env (Lam binder (SCC cc body)) args + = simplExpr env (Lam binder (SCC cc body)) args result_ty -simplExpr env (SCC cc (Lam binder body)) args +simplExpr env (SCC cc (Lam binder body)) args result_ty -- always ok to move scc inside type/usage lambda - = simplExpr env (Lam binder (SCC cc body)) args + = simplExpr env (Lam binder (SCC cc body)) args result_ty \end{code} 3) Eliminating dict sccs ... \begin{code} -simplExpr env (SCC cc expr) args +simplExpr env (SCC cc expr) args result_ty | squashableDictishCcExpr cc expr -- eliminate dict cc if trivial dict expression - = simplExpr env expr args + = simplExpr env expr args result_ty \end{code} 4) Moving arguments inside the body of an scc ... @@ -455,11 +470,11 @@ 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 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} @@ -486,86 +501,128 @@ simplRhsExpr :: 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. - simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' -> + simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) -> - -- Put it back together - returnSmpl ( - (if switchIsSet env SimplDoEtaReduction - then mkTyLamTryingEta - else mkTyLam) tyvars' lambda' - ) - where + -- Put on the big lambdas, trying to float out any bindings caught inside + mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' -> - rhs_env | not (switchIsSet env IgnoreINLINEPragma) && - idWantsToBeINLINEd id - = switchOffInlining env + returnSmpl (rhs', arity) + where + rhs_ty = idType new_id + rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs + = switchOffInlining env1 -- See comments with switchOffInlining | otherwise - = env + = env1 - -- Switch off all inlining in the RHS of things that have an INLINE pragma. - -- They are going to be inlined wherever they are used, and then all the - -- inlining will take effect. Meanwhile, there isn't - -- much point in doing anything to the as-yet-un-INLINEd rhs. - -- It's very important to switch off inlining! Consider: - -- - -- let f = \pq -> BIG - -- in - -- let g = \y -> f y y - -- {-# INLINE g #-} - -- in ...g...g...g...g...g... - -- - -- Now, if that's the ONLY occurrence of f, it will be inlined inside g, - -- and thence copied multiple times when g is inlined. + -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC + -- for the rhs of top level defs is "OST_CENTRE". Consider + -- f = \x -> e + -- g = \y -> let v = f y in scc "x" (v ...) + -- Here we want to inline "f", since its CC is SUBSUMED, but we don't + -- want to inline "v" since its CC is dynamically determined. - -- Andy disagrees! Example: - -- all xs = foldr (&&) True xs - -- any p = all . map p {-# INLINE any #-} - -- - -- Problem: any won't get deforested, and so if it's exported and - -- the importer doesn't use the inlining, (eg passes it as an arg) - -- then we won't get deforestation at all. - -- We havn't solved this problem yet! + current_cc = getEnclosingCC env + env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre + | otherwise = env (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} +---------------------------------------------------------------- + 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} @@ -576,56 +633,87 @@ Simplify (\binders -> body) trying eta expansion and reduction, given that the abstraction will always be applied to at least min_no_of_args. \begin{code} -simplValLam env expr min_no_of_args +simplValLam env expr min_no_of_args expr_ty | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off - null binders || -- or it's a thunk + + exprIsTrivial expr || -- or it's a trivial RHS + -- No eta expansion for trivial RHSs + -- It's rather a Bad Thing to expand + -- g = f alpha beta + -- to + -- g = \a b c -> f alpha beta a b c + -- + -- The original RHS is "trivial" (exprIsTrivial), because it generates + -- no code (renames f to g). But the new RHS isn't. + null potential_extra_binder_tys || -- or ain't a function no_of_extra_binders <= 0 -- or no extra binders needed = cloneIds env binders `thenSmpl` \ binders' -> let new_env = extendIdEnvWithClones env binders binders' in - simplExpr new_env body [] `thenSmpl` \ body' -> - returnSmpl ( - (if switchIsSet new_env SimplDoEtaReduction - then mkValLamTryingEta - else mkValLam) binders' body' - ) + 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 - (binders,body) = collectValBinders expr - (potential_extra_binder_tys, res_ty) - = splitFunTy (simplTy env (coreExprType (unTagBinders body))) + (binders,body) = collectValBinders expr + no_of_binders = length binders + (arg_tys, res_ty) = 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 - length binders) + -- always applied to in its scope; but ignore this + -- info for thunks. To see why we ignore it for thunks, + -- consider let f = lookup env key in (f 1, f 2) + -- We'd better not eta expand f just because it is + -- always applied! + (min_no_of_args - no_of_binders) -- Next, try seeing if there's a lambda hidden inside - -- something cheap + -- something cheap. + -- etaExpandCount can reuturn a huge number (like 10000!) if + -- it finds that the body is a call to "error"; hence + -- the use of "min" here. `max` - etaExpandCount body + (etaExpandCount body `min` length potential_extra_binder_tys) -- Finally, see if it's a state transformer, in which -- case we eta-expand on principle! This can waste work, @@ -634,7 +722,6 @@ simplValLam env expr min_no_of_args case potential_extra_binder_tys of [ty] | ty `eqTy` realWorldStateTy -> 1 other -> 0 - \end{code} @@ -647,20 +734,21 @@ simplValLam env expr min_no_of_args \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 @@ -671,7 +759,7 @@ simplCoerce env coercion ty expr args %************************************************************************ %* * -\subsection[Simplify-let]{Let-expressions} +\subsection[Simplify-bind]{Binding groups} %* * %************************************************************************ @@ -681,8 +769,35 @@ simplBind :: SimplEnv -> (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 @@ -722,78 +837,36 @@ achieving the same effect. ToDo: check this is OK with andy +Let to case: two points +~~~~~~~~~~~ -\begin{code} --- Dead code is now discarded by the occurrence analyser, - -simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty - = simpl_bind env rhs - where - -- Try let-to-case; see notes below about let-to-case - simpl_bind env rhs | will_be_demanded && - try_let_to_case && - type_ok_for_let_to_case rhs_ty && - rhs_is_whnf -- note: WHNF, but not bottom, (comment below) - = tick Let2Case `thenSmpl_` - mkIdentityAlts rhs_ty `thenSmpl` \ id_alts -> - simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty - - -- Try let-from-let - simpl_bind env (Let bind rhs) | let_floating_ok - = tick LetFloatFromLet `thenSmpl_` - simplBind env (fix_up_demandedness will_be_demanded bind) - (\env -> simpl_bind env rhs) body_ty - - -- Try case-from-let; this deals with a strict let of error too - simpl_bind env (Case scrut alts) | will_be_demanded || - (float_primops && is_cheap_prim_app scrut) - = tick CaseFloatFromLet `thenSmpl_` +Point 1. We defer let-to-case for all data types except single-constructor +ones. Suppose we change - -- First, bind large let-body if necessary - if ok_to_dup || isSingleton (nonErrorRHSs alts) - then - simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty - else - bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> - let - body_c' = \env -> simplExpr env new_body [] - case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty - in - simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr -> - returnSmpl (Let extra_binding case_expr) + let x* = e in b +to + case e of x -> b - -- None of the above; simplify rhs and tidy up - simpl_bind env rhs - = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> - completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds) -> - body_c new_env `thenSmpl` \ body' -> - returnSmpl (mkCoLetsAny binds body') +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 - -- 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 + case e of (y,z) -> let x = (y,z) in b - will_be_demanded = willBeDemanded (getIdDemandInfo id) - rhs_ty = idType id +because now we can squash case-on-x wherever they occur in b. - rhs_is_whnf = case mkFormSummary rhs of - VarForm -> True - ValueForm -> True - other -> False +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. - let_floating_ok = (will_be_demanded && not no_float) || - always_float_let_from_let || - floatExposesHNF float_lets float_primops ok_to_dup rhs -\end{code} -Let to case -~~~~~~~~~~~ -It's important to try let-to-case before floating. Consider +Point 2. It's important to try let-to-case before doing the +strict-let-of-case transformation, which happens in the next equation +for simpl_bind. let a*::Int = case v of {p1->e1; p2->e2} in b @@ -814,7 +887,7 @@ Now watch what happens if we do let-to-case first: let k = \a# -> let a*=I# a# in b in case v of p1 -> case e1 of I# a# -> k a# - p1 -> case e1 of I# a# -> k a# + p1 -> case e2 of I# a# -> k a# The latter is clearly better. (Remember the reboxing let-decl for a is likely to go away, because after all b is strict in a.) @@ -838,179 +911,179 @@ Notice that let to case occurs only if x is used strictly in its body (obviously). -Letrec expressions -~~~~~~~~~~~~~~~~~~ - -Simplify each RHS, float any let(recs) from the RHSs (if let-floating is -on and it'll expose a HNF), and bang the whole resulting mess together -into a huge letrec. - -1. Any "macros" should be expanded. The main application of this -macro-expansion is: +\begin{code} +-- Dead code is now discarded by the occurrence analyser, - letrec - f = ....g... - g = ....f... - in - ....f... +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) -Here we would like the single call to g to be inlined. + | 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! -We can spot this easily, because g will be tagged as having just one -occurrence. The "inlineUnconditionally" predicate is just what we want. + -- Try let-from-let + simpl_bind env (Let bind rhs) | let_floating_ok + = tick LetFloatFromLet `thenSmpl_` + simplBind env (fix_up_demandedness will_be_demanded bind) + (\env -> simpl_bind env rhs) body_ty -A worry: could this lead to non-termination? For example: + -- Try case-from-let; this deals with a strict let of error too + simpl_bind env (Case scrut alts) | case_floating_ok scrut + = tick CaseFloatFromLet `thenSmpl_` - letrec - f = ...g... - g = ...f... - h = ...h... - in - ..h.. + -- First, bind large let-body if necessary + if ok_to_dup || isSingleton (nonErrorRHSs alts) + then + simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty + else + bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> + let + body_c' = \env -> simplExpr env new_body [] body_ty + case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty + in + simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr -> + returnSmpl (Let extra_binding case_expr) -Here, f and g call each other (just once) and neither is used elsewhere. -But it's OK: + -- None of the above; simplify rhs and tidy up + simpl_bind env rhs = complete_bind env rhs + + complete_bind env rhs + = 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 - let - floated_pairs | do_floating = float_pairs pairs - | otherwise = pairs - - ticks | do_floating = length floated_pairs - length pairs - | otherwise = 0 - - binders = map fst floated_pairs - in - tickN LetFloatFromLet ticks `thenSmpl_` - -- It's important to increment the tick counts if we - -- do any floating. A situation where this turns out - -- to be important is this: - -- Float in produces: - -- letrec x = let y = Ey in Ex - -- in B - -- Now floating gives this: - -- letrec x = Ex - -- y = Ey - -- in B - --- We now want to iterate once more in case Ey doesn't - -- mention x, in which case the y binding can be pulled - -- out as an enclosing let(rec), which in turn gives - -- the strictness analyser more chance. - - cloneIds env binders `thenSmpl` \ ids' -> - let - env_w_clones = extendIdEnvWithClones env binders ids' - in - simplRecursiveGroup env ids' floated_pairs `thenSmpl` \ (binding, new_env) -> - - 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 - do_floating = float_lets || always_float_let_from_let - - float_pairs pairs = concat (map float_pair pairs) - - float_pair (binder, rhs) - | always_float_let_from_let || - floatExposesHNF True False False rhs - = (binder,rhs') : pairs' - - | otherwise - = [(binder,rhs)] - where - (pairs', rhs') = do_float rhs - - -- Float just pulls out any top-level let(rec) bindings - do_float :: InExpr -> ([(InBinder,InExpr)], InExpr) - do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body') - where - (pairs', body') = do_float body - do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body') - where - (pairs', body') = do_float body - do_float other = ([], other) - -simplRecursiveGroup env new_ids pairs - = -- Add unfoldings to the new_ids corresponding to their RHS - let - occs = [occ | ((_,occ), _) <- pairs] - new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs - rhs_env = foldl extendEnvForRecBinding - env new_ids_w_pairs - in + 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 + }} + - mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss -> + maybe_con (Con con con_args) | switchIsSet env SimplReuseCon + = lookForConstructor env con con_args + maybe_con other_rhs = Nothing - let - new_pairs = zipEqual "simplRecGp" new_ids new_rhss - occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs - new_env = foldl (\env (occ_info,(new_id,new_rhs)) -> - extendEnvGivenBinding env occ_info new_id new_rhs) - env occs_w_new_pairs - in - returnSmpl (Rec new_pairs, new_env) +completeNonRec env binder@(id,occ_info) new_id new_rhs + = returnSmpl (new_env , [NonRec new_id new_rhs]) + where + 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 @@ -1045,61 +1118,227 @@ variable) when we find a let-expression: ... (let y = C a1 .. an in ...) ... @ where it is always good to ditch the binding for y, and replace y by -x. That's just what completeLetBinding does. +x. + End of digression +---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- + A digression on "optimising" coercions + + The trouble is that we kept transforming + let x = coerce e + y = coerce x + in ... + to + let x' = coerce e + y' = coerce x' + in ... + and counting a couple of ticks for this non-transformation +\begin{pseudocode} + -- We want to ensure that all let-bound Coerces have + -- atomic bodies, so they can freely be inlined. +completeNonRec env binder new_id (Coerce coercion ty rhs) + | not (is_atomic rhs) + = newId (coreExprType rhs) `thenSmpl` \ inner_id -> + completeNonRec env + (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) -> + -- Dangerous occ because, like constructor args, + -- it can be duplicated easily + let + atomic_rhs = case runEager $ lookupId env1 inner_id of + LitArg l -> Lit l + VarArg v -> Var v + in + completeNonRec env1 binder new_id + (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> + + returnSmpl (env2, binds1 ++ binds2) +\end{pseudocode} +---------------------------------------------------------------------------- + + + +%************************************************************************ +%* * +\subsection[Simplify-letrec]{Letrec-expressions} +%* * +%************************************************************************ + +Letrec expressions +~~~~~~~~~~~~~~~~~~ +Here's the game plan + +1. Float any let(rec)s out of the RHSs +2. Clone all the Ids and extend the envt with these clones +3. Simplify one binding at a time, adding each binding to the + environment once it's done. + +This relies on the occurrence analyser to + a) break all cycles with an Id marked MustNotBeInlined + b) sort the decls into topological order +The former prevents infinite inlinings, and the latter means +that we get maximum benefit from working top to bottom. \begin{code} - -- Sigh: rather disgusting case for coercions. We want to - -- ensure that all let-bound Coerces have atomic bodies, so - -- they can freely be inlined. -completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs) - = (case rhs of - Var v -> returnSmpl (env, [], rhs) - Lit l -> returnSmpl (env, [], rhs) - other -> newId (coreExprType rhs) `thenSmpl` \ inner_id -> - completeNonRec env - (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) -> - -- Dangerous occ because, like constructor args, - -- it can be duplicated easily - let - atomic_rhs = case lookupId env1 inner_id of - LitArg l -> Lit l - VarArg v -> Var v - in - returnSmpl (env1, extra_bind, atomic_rhs) - ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) -> - -- Tiresome to do all this, but we must treat the lit/var cases specially - -- or we get a tick for atomic rhs when effectively it's a no-op. - - cloneId env1 binder `thenSmpl` \ new_id -> - let - new_rhs = Coerce coercion ty atomic_rhs - env2 = extendIdEnvWithClone env1 binder new_id - new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs - in - returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs]) - -completeNonRec env binder new_rhs - -- See if RHS is an atom, or a reusable constructor - | maybeToBool maybe_atomic_rhs - = let - new_env = extendIdEnvWithAtom env binder rhs_atom +simplRec env pairs body_c body_ty + = -- Do floating, if necessary + floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] -> + let + binders = map fst pairs' in - tick atom_tick_type `thenSmpl_` - returnSmpl (new_env, []) - where - maybe_atomic_rhs = exprToAtom env new_rhs - Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs + cloneIds env binders `thenSmpl` \ ids' -> + let + env_w_clones = extendIdEnvWithClones env binders ids' + in + simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) -> -completeNonRec env binder@(_,occ_info) new_rhs - = cloneId env binder `thenSmpl` \ new_id -> + body_c new_env `thenSmpl` \ body' -> + + returnSmpl (Let (Rec pairs') body') +\end{code} + +\begin{code} +-- The env passed to simplRecursiveGroup already has +-- bindings that clone the variables of the group. +simplRecursiveGroup env new_ids [] + = returnSmpl ([], env) + +simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs) + | inlineUnconditionally ok_to_dup id occ_info + = -- Single occurrence, so drop binding and extend env with the inlining + -- This is a little delicate, because what if the unique occurrence + -- is *before* this binding? This'll never happen, because + -- either it'll be marked "never inline" or else its occurrence will + -- occur after its binding in the group. + -- + -- If these claims aren't right Core Lint will spot an unbound + -- variable. A quick fix is to delete this clause for simplRecursiveGroup let - env1 = extendIdEnvWithClone env binder new_id - new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs + new_env = extendEnvGivenInlining env new_id occ_info rhs in - returnSmpl (new_env, [NonRec new_id new_rhs]) + simplRecursiveGroup new_env new_ids pairs + + | 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 + 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} @@ -1107,38 +1346,14 @@ completeNonRec env binder@(_,occ_info) new_rhs %************************************************************************ \begin{code} -simplArg :: SimplEnv -> InArg -> OutArg +simplArg :: SimplEnv -> InArg -> Eager ans OutArg -simplArg env (LitArg lit) = LitArg lit -simplArg env (TyArg ty) = TyArg (simplTy env ty) +simplArg env (LitArg lit) = returnEager (LitArg lit) +simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' -> + returnEager (TyArg ty') simplArg env (VarArg id) = lookupId env id \end{code} - -\begin{code} -exprToAtom env (Var var) - = Just (VarArg var, AtomicRhs) - -exprToAtom env (Lit lit) - | not (isNoRepLit lit) - = Just (LitArg lit, AtomicRhs) - -exprToAtom env (Con con con_args) - | switchIsSet env SimplReuseCon - -- Look out for - -- let v = C args - -- in - --- ...(let w = C same-args in ...)... - -- Then use v instead of w. This may save - -- re-constructing an existing constructor. - = case (lookForConstructor env con con_args) of - Nothing -> Nothing - Just var -> Just (VarArg var, ConReused) - -exprToAtom env other - = Nothing -\end{code} - %************************************************************************ %* * \subsection[Simplify-quickies]{Some local help functions} @@ -1156,22 +1371,34 @@ fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs) fix_up_demandedness False {- May not be demanded -} (Rec pairs) = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs] -un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info) +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}