X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=c2128932150b992105119de922aed63979d97ca5;hp=53c9149460d14838b5ddd534307d87bfac054137;hb=4bc25e8c30559b7a6a87b39afcc79340ae778788;hpb=d95ce839533391e7118257537044f01cbb1d6694 diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 53c9149..c212893 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -10,12 +10,12 @@ module SimplUtils ( -- Inlining, preInlineUnconditionally, postInlineUnconditionally, - activeInline, activeRule, + activeInline, activeRule, inlineMode, -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, - countValArgs, countArgs, + countValArgs, countArgs, splitInlineCont, mkBoringStop, mkLazyArgStop, contIsRhsOrArg, interestingCallContext, interestingArgContext, @@ -34,6 +34,7 @@ import qualified CoreSubst import PprCore import CoreFVs import CoreUtils +import CoreArity ( etaExpand, exprEtaExpandArity ) import CoreUnfold import Name import Id @@ -214,6 +215,34 @@ dropArgs :: Int -> SimplCont -> SimplCont dropArgs 0 cont = cont dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other) + +-------------------- +splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont) +-- Returns Nothing if the continuation should dissolve an InlineMe Note +-- Return Just (c1,c2) otherwise, +-- where c1 is the continuation to put inside the InlineMe +-- and c2 outside + +-- Example: (__inline_me__ (/\a. e)) ty +-- Here we want to do the beta-redex without dissolving the InlineMe +-- See test simpl017 (and Trac #1627) for a good example of why this is important + +splitInlineCont (ApplyTo dup (Type ty) se c) + | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2) +splitInlineCont cont@(Stop {}) = Just (mkBoringStop, cont) +splitInlineCont cont@(StrictBind {}) = Just (mkBoringStop, cont) +splitInlineCont _ = Nothing + -- NB: we dissolve an InlineMe in any strict context, + -- not just function aplication. + -- E.g. foldr k z (__inline_me (case x of p -> build ...)) + -- Here we want to get rid of the __inline_me__ so we + -- can float the case, and see foldr/build + -- + -- However *not* in a strict RHS, else we get + -- let f = __inline_me__ (\x. e) in ...f... + -- Now if f is guaranteed to be called, hence a strict binding + -- we don't thereby want to dissolve the __inline_me__; for + -- example, 'f' might be a wrapper, so we'd inline the worker \end{code} @@ -341,7 +370,7 @@ mkArgInfo fun n_val_args call_cont vanilla_discounts, arg_discounts :: [Int] vanilla_discounts = repeat 0 arg_discounts = case idUnfolding fun of - CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}} + CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _) -> discounts ++ vanilla_discounts _ -> vanilla_discounts @@ -462,7 +491,13 @@ unboxed tuples and suchlike. INLINE pragmas ~~~~~~~~~~~~~~ -We don't simplify inside InlineRules (which come from INLINE pragmas). +SimplGently is also used as the mode to simplify inside an InlineMe note. + +\begin{code} +inlineMode :: SimplifierMode +inlineMode = SimplGently +\end{code} + It really is important to switch off inlinings inside such expressions. Consider the following example @@ -587,9 +622,9 @@ preInlineUnconditionally env top_lvl bndr rhs where phase = getMode env active = case phase of - SimplGently -> isAlwaysActive prag - SimplPhase n _ -> isActive n prag - prag = idInlinePragma bndr + SimplGently -> isAlwaysActive act + SimplPhase n _ -> isActive n act + act = idInlineActivation bndr try_once in_lam int_cxt -- There's one textual occurrence | not in_lam = isNotTopLevel top_lvl || early_phase @@ -743,9 +778,9 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding where active = case getMode env of - SimplGently -> isAlwaysActive prag - SimplPhase n _ -> isActive n prag - prag = idInlinePragma bndr + SimplGently -> isAlwaysActive act + SimplPhase n _ -> isActive n act + act = idInlineActivation bndr activeInline :: SimplEnv -> OutId -> Bool activeInline env id @@ -766,9 +801,9 @@ activeInline env id -- and they are now constructed as Compulsory unfoldings (in MkId) -- so they'll happen anyway. - SimplPhase n _ -> isActive n prag + SimplPhase n _ -> isActive n act where - prag = idInlinePragma id + act = idInlineActivation id activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool) -- Nothing => No rules at all @@ -794,14 +829,14 @@ activeRule dflags env %************************************************************************ \begin{code} -mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr +mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr -- mkLam tries three things -- a) eta reduction, if that gives a trivial expression -- b) eta expansion [only if there are some value lambdas] -mkLam [] body +mkLam _b [] body = return body -mkLam bndrs body +mkLam _env bndrs body = do { dflags <- getDOptsSmpl ; mkLam' dflags bndrs body } where @@ -823,7 +858,7 @@ mkLam bndrs body | dopt Opt_DoLambdaEtaExpansion dflags, any isRuntimeVar bndrs - = do { body' <- tryEtaExpansion dflags body + = do { let body' = tryEtaExpansion dflags body ; return (mkLams bndrs body') } | otherwise @@ -1008,11 +1043,10 @@ when computing arity; and etaExpand adds the coerces as necessary when actually computing the expansion. \begin{code} -tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr +tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr -- There is at least one runtime binder in the binders -tryEtaExpansion dflags body = do - us <- getUniquesM - return (etaExpand fun_arity us body (exprType body)) +tryEtaExpansion dflags body + = etaExpand fun_arity body where fun_arity = exprEtaExpandArity dflags body \end{code} @@ -1165,7 +1199,7 @@ abstractFloats main_tvs body_env body = do { uniq <- getUniqueM ; let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var $ -- Note [transferPolyIdInfo] in Id.lhs + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs mkLocalId poly_name poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } -- In the olden days, it was crucial to copy the occInfo of the original var,