X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=7d5d764fc6e3283ee1d5499d39483d2de0038e0c;hp=76ce1f9601f5dfc561c2953722f1003a677de55d;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=1d7a3cf332532b1f9d798b44e76c4be6f0c74dcf diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 76ce1f9..7d5d764 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -36,6 +36,7 @@ import StaticFlags import CoreSyn import qualified CoreSubst import PprCore +import DataCon ( dataConCannotMatch ) import CoreFVs import CoreUtils import CoreArity @@ -45,17 +46,16 @@ import Id import Var import Demand import SimplMonad -import TcType ( isDictLikeTy ) import Type hiding( substTy ) -import Coercion ( coercionKind ) +import Coercion hiding( substCo ) import TyCon -import Unify ( dataConCannotMatch ) import VarSet import BasicTypes import Util import MonadUtils import Outputable import FastString +import Pair import Data.List \end{code} @@ -99,6 +99,7 @@ data SimplCont | CoerceIt -- C `cast` co OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion SimplCont | ApplyTo -- C arg @@ -208,6 +209,7 @@ contIsDupable _ = False contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont +contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont contIsTrivial (CoerceIt _ cont) = contIsTrivial cont contIsTrivial _ = False @@ -216,17 +218,19 @@ contResultType :: SimplEnv -> OutType -> SimplCont -> OutType contResultType env ty cont = go cont ty where - subst_ty se ty = substTy (se `setInScope` env) ty + subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty + subst_co se co = SimplEnv.substCo (se `setInScope` env) co go (Stop {}) ty = ty - go (CoerceIt co cont) _ = go cont (snd (coercionKind co)) + go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co)) go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body))) go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai)) go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts)) go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se) - apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) - apply_to_arg ty _ _ = funResultTy ty + apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) + apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg) + apply_to_arg ty _ _ = funResultTy ty argInfoResultTy :: ArgInfo -> OutType argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) @@ -235,6 +239,7 @@ argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) ------------------- countValArgs :: SimplCont -> Int countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont +countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont countValArgs _ = 0 @@ -468,12 +473,17 @@ CoreMonad sm_eta_expand :: Bool -- Whether eta-expansion is enabled \begin{code} -simplEnvForGHCi :: SimplEnv -simplEnvForGHCi = mkSimplEnv $ - SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_rules = True, sm_inline = False - , sm_eta_expand = False, sm_case_case = True } +simplEnvForGHCi :: DynFlags -> SimplEnv +simplEnvForGHCi dflags + = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] + , sm_phase = InitialPhase + , sm_rules = rules_on + , sm_inline = False + , sm_eta_expand = eta_expand_on + , sm_case_case = True } + where + rules_on = dopt Opt_EnableRewriteRules dflags + eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags -- Do not do any inlining, in case we expose some unboxed -- tuple stuff that confuses the bytecode interpreter @@ -481,9 +491,10 @@ updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode -- See Note [Simplifying inside InlineRules] updModeForInlineRules inline_rule_act current_mode = current_mode { sm_phase = phaseFromActivation inline_rule_act - , sm_rules = True , sm_inline = True , sm_eta_expand = False } + -- For sm_rules, just inherit; sm_rules might be "off" + -- becuase of -fno-enable-rewrite-rules where phaseFromActivation (ActiveAfter n) = Phase n phaseFromActivation _ = InitialPhase @@ -778,6 +789,11 @@ Don't inline top-level Ids that are bottoming, even if they are used just once, because FloatOut has gone to some trouble to extract them out. Inlining them won't make the program run faster! +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and have a separate +substitution, so don't inline them via the IdSubst! + \begin{code} preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool preInlineUnconditionally env top_lvl bndr rhs @@ -785,6 +801,7 @@ preInlineUnconditionally env top_lvl bndr rhs | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] | opt_SimplNoPreInlining = False + | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally] | otherwise = case idOccInfo bndr of IAmDead -> True -- Happens in ((\x.1) v) OneOcc in_lam True int_cxt -> try_once in_lam int_cxt @@ -857,7 +874,7 @@ a thing based on the form of its RHS; in particular if it has a trivial RHS. If so, we can inline and discard the binding altogether. NB: a loop breaker has must_keep_binding = True and non-loop-breakers -only have *forward* references Hence, it's safe to discard the binding +only have *forward* references. Hence, it's safe to discard the binding NOTE: This isn't our last opportunity to inline. We're at the binding site right now, and we'll get another opportunity when we get to the @@ -882,6 +899,7 @@ story for now. postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -- The binder (an InId would be fine too) + -- (*not* a CoVar) -> OccInfo -- From the InId -> OutExpr -> Unfolding @@ -892,8 +910,8 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding -- because it might be referred to "earlier" | isExportedId bndr = False | isStableUnfolding unfolding = False -- Note [InlineRule and postInlineUnconditionally] - | exprIsTrivial rhs = True | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] + | exprIsTrivial rhs = True | otherwise = case occ_info of -- The point of examining occ_info here is that for *non-values* @@ -960,14 +978,29 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding Note [Top level and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do postInlineUnconditionally for top-level things (exept ones that -are trivial): - * There is no point, because the main goal is to get rid of local - bindings used in multiple case branches. +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + * Doing so will inline top-level error expressions that have been carefully floated out by FloatOut. More generally, it might replace static allocation with dynamic. + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + Note [InlineRule and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do not do postInlineUnconditionally if the Id has an InlineRule, otherwise @@ -1011,9 +1044,9 @@ mkLam _env bndrs body | not (any bad bndrs) -- Note [Casts and lambdas] = do { lam <- mkLam' dflags bndrs body - ; return (mkCoerce (mkPiTypes bndrs co) lam) } + ; return (mkCoerce (mkPiCos bndrs co) lam) } where - co_vars = tyVarsOfType co + co_vars = tyCoVarsOfCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars mkLam' dflags bndrs body@(Lam {}) @@ -1027,7 +1060,7 @@ mkLam _env bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | otherwise + | otherwise = return (mkLams bndrs body) \end{code} @@ -1070,9 +1103,6 @@ because the latter is not well-kinded. %* * %************************************************************************ -When we meet a let-binding we try eta-expansion. To find the -arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis] - \begin{code} tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] @@ -1315,9 +1345,7 @@ abstractFloats main_tvs body_env body ; return (subst', (NonRec poly_id poly_rhs)) } where rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions] - | otherwise - = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs') + tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') -- Abstract only over the type variables free in the rhs -- wrt which the new binding is abstracted. But the naive @@ -1529,9 +1557,8 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) [con] -> -- It matches exactly one constructor, so fill it in do { tick (FillInCaseDefault case_bndr) ; us <- getUniquesM - ; let (ex_tvs, co_tvs, arg_ids) = - dataConRepInstPat us con inst_tys - ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] } + ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] } _ -> return [(DEFAULT, [], deflt_rhs)]