X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=9e59327f5ece294a1698c2b15d51015868ddbc61;hb=996573cd62a9dab5b3a7f7ab85567507422601bb;hp=6656d566bbf3b089ec34e7468f78c40edc30d2f5;hpb=6cd71a70ff1abdcfd36130a420405de575f0594d;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 6656d56..9e59327 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -4,24 +4,20 @@ \section[SimplEnv]{Environment stuff for the simplifier} \begin{code} -#include "HsVersions.h" - module SimplEnv ( nullSimplEnv, combineSimplEnv, pprSimplEnv, -- debugging only - extendTyEnv, extendTyEnvList, - simplTy, simplTyInId, + bindTyVar, bindTyVars, simplTy, - extendIdEnvWithAtom, extendIdEnvWithAtoms, - extendIdEnvWithClone, extendIdEnvWithClones, - lookupId, + lookupId, bindIdToAtom, + getSubstEnvs, setTyEnv, setIdEnv, notInScope, markDangerousOccs, lookupRhsInfo, lookupOutIdEnv, isEvaluated, extendEnvGivenBinding, extendEnvGivenNewRhs, - extendEnvGivenRhsInfo, + extendEnvGivenRhsInfo, extendEnvGivenInlining, lookForConstructor, @@ -31,63 +27,52 @@ module SimplEnv ( setEnclosingCC, getEnclosingCC, -- Types - SYN_IE(SwitchChecker), + SwitchChecker, SimplEnv, - SYN_IE(InIdEnv), SYN_IE(InTypeEnv), + InIdEnv, InTypeEnv, UnfoldConApp, RhsInfo(..), - SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), - SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType), + InId, InBinder, InBinding, InType, + OutId, OutBinder, OutBinding, OutType, - SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg), - SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg) + InExpr, InAlts, InDefault, InArg, + OutExpr, OutAlts, OutDefault, OutArg ) where -IMP_Ubiq(){-uitous-} - -IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop +#include "HsVersions.h" -import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, - BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC +import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, + okToInline, + BinderInfo {-instances, too-} ) import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, SimplifierSwitch(..), SwitchResult(..) ) import CoreSyn -import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup, - Unfolding(..), UfExpr, RdrName, - SimpleUnfolding(..), FormSummary(..), - calcUnfoldingGuidance, UnfoldingGuidance(..) - ) -import CoreUtils ( coreExprCc, unTagBinders ) -import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached ) +import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, + Unfolding(..), SimpleUnfolding(..), FormSummary(..), + calcUnfoldingGuidance ) +import CoreUtils ( coreExprCc ) +import CostCentre ( CostCentre, subsumedCosts, noCostCentreAttached ) import FiniteMap -- lots of things -import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd, - applyTypeEnvToId, getInlinePragma, - nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly, - SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) ) -import Literal ( isNoRepLit, Literal{-instances-} ) -import Maybes ( maybeToBool, expectJust ) -import Name ( isLocallyDefined ) +import Id ( getInlinePragma, + nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv, + addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly, + IdEnv, IdSet, Id ) +import Literal ( Literal{-instances-} ) +import Maybes ( expectJust ) import OccurAnal ( occurAnalyseExpr ) -import Outputable ( PprStyle(..), Outputable(..){-instances-} ) import PprCore -- various instances -import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, - SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} , - SYN_IE(TyVar) +import Type ( instantiateTy, Type ) +import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList, + TyVarSet, emptyTyVarSet, + TyVar ) -import Unique ( Unique{-instance Outputable-} ) -import UniqFM ( addToUFM_C, ufmToList, Uniquable(..) - ) -import Usage ( SYN_IE(UVar), GenUsage{-instances-} ) -import Util ( SYN_IE(Eager), appEager, returnEager, runEager, - zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) ) - +import Unique ( Unique{-instance Outputable-}, Uniquable(..) ) +import UniqFM ( addToUFM, addToUFM_C, ufmToList ) +import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList ) +import Outputable \end{code} %************************************************************************ @@ -140,6 +125,22 @@ Id. Unfoldings in the Id itself are used only for imported things inside the Ids, etc.). \begin{code} +type InTypeEnv = (TyVarSet, -- In-scope tyvars (in result) + TyVarEnv Type) -- Type substitution + -- If t is in the in-scope set, it certainly won't be + -- in the domain of the substitution, and vice versa + +type InIdEnv = (IdEnv Id, -- In-scope Ids (in result) + IdEnv OutArg) -- Id substitution + -- The in-scope set is represented by an IdEnv, because + -- we use it to propagate pragma info etc from binding + -- site to occurrences. + + -- The substitution usually maps an Id to its clone, + -- but if the orig defn is a let-binding, and + -- the RHS of the let simplifies to an atom, + -- we just add the binding to the substitution and elide the let. + data SimplEnv = SimplEnv SwitchChecker @@ -153,7 +154,7 @@ data SimplEnv nullSimplEnv :: SwitchChecker -> SimplEnv nullSimplEnv sw_chkr - = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps + = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullIdEnv nullConApps combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) @@ -161,6 +162,17 @@ combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" + +getSubstEnvs :: SimplEnv -> (InTypeEnv, InIdEnv) +getSubstEnvs (SimplEnv _ _ ty_env in_id_env _ _) = (ty_env, in_id_env) + +setTyEnv :: SimplEnv -> InTypeEnv -> SimplEnv +setTyEnv (SimplEnv chkr encl_cc _ in_id_env out_id_env con_apps) ty_env + = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps + +setIdEnv :: SimplEnv -> InIdEnv -> SimplEnv +setIdEnv (SimplEnv chkr encl_cc ty_env _ out_id_env con_apps) id_env + = SimplEnv chkr encl_cc ty_env id_env out_id_env con_apps \end{code} @@ -251,24 +263,25 @@ getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = en %* * %************************************************************************ -\begin{code} -type TypeEnv = TyVarEnv Type -type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes +These two "bind" functions extend the tyvar substitution. +They don't affect what tyvars are in scope. -extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps +\begin{code} +bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv +bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) in_id_env out_id_env con_apps) tyvar ty + = SimplEnv chkr encl_cc (tyvars, new_ty_subst) in_id_env out_id_env con_apps where - new_ty_env = addOneToTyVarEnv ty_env tyvar ty + new_ty_subst = addToTyVarEnv ty_subst tyvar ty -extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps +bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv +bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) in_id_env out_id_env con_apps) extra_subst + = SimplEnv chkr encl_cc (tyvars, new_ty_subst) in_id_env out_id_env con_apps where - new_ty_env = growTyVarEnvList ty_env pairs + new_ty_subst = ty_subst `plusTyVarEnv` extra_subst +\end{code} -simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty) -simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id) +\begin{code} +simplTy (SimplEnv _ _ (_, ty_subst) _ _ _) ty = returnEager (instantiateTy ty_subst ty) \end{code} %************************************************************************ @@ -278,68 +291,48 @@ simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_en %************************************************************************ \begin{code} -type InIdEnv = IdEnv OutArg -- Maps InIds to their value - -- Usually this is just the cloned Id, but if - -- if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just bind the variable to that atom, and - -- elide the let. -\end{code} - -\begin{code} lookupId :: SimplEnv -> Id -> Eager ans OutArg -lookupId (SimplEnv _ _ _ in_id_env _ _) id - = case (lookupIdEnv in_id_env id) of +lookupId (SimplEnv _ _ _ (in_scope_ids, id_subst) _ _) id + = case lookupIdEnv id_subst id of Just atom -> returnEager atom - Nothing -> returnEager (VarArg id) + Nothing -> case lookupIdEnv in_scope_ids id of + Just id' -> returnEager (VarArg id') + Nothing -> returnEager (VarArg id) +\end{code} + +notInScope forgets that the specified binder is in scope. +It is used when we decide to bind a let(rec) bound thing to +an atom, *after* the Id has been added to the in-scope mapping by simplBinder. + +\begin{code} +notInScope :: SimplEnv -> OutBinder -> SimplEnv +notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env con_apps) id + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) out_id_env con_apps + where + new_in_scope_ids = delOneFromIdEnv in_scope_ids id \end{code} +These "bind" functions extend the Id substitution. + \begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder - -> OutArg{-Val args only, please-} - -> SimplEnv +bindIdToAtom :: SimplEnv + -> InBinder + -> OutArg -- Val args only, please + -> SimplEnv -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) +bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env con_apps) (in_id,occ_info) atom = case atom of LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env - (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps ---SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps - where - new_in_id_env = addOneToIdEnv in_id_env in_id atom -{- - new_out_id_env = case atom of - LitArg _ -> out_id_env - VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info) --} - -extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv -extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) - - -extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv - -extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (in_id,_) out_id - = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps + (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) + con_apps where - new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id) - -extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv -extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - in_binders out_ids - = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps - where - new_in_id_env = growIdEnvList in_id_env bindings - bindings = zipEqual "extendIdEnvWithClones" - [id | (id,_) <- in_binders] - (map VarArg out_ids) + new_in_id_env = (in_scope_ids, addOneToIdEnv id_subst in_id atom) \end{code} + %************************************************************************ %* * \subsubsection{The @OutIdEnv@} @@ -352,7 +345,6 @@ both locally-bound ones, and perhaps some imported ones too. \begin{code} type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo) - \end{code} The "Id" part is just so that we can recover the domain of the mapping, which @@ -369,8 +361,11 @@ data RhsInfo = NoRhsInfo | OtherLit [Literal] -- It ain't one of these | OtherCon [Id] -- It ain't one of these + -- InUnfolding is used for let(rec) bindings that + -- are *definitely* going to be inlined. + -- We record the un-simplified RHS and drop the binding | InUnfolding SimplEnv -- Un-simplified unfolding - SimpleUnfolding -- (need to snag envts therefore) + SimplifiableCoreExpr -- (need to snag envts therefore) | OutUnfolding CostCentre SimpleUnfolding -- Already-simplified unfolding @@ -400,7 +395,6 @@ modifyOutEnvItem (id, occ, info1) (_, _, info2) isEvaluated :: RhsInfo -> Bool isEvaluated (OtherLit _) = True isEvaluated (OtherCon _) = True -isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True isEvaluated other = False \end{code} @@ -435,6 +429,15 @@ markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) a \end{code} +\begin{code} +extendEnvGivenInlining :: SimplEnv -> Id -> BinderInfo -> InExpr -> SimplEnv +extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) + id occ_info rhs + = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps + where + new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs) +\end{code} + %************************************************************************ %* * @@ -469,12 +472,13 @@ extendConApps con_apps id other_rhs = con_apps \end{code} \begin{code} -lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args +lookForConstructor env@(SimplEnv _ _ _ _ _ con_apps) (Con con args) + | switchIsSet env SimplReuseCon = case lookupFM con_apps (UCA con val_args) of Nothing -> Nothing Just assocs -> case [id | (tys, id) <- assocs, - and (zipWith eqTy tys ty_args)] + and (zipWith (==) tys ty_args)] of [] -> Nothing (id:_) -> Just id @@ -482,6 +486,7 @@ lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args val_args = filter isValArg args -- Literals and Ids ty_args = [ty | TyArg ty <- args] -- Just types +lookForConstructor env other = Nothing \end{code} NB: In @lookForConstructor@ we used (before Apr 94) to have a special case @@ -508,60 +513,34 @@ it, so we can use it for a @FiniteMap@ key. \begin{code} instance Eq UnfoldConApp where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord UnfoldConApp where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 UnfoldConApp where - cmp = cmp_app + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmp_app a b cmp_app (UCA c1 as1) (UCA c2 as2) - = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 + = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2 where - -- ToDo: make an "instance Ord3 CoreArg"??? + -- ToDo: make an "instance Ord CoreArg"??? - cmp_arg (VarArg x) (VarArg y) = x `cmp` y - cmp_arg (LitArg x) (LitArg y) = x `cmp` y - cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" - cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" + cmp_arg (VarArg x) (VarArg y) = x `compare` y + cmp_arg (LitArg x) (LitArg y) = x `compare` y + cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs" cmp_arg x y - | tag x _LT_ tag y = LT_ - | otherwise = GT_ + | tag x _LT_ tag y = LT + | otherwise = GT where tag (VarArg _) = ILIT(1) tag (LitArg _) = ILIT(2) tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" - tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" \end{code} - - - -============================ OLD ================================ - This version was used when we use the *simplified* RHS of a - let as the thing's unfolding. The has the nasty property described - in the following comments. Much worse, it can fail to terminate - on recursive things. Consider - - letrec f = \x -> let z = f x' in ... - - in - let n = f y - in - case n of { ... } - - If we bind n to its *simplified* RHS, we then *re-simplify* it when - we inline n. Then we may well inline f; and then the same thing - happens with z! - - @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS of a new binding. There is a horrid case we have to take care about, due to Andr\'e Santos: @@ -612,9 +591,14 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con occ_info out_id rhs = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps where - new_out_id_env = case guidance of - UnfoldNever -> out_id_env -- No new stuff to put in - other -> out_id_env_with_unfolding + new_out_id_env | okToInline (whnfOrBottom form) + (couldBeSmallEnoughToInline out_id guidance) + occ_info + = out_id_env_with_unfolding + | otherwise + = out_id_env + -- Don't bother to extend the OutIdEnv unless there is some possibility + -- that the thing might be inlined. We check this by calling okToInline suitably. new_con_apps = _scc_ "eegnr.conapps" extendConApps con_apps out_id rhs @@ -654,15 +638,15 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con is_interesting v = _scc_ "eegnr.mkidset" case lookupIdEnv out_id_env v of - Just (_, OneOcc _ _ _ _ _, _) -> True - other -> False + Just (_, occ, _) -> isOneOcc occ + other -> False -- Compute unfolding details - rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template) - form_summary = _scc_ "eegnr.form_sum" - mkFormSummary rhs - guidance = _scc_ "eegnr.guidance" - mkSimplUnfoldingGuidance chkr out_id rhs + rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template) + form = _scc_ "eegnr.form_sum" + mkFormSummary rhs + guidance = _scc_ "eegnr.guidance" + mkSimplUnfoldingGuidance chkr out_id rhs -- Compute cost centre for thing unf_cc | noCostCentreAttached expr_cc = encl_cc @@ -670,115 +654,3 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con where expr_cc = coreExprCc rhs \end{code} - - - - -========================== OLD [removed SLPJ March 97] ==================== - -I removed the attempt to inline recursive bindings when I discovered -a program that made the simplifier loop (nofib/spectral/hartel/typecheck/Main.hs) - -The nasty case is this: - - letrec f = \x -> let z = f x' in ... - - in - let n = f y - in - case n of { ... } - -If we bind n to its *simplified* RHS, we then *re-simplify* it when we -inline n. Then we may well inline f; and then the same thing happens -with z! - -Recursive bindings -~~~~~~~~~~~~~~~~~~ -We need to be pretty careful when extending -the environment with RHS info in recursive groups. - -Here's a nasty example: - - letrec r = f x - t = r - x = ...t... - in - ...t... - -Here, r occurs exactly once, so we may reasonably inline r in t's RHS. -But the pre-simplified t's rhs is an atom, r, so we may also decide to -inline t everywhere. But if we do *both* these reasonable things we get - - letrec r = f x - t = f x - x = ...r... - in - ...t... - -Bad news! (f x) is duplicated! (The t in the body doesn't get -inlined because by the time the recursive group is done we see that -t's RHS isn't an atom.) - -Our solution is this: - (a) we inline un-simplified RHSs, and then simplify - them in a clone-only environment. - (b) we inline only variables and values -This means that - - - r = f x ==> r = f x - t = r ==> t = r - x = ...t... ==> x = ...r... - in in - t r - -Now t is dead, and we're home. - -Most silly x=y bindings in recursive group will go away. But not all: - - let y = 1:x - x = y - -Here, we can't inline x because it's in an argument position. so we'll just replace -with a clone of y. Instead we'll probably inline y (a small value) to give - - let y = 1:x - x = 1:y - -which is OK if not clever. - - - -\begin{code} -{- -extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (out_id, ((_,occ_info), old_rhs)) - = case (form_summary, guidance) of - (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in - (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps - (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps - other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable - --- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps - where -{- - new_out_id_env = case (form_summary, guidance) of - (_, UnfoldNever) -> out_id_env -- No new stuff to put in - (ValueForm, _) -> out_id_env_with_unfolding - (VarForm, _) -> out_id_env_with_unfolding - other -> out_id_env -- Not a value or variable --} - -- If there is an unfolding, we add rhs-info for out_id, - -- No need to modify occ info because RHS is pre-simplification - out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id - (out_id, occ_info, rhs_info) - - -- Compute unfolding details - -- Note that we use the "old" environment, that just has clones of the rec-bound vars, - -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once. - -- Only if the thing is still small enough next time round will we inline again. - rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs) - form_summary = mkFormSummary old_rhs - guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs) --} -\end{code}