X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=bbd0e944c29b0a37f4c658b632fff4ad67730df4;hb=d08b0747c9573fd2c3bd05c82430b02bf0bcfc5f;hp=f1ac5d87f88b0eafc6a8ba394847f6d13a1ac065;hpb=f7ecf7234c224489be8a5e63fced903b655d92ee;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index f1ac5d8..bbd0e94 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -15,34 +15,43 @@ IMPORT_1_3(List(partition)) import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, FormSummary(..) ) +import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, exprIsTrivial, whnfOrBottom, FormSummary(..) ) import CostCentre ( isSccCountCostCentre, cmpCostCentre ) import CoreSyn import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) -import Id ( idType, idWantsToBeINLINEd, +import Id ( idType, 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 Name ( isExported ) 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, + splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy ) import TysWiredIn ( realWorldStateTy ) -import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic ) +import Outputable ( 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 +187,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 True 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 +244,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 +258,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 +275,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 +288,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 +310,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 +322,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 +372,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 +387,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 +400,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 +428,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 +465,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,34 +496,51 @@ simplRhsExpr :: SimplEnv -> InBinder -> InExpr - -> SmplM OutExpr - -simplRhsExpr env binder@(id,occ_info) rhs - | dont_eta_expand rhs - = simplExpr rhs_env rhs [] - - | otherwise -- Have a go at eta expansion + -> OutId -- The new binder (used only for its type) + -> SmplM (OutExpr, ArityInfo) + +-- 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 (like strictness) that v doesn't. + +simplRhsExpr env binder@(id,occ_info) (Var v) new_id + = case (runEager $ lookupId env v) of + LitArg lit -> returnSmpl (Lit lit, ArityExactly 0) + VarArg v' -> returnSmpl (Var v', getIdArity v') + +simplRhsExpr env binder@(id,occ_info) rhs new_id = -- 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')) + rhs_ty = idType new_id + 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) && + returnSmpl (rhs', arity) + where + rhs_env | -- 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 @@ -544,25 +571,6 @@ simplRhsExpr env binder@(id,occ_info) rhs -- 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} @@ -576,56 +584,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 +673,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 +685,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 @@ -727,15 +766,29 @@ ToDo: check this is OK with andy -- 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 mess about with floating or let-to-case on + -- INLINE things + | otherwise = simpl_bind env rhs where + -- Try for strict let of error + simpl_bind env rhs | will_be_demanded && maybeToBool maybe_error_app + = returnSmpl retyped_error_app + where + maybe_error_app = maybeErrorApp rhs (Just body_ty) + Just retyped_error_app = maybe_error_app + -- 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 && + 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. not rhs_is_whnf -- note: WHNF, but not bottom, (comment below) = tick Let2Case `thenSmpl_` - mkIdentityAlts rhs_ty `thenSmpl` \ id_alts -> + mkIdentityAlts rhs_ty demand_info `thenSmpl` \ id_alts -> simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty -- NB: it's tidier to call complete_bind not simpl_bind, else -- we nearly end up in a loop. Consider: @@ -752,8 +805,7 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty (\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) + simpl_bind env (Case scrut alts) | case_floating_ok scrut = tick CaseFloatFromLet `thenSmpl_` -- First, bind large let-body if necessary @@ -763,7 +815,7 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty else bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> let - body_c' = \env -> simplExpr env new_body [] + body_c' = \env -> simplExpr env new_body [] body_ty case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty in simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr -> @@ -773,8 +825,10 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty 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) -> + = 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') @@ -787,22 +841,74 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty try_let_to_case = switchIsSet env SimplLetToCase no_float = switchIsSet env SimplNoLetFromStrictLet - will_be_demanded = willBeDemanded (getIdDemandInfo id) + demand_info = getIdDemandInfo id + will_be_demanded = willBeDemanded demand_info rhs_ty = idType id - rhs_is_whnf = case mkFormSummary rhs of + 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 + float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs + let_floating_ok = (will_be_demanded && not no_float) || always_float_let_from_let || - floatExposesHNF float_lets float_primops ok_to_dup rhs + float_exposes_hnf + + 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} -Let to case +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 + +Let to case: two points ~~~~~~~~~~~ -It's important to try let-to-case before floating. Consider + +Point 1. We defer let-to-case for all data types except single-constructor +ones. Suppose we change + + let x* = e in b +to + case e of x -> b + +It can be the case that we find that b ultimately contains ...(case x of ..).... +and this is the only occurrence of x. Then if we've done let-to-case +we can't inline x, which is a real pain. On the other hand, we lose no +transformations by not doing this transformation, because the relevant +case-of-X transformations are also implemented by simpl_bind. + +If x is a single-constructor type, then we go ahead anyway, giving + + case e of (y,z) -> let x = (y,z) in b + +because now we can squash case-on-x wherever they occur in b. + +We do let-to-case on multi-constructor types in the tidy-up phase +(tidyCoreExpr) mainly so that the code generator doesn't need to +spot the demand-flag. + + +Point 2. It's important to try let-to-case before doing the +strict-let-of-case transformation, which happens in the next equation +for simpl_bind. let a*::Int = case v of {p1->e1; p2->e2} in b @@ -823,7 +929,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.) @@ -931,91 +1037,52 @@ How to do it? \begin{code} simplBind env (Rec pairs) body_c body_ty = -- Do floating, if necessary + floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] -> 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 + binders = map fst 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_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) -> + simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) -> body_c new_env `thenSmpl` \ body' -> - returnSmpl (Let binding body') + returnSmpl (Let (Rec pairs') body') +\end{code} - where - ------------ Floating stuff ------------------- +\begin{code} +-- The env passed to simplRecursiveGroup already has +-- bindings that clone the variables of the group. +simplRecursiveGroup env new_ids [] + = returnSmpl ([], env) - 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 +simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs) + = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) -> let - binders = map fst pairs - occs = map snd binders - new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs - rhs_env = foldl extendEnvForRecBinding - env new_ids_w_pairs - in + new_id' = new_id `withArity` arity + + -- ToDo: this next bit could usefully share code with completeNonRec - mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss -> + new_env + | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" + = env - let - new_pairs = zipEqual "simplRecGp" new_ids new_rhss - occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs - new_env = foldl add_binding env occs_w_new_pairs + | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic + = extendIdEnvWithAtom env binder the_arg - add_binding env (occ_info,(new_id,new_rhs)) + | 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 - returnSmpl (Rec new_pairs, new_env) + simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> + returnSmpl ((new_id', new_rhs) : new_pairs, final_env) \end{code} @@ -1060,65 +1127,157 @@ x. That's just what completeLetBinding does. \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 runEager $ 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 + | 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 + + 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} + + +\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 rhs \end{code} + %************************************************************************ %* * \subsection[Simplify-atoms]{Simplifying atoms} @@ -1126,38 +1285,14 @@ completeNonRec top_level env binder@(old_id,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} @@ -1175,22 +1310,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}