From 9015d17020a8620c3fe15de4eab68573b07e7793 Mon Sep 17 00:00:00 2001 From: sof Date: Sun, 18 May 1997 23:29:18 +0000 Subject: [PATCH] [project @ 1997-05-18 23:29:18 by sof] mkTyLam - tyvar lifting added --- ghc/compiler/simplCore/SimplUtils.lhs | 181 +++++++++++++++++++++++++++++---- 1 file changed, 160 insertions(+), 21 deletions(-) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 4b8f01a..a92ae3f 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -10,7 +10,7 @@ module SimplUtils ( floatExposesHNF, - etaCoreExpr, + etaCoreExpr, mkRhsTyLam, etaExpandCount, @@ -18,7 +18,7 @@ module SimplUtils ( simplIdWantsToBeINLINEd, - type_ok_for_let_to_case + singleConstructorType, typeOkForCase ) where IMP_Ubiq(){-uitous-} @@ -27,17 +27,20 @@ IMPORT_DELOOPER(SmplLoop) -- paranoia checking import BinderInfo import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( SimpleUnfolding, mkFormSummary, FormSummary(..) ) -import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys, +import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) ) +import Id ( idType, isBottomingId, addInlinePragma, addIdDemandInfo, + idWantsToBeINLINEd, dataConArgTys, SYN_IE(Id), getIdArity, GenId{-instance Eq-} ) -import IdInfo ( ArityInfo(..) ) +import IdInfo ( ArityInfo(..), DemandInfo ) import Maybes ( maybeToBool ) import PrelVals ( augmentId, buildId ) import PrimOp ( primOpIsCheap ) import SimplEnv import SimplMonad -import Type ( tyVarsOfType, isPrimType, maybeAppDataTyConExpandingDicts ) +import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, isPrimType, + maybeAppDataTyConExpandingDicts, SYN_IE(Type) + ) import TysWiredIn ( realWorldStateTy ) import TyVar ( elementOfTyVarSet, GenTyVar{-instance Eq-} ) @@ -103,6 +106,100 @@ floatExposesHNF float_lets float_primops ok_to_dup rhs try_deflt (BindDefault _ rhs) = try rhs \end{code} + +Local tyvar-lifting +~~~~~~~~~~~~~~~~~~~ +mkRhsTyLam tries this transformation, when the big lambda appears as +the RHS of a let(rec) binding: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> f a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +So far as the implemtation is concerned: + + Invariant: go F e = /\tvs -> F e + + Equalities: + go F (Let x=e in b) + = Let x' = /\tvs -> F e + in + go G b + where + G = F . Let x = x' tvs + + go F (Letrec xi=ei in b) + = Letrec {xi' = /\tvs -> G ei} + in + go G b + where + G = F . Let {xi = xi' tvs} + +\begin{code} +mkRhsTyLam [] body = returnSmpl body + +mkRhsTyLam tyvars body + = go (\x -> x) body + where + tyvar_tys = mkTyVarTys tyvars + + go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs + = go (fn . Let bind) body + + go fn (Let bind@(NonRec var rhs) body) + = mk_poly var `thenSmpl` \ (var', rhs') -> + go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' -> + returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body') + + go fn (Let (Rec prs) body) + = mapAndUnzipSmpl mk_poly vars `thenSmpl` \ (vars', rhss') -> + let + gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss') + in + go gn body `thenSmpl` \ body' -> + returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body') + where + (vars,rhss) = unzip prs + + go fn body = returnSmpl (mkTyLam tyvars (fn body)) + + mk_poly var + = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id -> + returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys) + + mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs + -- The addInlinePragma is really important! If we don't say + -- INLINE on these silly little bindings then look what happens! + -- Suppose we start with: + -- + -- x = let g = /\a -> \x -> f x x + -- in + -- /\ b -> let g* = g b in E + -- + -- Then: * the binding for g gets floated out + -- * but then it gets inlined into the rhs of g* + -- * then the binding for g* is floated out of the /\b + -- * so we're back to square one + -- The silly binding for g* must be INLINE, so that no inlining + -- will happen in its RHS. +\end{code} + Eta reduction ~~~~~~~~~~~~~ @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr. @@ -336,15 +433,11 @@ if there's many, or if it's a primitive type. \begin{code} mkIdentityAlts - :: Type -- type of RHS + :: Type -- type of RHS + -> DemandInfo -- Appropriate demand info -> SmplM InAlts -- result -mkIdentityAlts rhs_ty - | isPrimType rhs_ty - = newId rhs_ty `thenSmpl` \ binder -> - returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder))) - - | otherwise +mkIdentityAlts rhs_ty demand_info = case (maybeAppDataTyConExpandingDicts rhs_ty) of Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking let @@ -360,32 +453,78 @@ mkIdentityAlts rhs_ty NoDefault ) - _ -> -- Multi-constructor or abstract algebraic type - newId rhs_ty `thenSmpl` \ binder -> - returnSmpl (AlgAlts [] (BindDefault (binder,bad_occ_info) (Var binder))) + _ -> panic "mkIdentityAlts" -- Should never happen; only called for single-constructor types where bad_occ_info = ManyOcc 0 -- Non-committal! + + +{- SHOULD NEVER HAPPEN + | isPrimType rhs_ty + = newId rhs_ty `thenSmpl` \ binder -> + let + binder_w_info = binder `addIdDemandInfo` demand_info + -- It's occasionally really worth adding the right demand info. Consider + -- let x = E in B + -- where x is sure to be demanded in B + -- We will transform to: + -- case E of x -> B + -- Now suppose that E simplifies to just y; we get + -- case y of x -> B + -- Because x is sure to be demanded, we can eliminate the case + -- even if pedantic-bottoms is on; but we need to have the right + -- demand-info on the default branch of the case. That's what + -- we are doing here. + in + returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder))) +-} \end{code} \begin{code} simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool simplIdWantsToBeINLINEd id env - = if switchIsSet env IgnoreINLINEPragma + = {- We used to arrange that in the final simplification pass we'd switch + off all INLINE pragmas, so that we'd inline workers back into the + body of their wrapper if the wrapper hadn't itself been inlined by then. + This occurred especially for methods in dictionaries. + + We no longer do this: + a) there's a good chance that the exported wrapper will get + inlined in some importing scope, in which case we don't + want to lose the w/w idea. + + b) The occurrence analyser must agree about what has an + INLINE pragma. Not hard, but delicate. + + c) if the worker gets inlined we have to tell the wrapepr + that it's no longer a wrapper, else the interface file stuff + asks for a worker that no longer exists. + + if switchIsSet env IgnoreINLINEPragma then False - else idWantsToBeINLINEd id + else + -} + + idWantsToBeINLINEd id idMinArity id = case getIdArity id of UnknownArity -> 0 ArityAtLeast n -> n ArityExactly n -> n -type_ok_for_let_to_case :: Type -> Bool +singleConstructorType :: Type -> Bool +singleConstructorType ty + = case (maybeAppDataTyConExpandingDicts ty) of + Just (tycon, ty_args, [con]) -> True + other -> False -type_ok_for_let_to_case ty +typeOkForCase :: Type -> Bool +typeOkForCase ty = case (maybeAppDataTyConExpandingDicts ty) of Nothing -> False Just (tycon, ty_args, []) -> False Just (tycon, ty_args, non_null_data_cons) -> True - -- Null data cons => type is abstract + -- Null data cons => type is abstract, which code gen can't + -- currently handle. (ToDo: when return-in-heap is universal we + -- don't need to worry about this.) \end{code} -- 1.7.10.4