X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=7d5d764fc6e3283ee1d5499d39483d2de0038e0c;hp=7e9a010051ee64822a2604bf0d628125e5b5df63;hb=c1c2c25355bc462e521b2c5fb41ac79307da22ff;hpb=61899158575bc64e692d6ab350c43c5d8ec1d8e2 diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 7e9a010..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 @@ -784,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 @@ -791,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 @@ -888,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 @@ -1032,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 {}) @@ -1048,7 +1060,7 @@ mkLam _env bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | otherwise + | otherwise = return (mkLams bndrs body) \end{code} @@ -1091,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] @@ -1336,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 @@ -1550,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)]