X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=1fb04febf1aeae0e022292753238de01b4b35aa6;hb=fb982282ff6307b342d8fbc09b58a990d76c68fb;hp=96857a38edabe31662b10114675bae6fc2996173;hpb=f2e74c8829d283aab5024731506f505ec4d5c7cb;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 96857a3..1fb04fe 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -15,8 +15,9 @@ module SimplUtils ( -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), + isSimplified, contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, - pushArgs, countValArgs, countArgs, addArgTo, + pushSimplifiedArgs, countValArgs, countArgs, addArgTo, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, interestingCallContext, @@ -36,11 +37,11 @@ import qualified CoreSubst import PprCore import CoreFVs import CoreUtils -import CoreArity ( etaExpand, exprEtaExpandArity ) +import CoreArity import CoreUnfold import Name import Id -import Var ( isCoVar ) +import Var ( Var, isCoVar ) import Demand import SimplMonad import Type hiding( substTy ) @@ -99,12 +100,12 @@ data SimplCont SimplCont | ApplyTo -- C arg - DupFlag - InExpr StaticEnv -- The argument and its static env + DupFlag -- See Note [DupFlag invariants] + InExpr StaticEnv -- The argument and its static env SimplCont | Select -- case C of alts - DupFlag + DupFlag -- See Note [DupFlag invariants] InId [InAlt] StaticEnv -- The case binder, alts, and subst-env SimplCont @@ -151,14 +152,31 @@ instance Outputable SimplCont where (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont -data DupFlag = OkToDup | NoDup +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty instance Outputable DupFlag where - ppr OkToDup = ptext (sLit "ok") - ppr NoDup = ptext (sLit "nodup") + ppr OkToDup = ptext (sLit "ok") + ppr NoDup = ptext (sLit "nodup") + ppr Simplified = ptext (sLit "simpl") +\end{code} +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both (ApplyTo dup _ env k) + and (Select dup _ _ env k) +the following invariants hold + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty + (and and hence no need to re-simplify) +\begin{code} ------------------- mkBoringStop :: SimplCont mkBoringStop = Stop BoringCtxt @@ -179,8 +197,8 @@ contIsRhsOrArg _ = False ------------------- contIsDupable :: SimplCont -> Bool contIsDupable (Stop {}) = True -contIsDupable (ApplyTo OkToDup _ _ _) = True -contIsDupable (Select OkToDup _ _ _ _) = True +contIsDupable (ApplyTo OkToDup _ _ _) = True -- See Note [DupFlag invariants] +contIsDupable (Select OkToDup _ _ _ _) = True -- ...ditto... contIsDupable (CoerceIt _ cont) = contIsDupable cont contIsDupable _ = False @@ -238,9 +256,10 @@ contArgs cont@(ApplyTo {}) contArgs cont = (True, [], cont) -pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont -pushArgs _env [] cont = cont -pushArgs env (arg:args) cont = ApplyTo NoDup arg env (pushArgs env args cont) +pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont +pushSimplifiedArgs _env [] cont = cont +pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont) + -- The env has an empty SubstEnv dropArgs :: Int -> SimplCont -> SimplCont dropArgs 0 cont = cont @@ -1033,20 +1052,46 @@ mkLam _env bndrs body (bndrs1, body1) = collectBinders body mkLam' dflags bndrs body - | dopt Opt_DoEtaReduction dflags, - Just etad_lam <- tryEtaReduce bndrs body + | dopt Opt_DoEtaReduction dflags + , Just etad_lam <- tryEtaReduce bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | dopt Opt_DoLambdaEtaExpansion dflags, - not (all isTyVar bndrs) -- Don't eta expand type abstractions - = do { let body' = tryEtaExpansion dflags body + | dopt Opt_DoLambdaEtaExpansion dflags + , any ok_to_expand bndrs + = do { let body' = etaExpand fun_arity body + fun_arity = exprEtaExpandArity dflags body ; return (mkLams bndrs body') } | otherwise = return (mkLams bndrs body) + + ok_to_expand :: Var -> Bool -- Note [When to eta expand] + ok_to_expand bndr = isId bndr && not (isDictId bndr) \end{code} +Note [When to eta expand] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We only eta expand if there is at least one non-tyvar, non-dict +binder. The proximate cause for not eta-expanding dictionary lambdas +was this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the InlineRule for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + Note [Casts and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1085,7 +1130,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 @@ -1094,146 +1139,6 @@ because the latter is not well-kinded. return (floats, mkLams bndrs body') -} - -%************************************************************************ -%* * - 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 -%* * -%************************************************************************ - - -We go for: - f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym - (n >= 0) - -where (in both cases) - - * The xi can include type variables - - * The yi are all value variables - - * 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 -actually computing the expansion. - -\begin{code} -tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr --- There is at least one runtime binder in the binders -tryEtaExpansion dflags body - = etaExpand fun_arity body - where - fun_arity = exprEtaExpandArity dflags body -\end{code} - - %************************************************************************ %* * \subsection{Floating lets out of big lambdas} @@ -1337,7 +1242,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 @@ -1529,16 +1434,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 @@ -1554,9 +1460,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)]