X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=6ce29a2562755448a27d7761e4b411933f6b15cb;hb=64bfc0114c0811fe175149dd6d803c7c77de0062;hp=5c9d5d53d94edf4ab0fa1052bfff87f3ae0cfb0f;hpb=30c39066cfbbb9380fff1f3266405d37af798009;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 5c9d5d5..6ce29a2 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -95,10 +95,8 @@ data SimplCont Bool -- True <=> There is something interesting about -- the context, and hence the inliner -- should be a bit keener (see interestingCallContext) - -- Two cases: - -- (a) This is the RHS of a thunk whose type suggests - -- that update-in-place would be possible - -- (b) This is an argument of a function that has RULES + -- Specifically: + -- This is an argument of a function that has RULES -- Inlining the call might allow the rule to fire | CoerceIt -- C `cast` co @@ -156,10 +154,10 @@ mkBoringStop :: OutType -> SimplCont mkBoringStop ty = Stop ty AnArg False mkLazyArgStop :: OutType -> Bool -> SimplCont -mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules) +mkLazyArgStop ty has_rules = Stop ty AnArg has_rules mkRhsStop :: OutType -> SimplCont -mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) +mkRhsStop ty = Stop ty AnRhs False ------------------- contIsRhsOrArg (Stop {}) = True @@ -400,27 +398,6 @@ interestingArgContext fn call_cont go (StrictBind {}) = False -- ?? go (CoerceIt _ c) = go c go (Stop _ _ interesting) = interesting - -------------------- -canUpdateInPlace :: Type -> Bool --- Consider let x = in ... --- If returns an explicit constructor, we might be able --- to do update in place. So we treat even a thunk RHS context --- as interesting if update in place is possible. We approximate --- this by seeing if the type has a single constructor with a --- small arity. But arity zero isn't good -- we share the single copy --- for that case, so no point in sharing. - -canUpdateInPlace ty - | not opt_UF_UpdateInPlace = False - | otherwise - = case splitTyConApp_maybe ty of - Nothing -> False - Just (tycon, _) -> case tyConDataCons_maybe tycon of - Just [dc] -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc - other -> False \end{code} @@ -882,48 +859,90 @@ because the latter is not well-kinded. %************************************************************************ %* * -\subsection{Eta expansion and reduction} + Eta reduction %* * %************************************************************************ -We try for eta reduction here, but *only* if we get all the -way to an exprIsTrivial expression. -We don't want to remove extra lambdas unless we are going -to avoid allocating this thing altogether +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. + +* 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. Instead, look at the unfolding. + + 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 vlaue, 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 + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. \begin{code} tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr tryEtaReduce bndrs body - -- We don't use CoreUtils.etaReduce, because we can be more - -- efficient here: - -- (a) we already have the binders - -- (b) we can do the triviality test before computing the free vars = go (reverse bndrs) body where 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! - ok_fun fun = exprIsTrivial fun - && not (any (`elemVarSet` (exprFreeVars fun)) bndrs) - && (exprIsHNF fun || all ok_lam bndrs) + -- 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 + | isLocalId fun = isEvaldUnfolding (idUnfolding fun) + | isDataConWorkId fun = True + | isGlobalId fun = idArity fun > 0 + ok_lam v = isTyVar v || isDictId v - -- The exprIsHNF is because eta reduction is not - -- valid in general: \x. bot /= bot - -- So we need to be sure that the "fun" is a value. - -- - -- However, 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 isDictTy ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg \end{code} - Try eta expansion for RHSs +%************************************************************************ +%* * + Eta expansion +%* * +%************************************************************************ + We go for: f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym @@ -938,6 +957,16 @@ where (in both cases) * N is a NORMAL FORM (i.e. no redexes anywhere) wanting a suitable number of extra args. +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good exmaple is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + We may have to sandwich some coerces between the lambdas to make the types work. exprEtaExpandArity looks through coerces when computing arity; and etaExpand adds the coerces as necessary when