From d6765099d843d0571c8c81382a1c3ed24e01aae1 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 29 Apr 1998 09:30:29 +0000 Subject: [PATCH] [project @ 1998-04-29 09:30:24 by simonpj] Alleged fix to SpecEnv muddle for recursive bindings --- ghc/compiler/simplCore/SimplUtils.lhs | 41 ++++++++++++++++++++++++-- ghc/compiler/simplCore/SimplVar.lhs | 51 +++++---------------------------- ghc/compiler/simplCore/Simplify.lhs | 50 ++++++++++++++++---------------- 3 files changed, 69 insertions(+), 73 deletions(-) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index b46ad32..4bd662b 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -16,7 +16,9 @@ module SimplUtils ( simplIdWantsToBeINLINEd, - singleConstructorType, typeOkForCase + singleConstructorType, typeOkForCase, + + substSpecEnvRhs ) where #include "HsVersions.h" @@ -29,6 +31,7 @@ import MkId ( mkSysLocal ) import Id ( idType, isBottomingId, getIdArity, addInlinePragma, addIdDemandInfo, idWantsToBeINLINEd, dataConArgTys, Id, + lookupIdEnv, delOneFromIdEnv ) import IdInfo ( ArityInfo(..), DemandInfo ) import Maybes ( maybeToBool ) @@ -37,10 +40,10 @@ import PrimOp ( primOpIsCheap ) import SimplEnv import SimplMonad import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe, - splitAlgTyConApp_maybe, Type + splitAlgTyConApp_maybe, instantiateTy, Type ) import TyCon ( isDataTyCon ) -import TyVar ( elementOfTyVarSet ) +import TyVar ( elementOfTyVarSet, delFromTyVarEnv ) import SrcLoc ( noSrcLoc ) import Util ( isIn, zipWithEqual, panic, assertPanic ) @@ -494,3 +497,35 @@ typeOkForCase ty -- currently handle. (ToDo: when return-in-heap is universal we -- don't need to worry about this.) \end{code} + + + +substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv +It exploits the known structure of a SpecEnv's RHS to have fewer +equations. + +\begin{code} +substSpecEnvRhs te ve rhs + = go te ve rhs + where + go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty)) + go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of + Just (SubstVar v') -> VarArg v' + Just (SubstLit l) -> LitArg l + Nothing -> VarArg v) + go te ve (Var v) = case lookupIdEnv ve v of + Just (SubstVar v') -> Var v' + Just (SubstLit l) -> Lit l + Nothing -> Var v + + -- These equations are a bit half baked, because + -- they don't deal properly wih capture. + -- But I'm sure it'll never matter... sigh. + go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e) + where + te' = delFromTyVarEnv te tyvar + + go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e) + where + ve' = delOneFromIdEnv ve v +\end{code} diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 0a7b85a..d27063e 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -28,7 +28,7 @@ import Id ( idType, getIdUnfolding, mkIdWithNewUniq, mkIdWithNewType, IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv ) -import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv ) +import SpecEnv ( lookupSpecEnv ) import OccurAnal ( occurAnalyseGlobalExpr ) import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) @@ -196,10 +196,6 @@ simplBinder env (id, occ_info) -- id1 has its type zapped id1 | empty_ty_subst = id | otherwise = mkIdWithNewType id ty' - - -- id2 has its SpecEnv zapped - id2 | isEmptySpecEnv spec_env = id1 - | otherwise = setIdSpecialisation id1 spec_env' in if not_in_scope then -- No need to clone, but we *must* zap any current substitution @@ -207,19 +203,19 @@ simplBinder env (id, occ_info) -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x let - env' = setIdEnv env (new_in_scope_ids id2, + env' = setIdEnv env (new_in_scope_ids id1, delOneFromIdEnv id_subst id) in - returnSmpl (env', id2) + returnSmpl (env', id1) else -- Must clone getUniqueSmpl `thenSmpl` \ uniq -> let - id3 = mkIdWithNewUniq id2 uniq - env' = setIdEnv env (new_in_scope_ids id3, - addOneToIdEnv id_subst id (SubstVar id3)) + id2 = mkIdWithNewUniq id1 uniq + env' = setIdEnv env (new_in_scope_ids id2, + addOneToIdEnv id_subst id (SubstVar id2)) in - returnSmpl (env', id3) + returnSmpl (env', id2) ) where ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env @@ -231,9 +227,6 @@ simplBinder env (id, occ_info) ty = idType id ty' = instantiateTy ty_subst ty - - spec_env = getIdSpecialisation id - spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId]) simplBinders env binders = mapAccumLSmpl simplBinder env binders @@ -266,33 +259,3 @@ simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar]) simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders \end{code} - -substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv -It exploits the known structure of a SpecEnv's RHS to have fewer -equations. - -\begin{code} -substSpecEnvRhs te ve rhs - = go te ve rhs - where - go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty)) - go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of - Just (SubstVar v') -> VarArg v' - Just (SubstLit l) -> LitArg l - Nothing -> VarArg v) - go te ve (Var v) = case lookupIdEnv ve v of - Just (SubstVar v') -> Var v' - Just (SubstLit l) -> Lit l - Nothing -> Var v - - -- These equations are a bit half baked, because - -- they don't deal properly wih capture. - -- But I'm sure it'll never matter... sigh. - go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e) - where - te' = delFromTyVarEnv te tyvar - - go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e) - where - ve' = delOneFromIdEnv ve v -\end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index a650417..bfe3daf 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -11,7 +11,7 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, mkFormSummary, +import CoreUnfold ( Unfolding, mkFormSummary, noUnfolding, exprIsTrivial, whnfOrBottom, inlineUnconditionally, FormSummary(..) ) @@ -21,7 +21,7 @@ import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, - addIdArity, getIdArity, + addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation, getIdDemandInfo, addIdDemandInfo ) import Name ( isExported, isLocallyDefined ) @@ -35,6 +35,7 @@ import SimplEnv import SimplMonad import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders ) import SimplUtils +import SpecEnv ( isEmptySpecEnv, substSpecEnv ) import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys, mkFunTys, splitAlgTyConApp_maybe, splitFunTys, splitFunTy_maybe, isUnpointedType @@ -1079,10 +1080,7 @@ completeBind :: SimplEnv -> InBinder -> OutId -> OutExpr -- Id and RHS -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s) -completeBind env binder@(_,occ_info) new_id new_rhs - | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" - = (env, new_binds) - +completeBind env binder@(old_id,occ_info) new_id new_rhs | atomic_rhs -- If rhs (after eta reduction) is atomic && not (isExported new_id) -- and binder isn't exported = -- Drop the binding completely @@ -1092,31 +1090,31 @@ completeBind env binder@(_,occ_info) new_id new_rhs in (env2, []) -{- This case is WRONG. It attempts to exploit knowledge that indirections - are eliminated (by OccurAnal), but they *aren't* for recursive bindings. - If this case is enabled, then - rec { local = (a,b) - global = local - ... = case global of ... - } - never gets simplified - - | atomic_rhs -- Rhs is atomic, and new_id is exported - && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False } - = -- The local variable v will be eliminated next time round - -- in favour of new_id, so it's a waste to replace all new_id's with v's - -- this time round. - -- This case is an optional improvement; saves a simplifier iteration - (env, [(new_id, eta'd_rhs)]) --} - | otherwise -- Non-atomic + -- The big deal here is that we simplify the + -- SpecEnv of the Id, if any. We used to do that in simplBinders, but + -- that didn't work because it didn't take account of the fact that + -- one of the mutually recursive group might mention one of the others + -- in its SpecEnv = let - env1 = extendEnvGivenBinding env occ_info new_id new_rhs - in + id_w_specenv | isEmptySpecEnv spec_env = new_id + | otherwise = setIdSpecialisation new_id spec_env' + + env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" + = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding + -- Still need to record the new_id with its SpecEnv + + | otherwise -- Can inline it + = extendEnvGivenBinding env occ_info id_w_specenv new_rhs + + in (env1, new_binds) where + spec_env = getIdSpecialisation old_id + spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env + (ty_subst,id_subst) = getSubstEnvs env + new_binds = [(new_id, new_rhs)] atomic_rhs = is_atomic eta'd_rhs eta'd_rhs = case lookForConstructor env new_rhs of -- 1.7.10.4