X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=06af5ad251282d31f633ff840925e8ee3f219206;hb=ff9ab413f6ea513f1aea29c987805d022b72109a;hp=90b4b0bf767a6a51f7c1c236cf8cb15d7ec9b5e7;hpb=f469905af60366ec85f08c0e9f83a34624d3a160;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 90b4b0b..06af5ad 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -12,12 +12,14 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, mkLam, newId, prepareAlts, - simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, +import SimplEnv +import SimplUtils ( mkCase, mkLam, prepareAlts, SimplCont(..), DupFlag(..), LetRhsFlag(..), mkRhsStop, mkBoringStop, pushContArgs, contResultType, countArgs, contIsDupable, contIsRhsOrArg, - getContArgs, interestingCallContext, interestingArg, isStrictType + getContArgs, interestingCallContext, interestingArg, isStrictType, + preInlineUnconditionally, postInlineUnconditionally, + inlineMode, activeInline, activeRule ) import Id ( Id, idType, idInfo, idArity, isDataConWorkId, setIdUnfolding, isDeadBinder, @@ -34,11 +36,11 @@ import IdInfo ( OccInfo(..), isLoopBreaker, ) import NewDemand ( isStrictDmd ) import Unify ( coreRefineTys ) -import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon, dataConResTy ) +import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon ) import TyCon ( tyConArity ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline ) +import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline ) import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprIsConApp_maybe, mkPiTypes, findAlt, exprType, exprIsValue, @@ -49,12 +51,9 @@ import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, - splitFunTy_maybe, splitFunTy, eqType, substTy, - mkTyVarTys, mkTyConApp + splitFunTy_maybe, splitFunTy, coreEqType ) import VarEnv ( elemVarEnv ) -import Subst ( SubstResult(..), emptySubst, substExpr, - substId, simplIdInfo ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, @@ -64,7 +63,7 @@ import OrdList import Maybe ( Maybe ) import Maybes ( orElse ) import Outputable -import Util ( notNull, equalLength ) +import Util ( notNull ) \end{code} @@ -235,7 +234,7 @@ simplTopBinds env binds -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. - simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> freeTick SimplifierDone `thenSmpl_` returnSmpl (floatBinds floats) @@ -302,7 +301,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside | preInlineUnconditionally env NotTopLevel bndr = tick (PreInlineUnconditionally bndr) `thenSmpl_` - thing_inside (extendIdSubst env bndr (ContEx (getSubst rhs_se) rhs)) + thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs)) | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let @@ -315,7 +314,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside let -- simplLetBndr doesn't deal with the IdInfo, so we must -- do so here (c.f. simplLazyBind) - bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) env2 = modifyInScope env1 bndr2 bndr2 in completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside @@ -350,7 +349,6 @@ simplNonRecX env bndr new_rhs thing_inside -- because quotInt# can fail. = simplBinder env bndr `thenSmpl` \ (env, bndr') -> thing_inside env `thenSmpl` \ (floats, body) -> --- gaw 2004 let body' = wrapFloats floats body in returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')]) @@ -363,7 +361,7 @@ simplNonRecX env bndr new_rhs thing_inside -- Similarly, single occurrences can be inlined vigourously -- e.g. case (f x, g y) of (a,b) -> .... -- If a,b occur once we can avoid constructing the let binding for them. - = thing_inside (extendIdSubst env bndr (ContEx emptySubst new_rhs)) + = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) | otherwise = simplBinder env bndr `thenSmpl` \ (env, bndr') -> @@ -425,7 +423,7 @@ simplRecOrTopPair :: SimplEnv simplRecOrTopPair env top_lvl bndr bndr' rhs | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline = tick (PreInlineUnconditionally bndr) `thenSmpl_` - returnSmpl (emptyFloats env, extendIdSubst env bndr (ContEx (getSubst env) rhs)) + returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs)) | otherwise = simplLazyBind env top_lvl Recursive bndr bndr' rhs env @@ -488,7 +486,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- NB 4: does no harm for non-recursive bindings - bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) env1 = modifyInScope env bndr2 bndr2 rhs_env = setInScope rhs_se env1 is_top_level = isTopLevel top_lvl @@ -706,7 +704,7 @@ might do the same again. simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') where - expr_ty' = substTy (getTvSubst env) (exprType expr) + expr_ty' = substTy env (exprType expr) -- The type in the Stop continuation, expr_ty', is usually not used -- It's only needed when discarding continuations after finding -- a function that returns bottom. @@ -733,7 +731,6 @@ simplExprF env (Type ty) cont simplType env ty `thenSmpl` \ ty' -> rebuild env (Type ty') cont --- gaw 2004 simplExprF env (Case scrut bndr case_ty alts) cont | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) = -- Simplify the scrutinee with a Select continuation @@ -746,10 +743,10 @@ simplExprF env (Case scrut bndr case_ty alts) cont rebuild env case_expr' cont where case_cont = Select NoDup bndr alts env (mkBoringStop case_ty') - case_ty' = substTy (getTvSubst env) case_ty -- c.f. defn of simplExpr + case_ty' = substTy env case_ty -- c.f. defn of simplExpr simplExprF env (Let (Rec pairs) body) cont - = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> + = simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -769,7 +766,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType simplType env ty = seqType new_ty `seq` returnSmpl new_ty where - new_ty = substTy (getTvSubst env) ty + new_ty = substTy env ty \end{code} @@ -846,7 +843,7 @@ simplNote env (Coerce to from) body cont -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification - | t1 `eqType` k1 = cont -- The coerces cancel out + | t1 `coreEqType` k1 = cont -- The coerces cancel out | otherwise = CoerceIt t1 cont -- They don't cancel, but -- the inner one is redundant @@ -867,8 +864,8 @@ simplNote env (Coerce to from) body cont -- But it isn't a common case. = let (t1,t2) = splitFunTy t1t2 - new_arg = mkCoerce2 s1 t1 (substExpr subst arg) - subst = getSubst (setInScope arg_se env) + new_arg = mkCoerce2 s1 t1 (substExpr arg_env arg) + arg_env = setInScope arg_se env in ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) @@ -914,10 +911,10 @@ simplNote env (CoreNote s) e cont \begin{code} simplVar env var cont - = case substId (getSubst env) var of - DoneEx e -> simplExprF (zapSubstEnv env) e cont - ContEx se e -> simplExprF (setSubstEnv env se) e cont - DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont + = case substId env var of + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont + DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -969,9 +966,10 @@ completeCall env var occ_info cont let in_scope = getInScope env + rules = getRules env maybe_rule = case activeRule env of Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope var args + Just act_fn -> lookupRule act_fn in_scope rules var args in case maybe_rule of { Just (rule_name, rule_rhs) -> @@ -1290,7 +1288,7 @@ Blob of helper functions for the "case-of-something-else" situation. rebuildCase :: SimplEnv -> OutExpr -- Scrutinee -> InId -- Case binder - -> [InAlt] -- Alternatives + -> [InAlt] -- Alternatives (inceasing order) -> SimplCont -> SimplM FloatsWithExpr @@ -1500,27 +1498,24 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' (tvs,ids) = span isTyVar vs in simplBinders env tvs `thenSmpl` \ (env1, tvs') -> - let - pat_res_ty = dataConResTy con (mkTyVarTys tvs') - tv_subst = getTvSubst env - in - case coreRefineTys tvs' tv_subst pat_res_ty (idType case_bndr') of { + case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of { Nothing -- Dead code; for now, I'm just going to put in an -- error case so I can see them -> let rhs' = mkApps (Var eRROR_ID) - [Type (substTy tv_subst (exprType rhs)), + [Type (substTy env (exprType rhs)), Lit (mkStringLit "Impossible alternative (GADT)")] in simplBinders env1 ids `thenSmpl` \ (env2, ids') -> returnSmpl (Nothing, (DataAlt con, tvs' ++ ids', rhs')) ; - Just tv_subst_env -> -- The normal case + Just refine@(tv_subst_env, _) -> -- The normal case let - env2 = setTvSubstEnv env1 tv_subst_env + env2 = refineSimplEnv env1 refine -- Simplify the Ids in the refined environment, so their types -- reflect the refinement. Usually this doesn't matter, but it helps -- in mkDupableAlt, when we want to float a lambda that uses these binders + -- Furthermore, it means the binders contain maximal type information in simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') -> let unf = mkUnfolding False con_app @@ -1553,7 +1548,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' | otherwise = zapped_v : go vs strs where zapped_v = zap_occ_info v - evald_v = zapped_v `setIdUnfolding` mkOtherCon [] + evald_v = zapped_v `setIdUnfolding` evaldUnfolding go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) -- If the case binder is alive, then we add the unfolding @@ -1614,7 +1609,7 @@ knownCon env con args bndr alts cont bind_args env bs (drop n_drop_tys args) $ \ env -> let con_app = mkConApp dc (take n_drop_tys args ++ con_args) - con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs] + con_args = [substExpr env (varToCoreExpr b) | b <- bs] -- args are aready OutExprs, but bs are InIds in simplNonRecX env bndr con_app $ \ env ->