X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=d1c5cefce147e6934c3338c39214f026592a53f6;hb=e95ee1f718c6915c478005aad8af81705357d6ab;hp=4a8ad544a9767c17872f9a28d6f3e4d1d0c9c182;hpb=b8ee6f14ca6e9e49015ee9b404cf8b8191fede05;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 4a8ad54..d1c5cef 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -36,7 +36,7 @@ import qualified CoreSubst import PprCore import CoreFVs import CoreUtils -import CoreArity ( etaExpand, exprEtaExpandArity ) +import CoreArity import CoreUnfold import Name import Id @@ -475,9 +475,9 @@ On the other hand, it is bad not to do ANY inlining into an InlineRule, because then recursive knots in instance declarations don't get unravelled. -However, *sometimes* SimplGently must do no call-site inlining at all. -Before full laziness we must be careful not to inline wrappers, -because doing so inhibits floating +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so inhibits floating e.g. ...(case f x of ...)... ==> ...(case (case x of I# x# -> fw x#) of ...)... ==> ...(case x of I# x# -> case fw x# of ...)... @@ -502,6 +502,9 @@ RULES are enabled when doing "gentle" simplification. Two reasons: to work in Template Haskell when simplifying splices, so we get simpler code for literal strings +But watch out: list fusion can prevent floating. So use phase control +to switch off those rules until after floating. + Note [Simplifying inside InlineRules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must take care with simplification inside InlineRules (which come from @@ -697,6 +700,27 @@ let-float if you inline windowToViewport However, as usual for Gentle mode, do not inline things that are inactive in the intial stages. See Note [Gentle mode]. +Note [InlineRule and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of f1. But if we inline it there +we'll lose the opportunity to inline at each of fInt's call sites. +The INLINE pragma will only inline when the application is saturated +for exactly this reason; and we don't want PreInlineUnconditionally +to second-guess it. A live example is Trac #3736. + c.f. Note [InlineRule and postInlineUnconditionally] + Note [Top-level botomming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't inline top-level Ids that are bottoming, even if they are used just @@ -707,6 +731,7 @@ Inlining them won't make the program run faster! preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool preInlineUnconditionally env top_lvl bndr rhs | not active = False + | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] | opt_SimplNoPreInlining = False | otherwise = case idOccInfo bndr of @@ -971,6 +996,8 @@ Then there's a danger we'll optimise to and now postInlineUnconditionally, losing the InlineRule on f. Now f' won't inline because 'e' is too big. + c.f. Note [InlineRule and preInlineUnconditionally] + %************************************************************************ %* * @@ -986,7 +1013,7 @@ mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam _b [] body = return body -mkLam env bndrs body +mkLam _env bndrs body = do { dflags <- getDOptsSmpl ; mkLam' dflags bndrs body } where @@ -1000,6 +1027,11 @@ mkLam env bndrs body co_vars = tyVarsOfType co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + mkLam' dflags bndrs body@(Lam {}) + = mkLam' dflags (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + mkLam' dflags bndrs body | dopt Opt_DoEtaReduction dflags, Just etad_lam <- tryEtaReduce bndrs body @@ -1007,9 +1039,7 @@ mkLam env bndrs body ; return etad_lam } | dopt Opt_DoLambdaEtaExpansion dflags, - not (inGentleMode env), -- In gentle mode don't eta-expansion - any isRuntimeVar bndrs -- because it can clutter up the code - -- with casts etc that may not be removed + not (all isTyCoVar bndrs) -- Don't eta expand type abstractions = do { let body' = tryEtaExpansion dflags body ; return (mkLams bndrs body') } @@ -1055,7 +1085,7 @@ because the latter is not well-kinded. {- Sept 01: I'm experimenting with getting the full laziness pass to float out past big lambdsa - | all isTyVar bndrs, -- Only for big lambdas + | all isTyCoVar bndrs, -- Only for big lambdas contIsRhs cont -- Only try the rhs type-lambda floating -- if this is indeed a right-hand side; otherwise -- we end up floating the thing out, only for float-in @@ -1067,100 +1097,6 @@ because the latter is not well-kinded. %************************************************************************ %* * - Eta reduction -%* * -%************************************************************************ - -Note [Eta reduction conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try for eta reduction here, but *only* if we get all the way to an -trivial expression. We don't want to remove extra lambdas unless we -are going to avoid allocating this thing altogether. - -There are some particularly delicate points here: - -* Eta reduction is not valid in general: - \x. bot /= bot - This matters, partly for old-fashioned correctness reasons but, - worse, getting it wrong can yield a seg fault. Consider - f = \x.f x - h y = case (case y of { True -> f `seq` True; False -> False }) of - True -> ...; False -> ... - - If we (unsoundly) eta-reduce f to get f=f, the strictness analyser - says f=bottom, and replaces the (f `seq` True) with just - (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it - *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not termninate after all. - Result: seg-fault because the boolean case actually gets a function value. - See Trac #1947. - - So it's important to to the right thing. - -* Note [Arity care]: we need to be careful if we just look at f's - arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in SimplEnv) so we must *not* trust the - arity when checking that 'f' is a value. Otherwise we will - eta-reduce - f = \x. f x - to - f = f - Which might change a terminiating program (think (f `seq` e)) to a - non-terminating one. So we check for being a loop breaker first. - - However for GlobalIds we can look at the arity; and for primops we - must, since they have no unfolding. - -* Regardless of whether 'f' is a value, we always want to - reduce (/\a -> f a) to f - This came up in a RULE: foldr (build (/\a -> g a)) - did not match foldr (build (/\b -> ...something complex...)) - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc isDictId - -* Never *reduce* arity. For example - f = \xy. g x y - Then if h has arity 1 we don't want to eta-reduce because then - f's arity would decrease, and that is bad - -These delicacies are why we don't use exprIsTrivial and exprIsHNF here. -Alas. - -\begin{code} -tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr -tryEtaReduce bndrs body - = go (reverse bndrs) body - where - incoming_arity = count isId bndrs - - go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round - go [] fun | ok_fun fun = Just fun -- Success! - go _ _ = Nothing -- Failure! - - -- Note [Eta reduction conditions] - ok_fun (App fun (Type ty)) - | not (any (`elemVarSet` tyVarsOfType ty) bndrs) - = ok_fun fun - ok_fun (Var fun_id) - = not (fun_id `elem` bndrs) - && (ok_fun_id fun_id || all ok_lam bndrs) - ok_fun _fun = False - - ok_fun_id fun = fun_arity fun >= incoming_arity - - fun_arity fun -- See Note [Arity care] - | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0 - | otherwise = idArity fun - - ok_lam v = isTyVar v || isDictId v - - ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg -\end{code} - - -%************************************************************************ -%* * Eta expansion %* * %************************************************************************ @@ -1307,7 +1243,7 @@ abstractFloats main_tvs body_env body 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 isTyVar rhs') + = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs') -- Abstract only over the type variables free in the rhs -- wrt which the new binding is abstracted. But the naive @@ -1499,16 +1435,17 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) -- case x of { DEFAULT -> e } -- and we don't want to fill in a default for them! , Just all_cons <- tyConDataCons_maybe tycon - , not (null all_cons) -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, then the case expression will have at most a default - -- alternative. We don't want to eliminate that alternative, because the - -- invariant is that there's always one alternative. It's more convenient - -- to leave - -- case x of { DEFAULT -> e } - -- as it is, rather than transform it to - -- error "case cant match" - -- which would be quite legitmate. But it's a really obscure corner, and - -- not worth wasting code on. + , not (null all_cons) + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, then the case expression will have at most a default + -- alternative. We don't want to eliminate that alternative, because the + -- invariant is that there's always one alternative. It's more convenient + -- to leave + -- case x of { DEFAULT -> e } + -- as it is, rather than transform it to + -- error "case cant match" + -- which would be quite legitmate. But it's a really obscure corner, and + -- not worth wasting code on. , let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con = case filterOut impossible all_cons of @@ -1524,9 +1461,12 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) _ -> return [(DEFAULT, [], deflt_rhs)] - | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon) + | debugIsOn, isAlgTyCon tycon + , null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) -- Check for no data constructors - -- This can legitimately happen for type families, so don't report that + -- This can legitimately happen for abstract types and type families, + -- so don't report that = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon) $ return [(DEFAULT, [], deflt_rhs)]