\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,
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}
%************************************************************************
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
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)
= 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}
%* *
%************************************************************************
-\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}
%************************************************************************
%************************************************************************
\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@}
\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
| 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
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}
\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}
+
%************************************************************************
%* *
\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
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
\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:
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
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
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}
projects / ghc-hetmet.git / blobdiff