X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=eba387c909f410a979b4bac18f80e6b5d9b8c729;hb=132c92f70c00bb465cfd33178338287eb587a63c;hp=2e7b0837af40a2256b677c81126e684982aa97c5;hpb=996573cd62a9dab5b3a7f7ab85567507422601bb;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2e7b083..eba387c 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -11,7 +11,7 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, +import CoreUnfold ( Unfolding, mkFormSummary, noUnfolding, exprIsTrivial, whnfOrBottom, inlineUnconditionally, FormSummary(..) ) @@ -21,8 +21,8 @@ import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, - addIdArity, getIdArity, - getIdDemandInfo, addIdDemandInfo + addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation, + getIdDemandInfo, addIdDemandInfo, isSpecPragmaId ) import Name ( isExported, isLocallyDefined ) import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), @@ -35,6 +35,7 @@ import SimplEnv import SimplMonad import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders ) import SimplUtils +import SpecEnv ( isEmptySpecEnv, substSpecEnv ) import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys, mkFunTys, splitAlgTyConApp_maybe, splitFunTys, splitFunTy_maybe, isUnpointedType @@ -44,6 +45,7 @@ import Util ( Eager, appEager, returnEager, runEager, mapEager, isSingleton, zipEqual, zipWithEqual, mapAndUnzip ) import Outputable + \end{code} The controlling flags, and what they do @@ -194,11 +196,11 @@ simplTopBinds env binds simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds) = --- No cloning necessary at top level - simplBinder env binder `thenSmpl` \ (env1, out_id) -> - simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') -> - simpl_top_binds new_env binds `thenSmpl` \ binds2' -> - returnSmpl (binds1' ++ binds2') + simplBinder env binder `thenSmpl` \ (env1, out_id) -> + simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) -> + completeNonRec env1 binder (out_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 @@ -242,21 +244,10 @@ applied to the specified arguments. Variables ~~~~~~~~~ -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 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 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. +simplExpr env (Var var) args result_ty + = simplVar env False {- No InlineCall -} var args result_ty \end{code} Literals @@ -284,10 +275,10 @@ simplExpr env (Prim op prim_args) args result_ty where -- PrimOps just need any types in them renamed. - simpl_op (CCallOp label is_asm may_gc arg_tys result_ty) + simpl_op (CCallOp label is_asm may_gc cconv 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') + returnEager (CCallOp label is_asm may_gc cconv arg_tys' result_ty') simpl_op other_op = returnEager other_op \end{code} @@ -336,8 +327,8 @@ simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty returnSmpl (Lam (TyBinder tyvar') body') #ifdef DEBUG -simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty - = panic "simplExpr:TyLam with non-TyArg" +simplExpr env e@(Lam (TyBinder _) _) args@(_ : _) result_ty + = pprPanic "simplExpr:TyLam with non-TyArg" (ppr e $$ ppr args) #endif \end{code} @@ -370,7 +361,7 @@ simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty -- on the arguments we've already beta-reduced into the body of the lambda = ASSERT( null args ) -- Value lambda must match value argument! let - new_env = markDangerousOccs env (take n orig_args) + new_env = markDangerousOccs env orig_args in simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty `thenSmpl` \ (expr', arity) -> @@ -394,69 +385,39 @@ Case expressions \begin{code} simplExpr env expr@(Case scrut alts) args result_ty - = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty + = simplCase env scrut + (getSubstEnvs env, alts) + (\env rhs -> simplExpr env rhs args result_ty) + result_ty \end{code} Coercions ~~~~~~~~~ \begin{code} -simplExpr env (Coerce coercion ty body) args result_ty - = simplCoerce env coercion ty body args result_ty -\end{code} +simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty + = simplCoerce env to_ty from_ty body args result_ty +simplExpr env (Note (SCC cc) body) args result_ty + = simplSCC env cc body args result_ty -Set-cost-centre -~~~~~~~~~~~~~~~ - -1) Eliminating nested sccs ... -We must be careful to maintain the scc counts ... - -\begin{code} -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 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 result_ty -\end{code} - -2) Moving sccs inside lambdas ... - -\begin{code} -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 result_ty - -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 result_ty -\end{code} +-- InlineCall is simple enough to deal with on the spot +-- The only complication is that we slide the InlineCall +-- inwards past any function arguments +simplExpr env (Note InlineCall expr) args result_ty + = go expr args + where + go (Var v) args = simplVar env True {- InlineCall -} v args result_ty -3) Eliminating dict sccs ... + go (App fun arg) args = simplArg env arg `appEager` \ arg' -> + go fun (arg' : args) -\begin{code} -simplExpr env (SCC cc expr) args result_ty - | squashableDictishCcExpr cc expr - -- eliminate dict cc if trivial dict expression - = simplExpr env expr args result_ty + go other args = -- Unexpected discard; report it + pprTrace "simplExpr: discarding InlineCall" (ppr expr) $ + simplExpr env other args result_ty \end{code} -4) Moving arguments inside the body of an scc ... -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 result_ty - = let - new_env = setEnclosingCC env cost_centre - in - simplExpr new_env body args result_ty `thenSmpl` \ body' -> - returnSmpl (SCC cost_centre body') -\end{code} %************************************************************************ %* * @@ -496,7 +457,7 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id | otherwise -- OK, use the big hammer = -- Deal with the big lambda part - simplTyBinders env tyvars `thenSmpl` \ (lam_env, tyvars') -> + simplTyBinders rhs_env tyvars `thenSmpl` \ (lam_env, tyvars') -> let body_ty = applyTys rhs_ty (mkTyVarTys tyvars') in @@ -695,6 +656,33 @@ simplValLam env expr min_no_of_args expr_ty \end{code} +%************************************************************************ +%* * +\subsection[Simplify-var]{Variables} +%* * +%************************************************************************ + +Check if there's a macro-expansion, and if so rattle on. Otherwise do +the more sophisticated stuff. + +\begin{code} +simplVar env inline_call var args result_ty + = case lookupIdSubst env var of + + Just (SubstExpr ty_subst id_subst expr) + -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty + + Just (SubstLit lit) -- A boring old literal + -> ASSERT( null args ) + returnSmpl (Lit lit) + + Just (SubstVar var') -- More interesting! An id! + -> completeVar env inline_call var' args result_ty + + Nothing -- Not in the substitution; hand off to completeVar + -> completeVar env inline_call var args result_ty +\end{code} + %************************************************************************ %* * @@ -704,26 +692,88 @@ simplValLam env expr min_no_of_args expr_ty \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 result_ty - = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty +simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty + = simplCase env scrut (getSubstEnvs env, alts) + (\env rhs -> simplCoerce env to_ty from_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 result_ty - = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty +simplCoerce env to_ty from_ty (Let bind body) args result_ty + = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty -- Default case -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 +-- NB: we do *not* push the argments inside the coercion +simplCoerce env to_ty from_ty expr args result_ty + = simplTy env to_ty `appEager` \ to_ty' -> + simplTy env from_ty `appEager` \ from_ty' -> + simplExpr env expr [] from_ty' `thenSmpl` \ expr' -> + returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args) + where -- Try cancellation; we do this "on the way up" because -- I think that's where it'll bite best - mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body - mkCoerce coercion ty body = Coerce coercion ty body + mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body) + = ASSERT( from_ty1 == to_ty2 ) + mkCoerce to_ty1 from_ty2 body + mkCoerce to_ty from_ty body + | to_ty == from_ty = body + | otherwise = Note (Coerce to_ty from_ty) body +\end{code} + + +%************************************************************************ +%* * +\subsection[Simplify-scc]{SCC expressions +%* * +%************************************************************************ + +1) Eliminating nested sccs ... +We must be careful to maintain the scc counts ... + +\begin{code} +simplSCC env cc1 (Note (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 + = simplSCC env cc1 expr args result_ty + + | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1) + -- eliminate outer scc if no call counts associated with either ccs + = simplSCC env cc2 expr args result_ty +\end{code} + +2) Moving sccs inside lambdas ... + +\begin{code} +simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty + | not (isSccCountCostCentre cc) + -- move scc inside lambda only if no call counts + = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty + +simplSCC env cc (Lam binder body) args result_ty + -- always ok to move scc inside type/usage lambda + = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty +\end{code} + +3) Eliminating dict sccs ... + +\begin{code} +simplSCC env cc expr args result_ty + | squashableDictishCcExpr cc expr + -- eliminate dict cc if trivial dict expression + = simplExpr env expr args result_ty +\end{code} + +4) Moving arguments inside the body of an scc ... +This moves the cost of doing the application inside the scc +(which may include the cost of extracting methods etc) + +\begin{code} +simplSCC env cc body args result_ty + = let + new_env = setEnclosingCC env cc + in + simplExpr new_env body args result_ty `thenSmpl` \ body' -> + returnSmpl (Note (SCC cc) body') \end{code} @@ -884,11 +934,11 @@ Notice that let to case occurs only if x is used strictly in its body \begin{code} -- Dead code is now discarded by the occurrence analyser, -simplNonRec env binder@(id,occ_info) rhs body_c body_ty - | inlineUnconditionally ok_to_dup id occ_info +simplNonRec env binder@(id,_) rhs body_c body_ty + | inlineUnconditionally binder = -- 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) + body_c (bindIdToExpr env binder rhs) | idWantsToBeINLINEd id = complete_bind env rhs -- Don't mess about with floating or let-to-case on @@ -900,7 +950,7 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty -- we can't trivially do let-to-case (because there may be some unboxed -- things bound in letrecs that aren't really recursive). | isUnpointedType rhs_ty && not rhs_is_whnf - = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id))) + = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id))) (\env rhs -> complete_bind env rhs) body_ty -- Try let-to-case; see notes below about let-to-case @@ -914,7 +964,7 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty -- the end of simplification. ) = tick Let2Case `thenSmpl_` - simplCase env rhs (AlgAlts [] (BindDefault binder (Var id))) + simplCase env rhs (getSubstEnvs env, 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 @@ -940,34 +990,34 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty = tick CaseFloatFromLet `thenSmpl_` -- First, bind large let-body if necessary - if ok_to_dup || isSingleton (nonErrorRHSs alts) + if isSingleton (nonErrorRHSs alts) then - simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty + simplCase env scrut (getSubstEnvs env, alts) + (\env rhs -> simpl_bind env rhs) body_ty else bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> let body_c' = \env -> simplExpr env new_body [] body_ty case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty in - simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr -> + simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr -> returnSmpl (Let extra_binding case_expr) -- None of the above; simplify rhs and tidy up simpl_bind env rhs = complete_bind env rhs complete_bind env rhs - = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) -> - simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) -> + = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) -> + simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) -> completeNonRec env_w_clone binder - (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) -> - body_c new_env `thenSmpl` \ body' -> + (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) -> + body_c new_env `thenSmpl` \ body' -> returnSmpl (mkCoLetsAny binds body') -- All this stuff is computed at the start of the simpl_bind loop float_lets = switchIsSet env SimplFloatLetsExposingWHNF float_primops = switchIsSet env SimplOkToFloatPrimOps - ok_to_dup = switchIsSet env SimplOkToDupCode always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets try_let_to_case = switchIsSet env SimplLetToCase no_float = switchIsSet env SimplNoLetFromStrictLet @@ -985,7 +1035,7 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty ValueForm -> True other -> False - float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs + float_exposes_hnf = floatExposesHNF float_lets float_primops rhs let_floating_ok = (will_be_demanded && not no_float) || always_float_let_from_let || @@ -1031,12 +1081,12 @@ completeBind :: SimplEnv -> InBinder -> OutId -> OutExpr -- Id and RHS -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s) -completeBind env binder@(_,occ_info) new_id new_rhs - | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" - = (env, new_binds) - - | atomic_rhs -- If rhs (after eta reduction) is atomic +completeBind env binder@(old_id,occ_info) new_id new_rhs + | not (idMustNotBeINLINEd new_id) + && atomic_rhs -- If rhs (after eta reduction) is atomic && not (isExported new_id) -- and binder isn't exported + && not (isSpecPragmaId new_id) -- Don't discard spec prag Ids + = -- Drop the binding completely let env1 = notInScope env new_id @@ -1044,22 +1094,32 @@ completeBind env binder@(_,occ_info) new_id new_rhs in (env2, []) - | atomic_rhs -- Rhs is atomic, and new_id is exported - && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False } - = -- The local variable v will be eliminated next time round - -- in favour of new_id, so it's a waste to replace all new_id's with v's - -- this time round. - -- This case is an optional improvement; saves a simplifier iteration - (env, [(new_id, eta'd_rhs)]) - | otherwise -- Non-atomic + -- The big deal here is that we simplify the + -- SpecEnv of the Id, if any. We used to do that in simplBinders, but + -- that didn't work because it didn't take account of the fact that + -- one of the mutually recursive group might mention one of the others + -- in its SpecEnv = let - env1 = extendEnvGivenBinding env occ_info new_id new_rhs - in + id_w_specenv | isEmptySpecEnv spec_env = new_id + | otherwise = setIdSpecialisation new_id spec_env' + + env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" + = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding + -- Still need to record the new_id with its SpecEnv + + | otherwise -- Can inline it + = extendEnvGivenBinding env occ_info id_w_specenv new_rhs + + new_binds = [(id_w_specenv, new_rhs)] + in (env1, new_binds) where - new_binds = [(new_id, new_rhs)] + spec_env = getIdSpecialisation old_id + spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env + (ty_subst,id_subst) = getSubstEnvs env + atomic_rhs = is_atomic eta'd_rhs eta'd_rhs = case lookForConstructor env new_rhs of Just v -> Var v @@ -1191,8 +1251,8 @@ simplRec env pairs body_c body_ty 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 +simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs) + | inlineUnconditionally binder = -- 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 @@ -1202,20 +1262,17 @@ simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs -- 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 + new_env = bindIdToExpr env binder 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 + new_id' = new_id `withArity` arity (new_env, new_binds') = completeBind env binder new_id' new_rhs in simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> returnSmpl (new_binds' ++ new_pairs, final_env) - where - ok_to_dup = switchIsSet env SimplOkToDupCode \end{code} @@ -1279,7 +1336,7 @@ floatBind env top_level bind -- fltRhs has same invariant as fltBind fltRhs rhs | (always_float_let_from_let || - floatExposesHNF True False False rhs) + floatExposesHNF True False rhs) = fltExpr rhs | otherwise @@ -1324,7 +1381,14 @@ simplArg :: SimplEnv -> InArg -> Eager ans OutArg 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 +simplArg env arg@(VarArg id) + = case lookupIdSubst env id of + Just (SubstVar id') -> returnEager (VarArg id') + Just (SubstLit lit) -> returnEager (LitArg lit) + Just (SubstExpr _ __) -> panic "simplArg" + Nothing -> case lookupOutIdEnv env id of + Just (id', _, _) -> returnEager (VarArg id') + Nothing -> returnEager arg \end{code} %************************************************************************