X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=5883013a06d69ba760312bcf610d7d99665ebee8;hp=5a00869ddd7b641c4876276393102680861ed2f8;hb=1b381af863d64aaa0a4dd9c816170c58e6131a9e;hpb=c177e43f99dcd525b78ee0ac8f16c3d42c618e1f diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 5a00869..5883013 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -26,7 +26,7 @@ module CoreUnfold ( interestingArg, ArgSummary(..), - couldBeSmallEnoughToInline, + couldBeSmallEnoughToInline, inlineBoringOk, certainlyWillInline, smallEnoughToInline, callSiteInline, CallCtxt(..), @@ -41,8 +41,8 @@ import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances -import TcType ( tcSplitSigmaTy, tcSplitDFunHead ) -import OccurAnal +import TcType ( tcSplitDFunTy ) +import OccurAnal ( occurAnalyseExpr ) import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) import CoreArity ( manifestArity, exprBotStrictness_maybe ) @@ -54,13 +54,13 @@ import Literal import PrimOp import IdInfo import BasicTypes ( Arity ) -import TcType ( tcSplitDFunTy ) -import Type +import Type import Coercion import PrelNames import VarEnv ( mkInScopeSet ) import Bag import Util +import Pair import FastTypes import FastString import Outputable @@ -91,15 +91,12 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) mkSimpleUnfolding :: CoreExpr -> Unfolding mkSimpleUnfolding = mkUnfolding InlineRhs False False -mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding +mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops = DFunUnfolding dfun_nargs data_con ops where - (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty - -- NB: tcSplitSigmaTy: do not look through a newtype - -- when the dictionary type is a newtype - (cls, _) = tcSplitDFunHead head_ty - dfun_nargs = length tvs + length theta + (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty + dfun_nargs = length tvs + n_theta data_con = classDataCon cls mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding @@ -111,7 +108,7 @@ mkWwInlineRule id expr arity mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded = mkCoreUnfolding InlineCompulsory True - expr 0 -- Arity of unfolding doesn't matter + (simpleOptExpr expr) 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding @@ -126,12 +123,7 @@ mkInlineUnfolding mb_arity expr Nothing -> (unSaturatedOk, manifestArity expr') Just ar -> (needSaturated, ar) - boring_ok = case calcUnfoldingGuidance True -- Treat as cheap - False -- But not bottoming - (arity+1) expr' of - (_, UnfWhen _ boring_ok) -> boring_ok - _other -> boringCxtNotOk - -- See Note [INLINE for small functions] + boring_ok = inlineBoringOk expr' mkInlinableUnfolding :: CoreExpr -> Unfolding mkInlinableUnfolding expr @@ -162,6 +154,10 @@ mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it mkUnfolding src top_lvl is_bottoming expr + | top_lvl && is_bottoming + , not (exprIsTrivial expr) + = NoUnfolding -- See Note [Do not inline top-level bottoming functions] + | otherwise = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, uf_src = src, uf_arity = arity, @@ -173,7 +169,7 @@ mkUnfolding src top_lvl is_bottoming expr uf_guidance = guidance } where is_cheap = exprIsCheap expr - (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) + (arity, guidance) = calcUnfoldingGuidance is_cheap opt_UF_CreationThreshold expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains @@ -193,15 +189,35 @@ mkUnfolding src top_lvl is_bottoming expr %************************************************************************ \begin{code} +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Note _ e) = go credit e + go credit (Cast e _) = go credit e + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + calcUnfoldingGuidance :: Bool -- True <=> the rhs is cheap, or we want to treat it -- as cheap (INLINE things) - -> Bool -- True <=> this is a top-level unfolding for a - -- diverging function; don't inline this -> Int -- Bomb out if size gets bigger than this -> CoreExpr -- Expression to look at -> (Arity, UnfoldingGuidance) -calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr +calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr = case collectBinders expr of { (bndrs, body) -> let val_bndrs = filter isId bndrs @@ -214,9 +230,6 @@ calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr | uncondInline n_val_bndrs (iBox size) , expr_is_cheap -> UnfWhen unSaturatedOk boringCxtOk -- Note [INLINE for small functions] - | top_bot -- See Note [Do not inline top-level bottoming functions] - -> UnfNever - | otherwise -> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs , ug_size = iBox size @@ -336,11 +349,13 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (Cast e _) = size_up e size_up (Note _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) size_up (Var f) = size_up_call f [] -- Make sure we get constructor -- discounts even on nullary constructors size_up (App fun (Type _)) = size_up fun + size_up (App fun (Coercion _)) = size_up fun size_up (App fun arg) = size_up arg `addSizeNSD` size_up_app fun [arg] @@ -396,7 +411,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr ------------ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args - | isTypeArg arg = size_up_app fun args + | isTyCoArg arg = size_up_app fun args | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) size_up_app (Var fun) args = size_up_call fun args @@ -771,21 +786,21 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info -- be a loop breaker (maybe the knot is not yet untied) CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top , uf_is_cheap = is_cheap, uf_arity = uf_arity - , uf_guidance = guidance } + , uf_guidance = guidance, uf_expandable = is_exp } | active_unfolding -> tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top - is_cheap uf_arity guidance + is_cheap is_exp uf_arity guidance | otherwise -> Nothing NoUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt - -> CoreExpr -> Bool -> Bool -> Arity -> UnfoldingGuidance + -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance -> Maybe CoreExpr tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top - is_cheap uf_arity guidance + is_cheap is_exp uf_arity guidance -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags @@ -794,6 +809,7 @@ tryUnfolding dflags id lone_variable text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, text "some_benefit" <+> ppr some_benefit, + text "is exp:" <+> ppr is_exp, text "is cheap:" <+> ppr is_cheap, text "guidance" <+> ppr guidance, extra_doc, @@ -827,10 +843,10 @@ tryUnfolding dflags id lone_variable interesting_saturated_call = case cont_info of - BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] + BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables] - ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - ValAppCtxt -> True -- Note [Cast then apply] + ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + ValAppCtxt -> True -- Note [Cast then apply] (yes_or_no, extra_doc) = case guidance of @@ -1134,12 +1150,14 @@ interestingArg e = go e 0 conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg - go (App fn (Type _)) n = go fn n + go (Coercion _) _ = TrivArg + go (App fn (Type _)) n = go fn n + go (App fn (Coercion _)) n = go fn n go (App fn _) n = go fn (n+1) go (Note _ a) n = go a n go (Cast e _) n = go e n go (Lam v e) n - | isTyCoVar v = go e n + | isTyVar v = go e n | n>0 = go e (n-1) | otherwise = ValueArg go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg } @@ -1195,7 +1213,7 @@ exprIsConApp_maybe id_unf (Cast expr co) Nothing -> Nothing ; Just (dc, _dc_univ_args, dc_args) -> - let (_from_ty, to_ty) = coercionKind co + let Pair _from_ty to_ty = coercionKind co dc_tc = dataConTyCon dc in case splitTyConApp_maybe to_ty of { @@ -1215,41 +1233,28 @@ exprIsConApp_maybe id_unf (Cast expr co) dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc - dc_eqs :: [(Type,Type)] -- All equalities from the DataCon - dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++ - [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc] - - (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args - (co_args, val_args) = splitAtList dc_eqs rest1 + (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ stripTypeArgs ex_args) - - -- Cast the existential coercion arguments - cast_co (ty1, ty2) (Type co) - = Type $ mkSymCoercion (substTy theta ty1) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty2) - cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg) - new_co_args = zipWith cast_co dc_eqs co_args - + theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ map mkReflCo (stripTypeArgs ex_args)) + -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg in #ifdef DEBUG let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr _dc_univ_args, ppr ex_args, ppr val_args] in - ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) - ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) #endif - Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) + Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) }} exprIsConApp_maybe id_unf expr @@ -1269,10 +1274,12 @@ exprIsConApp_maybe id_unf expr , let sat = length args == dfun_nargs -- See Note [DFun arity check] in if sat then True else pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False - , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) - subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - = Just (con, substTys subst dfun_res_tys, - [mkApps op args | op <- ops]) + , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) + mk_arg (DFunConstArg e) = e + mk_arg (DFunLamArg i) = args !! i + mk_arg (DFunPolyArg e) = mkApps e args + = Just (con, substTys subst dfun_res_tys, map mk_arg ops) -- Look through unfoldings, but only cheap ones, because -- we are effectively duplicating the unfolding @@ -1286,7 +1293,7 @@ exprIsConApp_maybe id_unf expr ----------- beta (Lam v body) pairs (arg : args) - | isTypeArg arg + | isTyCoArg arg = beta body ((v,arg):pairs) args beta (Lam {}) _ _ -- Un-saturated, or not a type lambda @@ -1298,10 +1305,10 @@ exprIsConApp_maybe id_unf expr subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] - stripTypeArgs :: [CoreExpr] -> [Type] stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) [ty | Type ty <- args] + -- We really do want isTypeArg here, not isTyCoArg! \end{code} Note [Unfolding DFuns]