X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=91e1c779cf749304856962c93d6da1acec97e495;hb=afc7564e0bcd27ff98775648bb2308b25710d20f;hp=75537f05dfb827da803b1febee686b192d5ce8ff;hpb=8f7ac3fe40d3d55743b824deab655d0797a1c55f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 75537f0..91e1c77 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,20 +8,27 @@ 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, addIdArity, +import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, + addIdArity, getIdArity, getIdDemandInfo, addIdDemandInfo, GenId{-instance NamedThing-} ) @@ -30,21 +37,26 @@ import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), atLeastArity, unknownArity ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) ---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, maybeAppDataTyCon, + splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy ) import TysWiredIn ( realWorldStateTy ) -import Util ( isSingleton, zipEqual, zipWithEqual, 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 @@ -180,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',arity) -> - completeNonRec env binder (in_id `withArity` arity) 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} %************************************************************************ @@ -226,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} @@ -239,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. @@ -256,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} @@ -269,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 @@ -295,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} @@ -306,33 +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 (extendTyEnv env tyvar ty) body args result_ty +\end{code} -simplExpr env tylam@(Lam (TyBinder tyvar) body) [] +\begin{code} +simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> let - new_env = extendTyEnv env tyvar (mkTyVarTy tyvar') + new_ty = mkTyVarTy tyvar' + new_env = extendTyEnv env tyvar new_ty + new_result_ty = applyTy result_ty new_ty in - simplExpr new_env body [] `thenSmpl` \ body' -> + 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} @@ -353,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) @@ -368,12 +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} @@ -381,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} @@ -411,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 ... @@ -448,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} @@ -479,61 +501,128 @@ simplRhsExpr :: SimplEnv -> InBinder -> InExpr + -> OutId -- The new binder (used only for its type) -> SmplM (OutExpr, ArityInfo) +\end{code} + -simplRhsExpr env binder@(id,occ_info) rhs +\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', arity) -> + simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) -> - -- Put it back together - returnSmpl (mkTyLam tyvars' lambda', arity) - 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) && - -- No! Don't ever inline in a INLINE thing's rhs, because - -- doing so will inline a worker straight back into its wrapper! - idWantsToBeINLINEd id - = switchOffInlining env + 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 \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} @@ -544,11 +633,18 @@ 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 --- We used to disable eta expansion for thunks, but I don't see why. --- 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 @@ -556,49 +652,68 @@ simplValLam env expr min_no_of_args let new_env = extendIdEnvWithClones env binders binders' in - simplExpr new_env body [] `thenSmpl` \ body' -> - returnSmpl (mkValLam binders' body', atLeastArity no_of_binders) + 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 ( mkValLam (binders' ++ extra_binders') body', - atLeastArity (no_of_binders + no_of_extra_binders) + final_arity ) where - (binders,body) = collectValBinders expr - no_of_binders = length binders - (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; but ignore this - -- if it's a thunk! To see why we ignore it for thunks, + -- 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! - (if null binders - then 0 - else min_no_of_args - no_of_binders) + (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, @@ -619,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 @@ -643,7 +759,7 @@ simplCoerce env coercion ty expr args %************************************************************************ %* * -\subsection[Simplify-let]{Let-expressions} +\subsection[Simplify-bind]{Binding groups} %* * %************************************************************************ @@ -653,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 @@ -694,25 +837,109 @@ achieving the same effect. ToDo: check this is OK with andy +Let to case: two points +~~~~~~~~~~~ + +Point 1. We defer let-to-case for all data types except single-constructor +ones. Suppose we change + + let x* = e in b +to + case e of x -> b + +It can be the case that we find that b ultimately contains ...(case x of ..).... +and this is the only occurrence of x. Then if we've done let-to-case +we can't inline x, which is a real pain. On the other hand, we lose no +transformations by not doing this transformation, because the relevant +case-of-X transformations are also implemented by simpl_bind. + +If x is a single-constructor type, then we go ahead anyway, giving + + case e of (y,z) -> let x = (y,z) in b + +because now we can squash case-on-x wherever they occur in b. + +We do let-to-case on multi-constructor types in the tidy-up phase +(tidyCoreExpr) mainly so that the code generator doesn't need to +spot the demand-flag. + + +Point 2. It's important to try let-to-case before doing the +strict-let-of-case transformation, which happens in the next equation +for simpl_bind. + + let a*::Int = case v of {p1->e1; p2->e2} + in b + +(The * means that a is sure to be demanded.) +If we do case-floating first we get this: + + let k = \a* -> b + in case v of + p1-> let a*=e1 in k a + p2-> let a*=e2 in k a + +Now watch what happens if we do let-to-case first: + + case (case v of {p1->e1; p2->e2}) of + Int a# -> let a*=I# a# in b +===> + let k = \a# -> let a*=I# a# in b + in case v of + p1 -> case e1 of I# a# -> k a# + p1 -> case e2 of I# a# -> k a# + +The latter is clearly better. (Remember the reboxing let-decl for a +is likely to go away, because after all b is strict in a.) + +We do not do let to case for WHNFs, e.g. + + let x = a:b in ... + =/=> + case a:b of x in ... + +as this is less efficient. but we don't mind doing let-to-case for +"bottom", as that will allow us to remove more dead code, if anything: + + let x = error in ... + ===> + case error of x -> ... + ===> + error + +Notice that let to case occurs only if x is used strictly in its body +(obviously). + \begin{code} -- Dead code is now discarded by the occurrence analyser, -simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty +simplNonRec env binder@(id,occ_info) rhs body_c body_ty + | inlineUnconditionally ok_to_dup id occ_info + = -- The binder is used in definitely-inline way in the body + -- So add it to the environment, drop the binding, and continue + body_c (extendEnvGivenInlining env id occ_info rhs) + | idWantsToBeINLINEd id - = complete_bind env rhs -- Don't messa bout with floating or let-to-case on + = 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 | will_be_demanded && - try_let_to_case && - type_ok_for_let_to_case rhs_ty && - not rhs_is_whnf -- note: WHNF, but not bottom, (comment below) + 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_` - mkIdentityAlts rhs_ty `thenSmpl` \ id_alts -> - simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty + 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 @@ -728,8 +955,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 @@ -739,8 +965,8 @@ 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 [] - case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty + 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) @@ -749,8 +975,8 @@ 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',arity) -> - cloneId env binder `thenSmpl` \ new_id -> + = 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' -> @@ -765,260 +991,99 @@ 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 -\end{code} - -Let to case -~~~~~~~~~~~ -It's important to try let-to-case before floating. Consider - - let a*::Int = case v of {p1->e1; p2->e2} - in b - -(The * means that a is sure to be demanded.) -If we do case-floating first we get this: - - let k = \a* -> b - in case v of - p1-> let a*=e1 in k a - p2-> let a*=e2 in k a - -Now watch what happens if we do let-to-case first: - - case (case v of {p1->e1; p2->e2}) of - Int a# -> let a*=I# a# in b -===> - let k = \a# -> let a*=I# a# in b - in case v of - p1 -> case e1 of I# a# -> k a# - p1 -> case e1 of I# a# -> k a# - -The latter is clearly better. (Remember the reboxing let-decl for a -is likely to go away, because after all b is strict in a.) - -We do not do let to case for WHNFs, e.g. - - let x = a:b in ... - =/=> - case a:b of x in ... - -as this is less efficient. but we don't mind doing let-to-case for -"bottom", as that will allow us to remove more dead code, if anything: - - let x = error in ... - ===> - case error of x -> ... - ===> - error - -Notice that let to case occurs only if x is used strictly in its body -(obviously). - - -Letrec expressions -~~~~~~~~~~~~~~~~~~ + float_exposes_hnf -Simplify each RHS, float any let(recs) from the RHSs (if let-floating is -on and it'll expose a HNF), and bang the whole resulting mess together -into a huge letrec. - -1. Any "macros" should be expanded. The main application of this -macro-expansion is: - - letrec - f = ....g... - g = ....f... - in - ....f... - -Here we would like the single call to g to be inlined. - -We can spot this easily, because g will be tagged as having just one -occurrence. The "inlineUnconditionally" predicate is just what we want. - -A worry: could this lead to non-termination? For example: - - letrec - f = ...g... - g = ...f... - h = ...h... - in - ..h.. - -Here, f and g call each other (just once) and neither is used elsewhere. -But it's OK: - -* 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. - -** IMPORTANT: check that NewOccAnal has the property that a group of - bindings like the above has f&g dropped.! *** - - -2. We'd also like to pull out any top-level let(rec)s from the -rhs of the defns: - - letrec - f = let h = ... in \x -> ....h...f...h... - in - ...f... -====> - letrec - h = ... - f = \x -> ....h...f...h... - in - ...f... - -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_w_clones 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) - - --- The env passed to simplRecursiveGroup already has --- bindings that clone the variables of the group. -simplRecursiveGroup env new_ids pairs - = -- Add unfoldings to the new_ids corresponding to their RHS - let - 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 - - mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss_w_arities -> - - let - new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities - mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs) - -- NB: the new arity isn't used when processing its own - -- right hand sides, nor in the subsequent code - -- The latter is something of a pity, and not hard to fix; but - -- the info will percolate on the next iteration anyway - -{- THE NEXT FEW LINES ARE PLAIN WRONG - occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs - new_env = foldl add_binding env occs_w_new_pairs - - add_binding env (occ_info,(new_id,new_rhs)) - = extendEnvGivenBinding env occ_info new_id new_rhs + 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 + }} + -Here's why it's wrong: consider - let f x = ...f x'... - in - f 3 + maybe_con (Con con con_args) | switchIsSet env SimplReuseCon + = lookForConstructor env con con_args + maybe_con other_rhs = Nothing -If the RHS is small we'll inline f in the body of the let, then -again, then again...URK --} - in - returnSmpl (Rec new_pairs, rhs_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 @@ -1053,10 +1118,23 @@ 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. - - -\begin{code} +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) @@ -1067,7 +1145,7 @@ completeNonRec env binder new_id (Coerce coercion ty rhs) -- Dangerous occ because, like constructor args, -- it can be duplicated easily let - atomic_rhs = case lookupId env1 inner_id of + atomic_rhs = case runEager $ lookupId env1 inner_id of LitArg l -> Lit l VarArg v -> Var v in @@ -1075,47 +1153,192 @@ completeNonRec env binder new_id (Coerce coercion ty rhs) (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> returnSmpl (env2, binds1 ++ binds2) - - -- Right hand sides that are constructors - -- let v = C args - -- in - --- ...(let w = C same-args in ...)... - -- Then use v instead of w. This may save - -- re-constructing an existing constructor. -completeNonRec env binder new_id rhs@(Con con con_args) - | switchIsSet env SimplReuseCon && - maybeToBool maybe_existing_con && - not (isExported new_id) -- Don't bother for exported things - -- because we won't be able to drop - -- its binding. - = tick ConReused `thenSmpl_` - returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs]) +\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} +simplRec env pairs body_c body_ty + = -- Do floating, if necessary + floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] -> + let + binders = map fst pairs' + in + cloneIds env binders `thenSmpl` \ ids' -> + let + env_w_clones = extendIdEnvWithClones env binders ids' + in + simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) -> + + body_c new_env `thenSmpl` \ body' -> + + 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 + new_env = extendEnvGivenInlining env new_id occ_info rhs + in + 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 - maybe_existing_con = lookForConstructor env con con_args - Just it = maybe_existing_con + ok_to_dup = switchIsSet env SimplOkToDupCode +\end{code} - -- Default case - -- Check for atomic right-hand sides. - -- We used to have a "tick AtomicRhs" in here, but it causes more trouble - -- than it's worth. For a top-level binding a = b, where a is exported, - -- we can't drop the binding, so we get repeated AtomicRhs ticks -completeNonRec env binder@(id,occ_info) new_id new_rhs - = returnSmpl (new_env , [NonRec new_id new_rhs]) - where - new_env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = extendIdEnvWithAtom env binder the_arg - | otherwise -- Non-atomic - = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id) - occ_info new_id new_rhs -- Don't eta if it doesn't eliminate the binding +\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 - eta'd_rhs = etaCoreExpr new_rhs - the_arg = case eta'd_rhs of - Var v -> VarArg v - Lit l -> LitArg l + -- 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} @@ -1123,10 +1346,11 @@ completeNonRec env binder@(id,occ_info) new_id 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} @@ -1152,18 +1376,23 @@ 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