From: sof Date: Sun, 18 May 1997 23:24:40 +0000 (+0000) Subject: [project @ 1997-05-18 23:24:40 by sof] X-Git-Tag: Approximately_1000_patches_recorded~606 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d08b0747c9573fd2c3bd05c82430b02bf0bcfc5f;p=ghc-hetmet.git [project @ 1997-05-18 23:24:40 by sof] Force type substitutions;2.0x bootable --- diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 1be67d8..bbd0e94 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -15,13 +15,13 @@ 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, addIdArity, +import Id ( idType, idWantsToBeINLINEd, idMustNotBeINLINEd, addIdArity, getIdArity, getIdDemandInfo, addIdDemandInfo, GenId{-instance NamedThing-} ) @@ -32,19 +32,26 @@ 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, + splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy ) import TysWiredIn ( realWorldStateTy ) -import Util ( isSingleton, zipEqual, zipWithEqual, 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 @@ -180,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',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 +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} @@ -239,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. @@ -256,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} @@ -269,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 @@ -295,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} @@ -306,33 +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 (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 +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) @@ -368,12 +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} @@ -381,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} @@ -411,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 ... @@ -448,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} @@ -479,27 +496,50 @@ simplRhsExpr :: SimplEnv -> InBinder -> InExpr + -> OutId -- The new binder (used only for its type) -> SmplM (OutExpr, ArityInfo) -simplRhsExpr env binder@(id,occ_info) rhs +-- 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', 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 + 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 @@ -544,11 +584,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 +603,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 +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 @@ -705,13 +772,23 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty | 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: @@ -738,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 -> @@ -748,8 +825,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' -> @@ -764,10 +841,15 @@ 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 @@ -797,9 +879,36 @@ 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 +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 @@ -928,110 +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') - - 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) - + 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 pairs - = -- Add unfoldings to the new_ids corresponding to their RHS +simplRecursiveGroup env new_ids [] + = returnSmpl ([], env) + +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_w_arities -> + new_env + | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" + = env - 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 + | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic + = extendIdEnvWithAtom env binder the_arg -Here's why it's wrong: consider - let f x = ...f x'... - in - f 3 + | otherwise -- Non-atomic + = extendEnvGivenBinding env occ_info new_id new_rhs + -- Don't eta if it doesn't eliminate the binding -If the RHS is small we'll inline f in the body of the let, then -again, then again...URK --} + 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, rhs_env) + simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> + returnSmpl ((new_id', new_rhs) : new_pairs, final_env) \end{code} @@ -1086,7 +1137,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 @@ -1120,14 +1171,16 @@ completeNonRec env binder new_id rhs@(Con con con_args) -- 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]) + | 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 - new_env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = extendIdEnvWithAtom env binder the_arg + atomic_env = 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 + 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 @@ -1135,6 +1188,96 @@ completeNonRec env binder@(id,occ_info) new_id new_rhs 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} @@ -1142,10 +1285,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} @@ -1171,18 +1315,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