diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 4c76eaf269cea66f61c840fb94e8272eec4b17fb..54fb90550c1030613e1fadd174370b98fad89ad4 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -9,12 +9,12 @@ syntax (namely @CoreExpr@s).
The type @Unfolding@ sits ``above'' simply-Core-expressions
unfoldings, capturing ``higher-level'' things we know about a binding,
usually things that the simplifier found out (e.g., ``it's a
-literal''). In the corner of a @SimpleUnfolding@ unfolding, you will
+literal''). In the corner of a @CoreUnfolding@ unfolding, you will
find, unsurprisingly, a Core expression.
\begin{code}
module CoreUnfold (
- SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
+ Unfolding(..), UnfoldingGuidance(..), -- types
FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
exprIsTrivial,
@@ -46,6 +46,7 @@ import BinderInfo ( BinderInfo, isOneFunOcc, isOneSafeFunOcc
)
import PragmaInfo ( PragmaInfo(..) )
import CoreSyn
+import Literal ( Literal )
import CoreUtils ( unTagBinders )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( coreExprType )
@@ -72,20 +73,20 @@ import Outputable
data Unfolding
= NoUnfolding
- | CoreUnfolding SimpleUnfolding
+ | OtherLit [Literal] -- It ain't one of these
+ | OtherCon [Id] -- It ain't one of these
- | MagicUnfolding
- Unique -- Unique of the Id whose magic unfolding this is
- MagicUnfoldingFun
-
-
-data SimpleUnfolding
- = SimpleUnfolding -- An unfolding with redundant cached information
+ | CoreUnfolding -- An unfolding with redundant cached information
FormSummary -- Tells whether the template is a WHNF or bottom
UnfoldingGuidance -- Tells about the *size* of the template.
SimplifiableCoreExpr -- Template
+ | MagicUnfolding
+ Unique -- Unique of the Id whose magic unfolding this is
+ MagicUnfoldingFun
+\end{code}
+\begin{code}
noUnfolding = NoUnfolding
mkUnfolding inline_prag expr
@@ -93,7 +94,7 @@ mkUnfolding inline_prag expr
-- strictness mangling (depends on there being no CSE)
ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
occ = occurAnalyseGlobalExpr expr
- cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ)
+ cuf = CoreUnfolding (mkFormSummary expr) ufg occ
cont = case occ of { Var _ -> cuf; _ -> cuf }
in
@@ -103,7 +104,7 @@ mkMagicUnfolding :: Unique -> Unfolding
mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
+getUnfoldingTemplate (CoreUnfolding _ _ expr)
= unTagBinders expr
getUnfoldingTemplate other = panic "getUnfoldingTemplate"
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index fdc3ecaa58be8ae8e2353e0290bd6fe6cab6ae93..7c09ad11daa92058fd2f8a7cf42abb474a1b818e 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -13,7 +13,7 @@ module ConFold ( completePrim ) where
#include "HsVersions.h"
import CoreSyn
-import CoreUnfold ( Unfolding, SimpleUnfolding )
+import CoreUnfold ( Unfolding )
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
import PrimOp ( PrimOp(..) )
@@ -90,7 +90,7 @@ completePrim env SeqOp [TyArg ty, LitArg lit]
= returnSmpl (Lit (mkMachInt 1))
completePrim env op@SeqOp args@[TyArg ty, VarArg var]
- | isEvaluated (lookupRhsInfo env var) = returnSmpl (Lit (mkMachInt 1)) -- var is eval'd
+ | isEvaluated (lookupUnfolding env var) = returnSmpl (Lit (mkMachInt 1)) -- var is eval'd
| otherwise = returnSmpl (Prim op args) -- var not eval'd
\end{code}
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 6417701517d223d29dfc7bb2f618a902985cb612..bbbd9d5b4f7f9eb102db7014d8cd364575acf79c 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -15,7 +15,7 @@ import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( Unfolding, SimpleUnfolding )
+import CoreUnfold ( Unfolding(..) )
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts, unTagBinders, coreExprType
)
@@ -330,8 +330,8 @@ completeCase env scrut alts rhs_c
-- If the scrutinee is a variable, look it up to see what we know about it
scrut_form = case scrut of
- Var v -> lookupRhsInfo env v
- other -> NoRhsInfo
+ Var v -> lookupUnfolding env v
+ other -> NoUnfolding
-- If the scrut is already eval'd then there's no worry about
-- eliminating the case
@@ -368,9 +368,10 @@ completeCase env scrut alts rhs_c
-- the scrutinee. Remember that the rhs is as yet unsimplified.
rhs1_is_scrutinee = case (scrut, rhs1) of
(Var scrut_var, Var rhs_var)
- -> case (runEager $ lookupId env rhs_var) of
- VarArg rhs_var' -> rhs_var' == scrut_var
- other -> False
+ -> case (lookupIdSubst env rhs_var) of
+ Nothing -> rhs_var == scrut_var
+ Just (SubstVar rhs_var') -> rhs_var' == scrut_var
+ other -> False
other -> False
is_elem x ys = isIn "completeCase" x ys
@@ -592,7 +593,7 @@ simplDefault
:: SimplEnv
-> OutExpr -- Simplified scrutinee
-> InDefault -- Default alternative to be completed
- -> RhsInfo -- Gives form of scrutinee
+ -> Unfolding -- Gives form of scrutinee
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
-> SmplM OutDefault
@@ -604,11 +605,11 @@ simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
info_from_this_case rhs_c
= simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
+ env2 = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
-- Add form details for the default binder
- scrut_info = lookupRhsInfo env scrut_var
- env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
+ scrut_info = lookupUnfolding env scrut_var
+ env3 = extendEnvGivenUnfolding env2 binder' occ_info scrut_info
new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
@@ -618,7 +619,7 @@ simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
info_from_this_case rhs_c
= simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
+ new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 31e6eff1758895040bd383fd8d62035e9d2882f5..18c4aec68244b3c132036e1a74c6e84693b9e94b 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -6,7 +6,7 @@
\begin{code}
module SimplEnv (
nullSimplEnv,
- getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs,
+ getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
bindTyVar, bindTyVars, simplTy,
@@ -15,9 +15,9 @@ module SimplEnv (
bindIdToAtom, bindIdToExpr,
markDangerousOccs,
- lookupRhsInfo, isEvaluated,
+ lookupUnfolding, isEvaluated,
extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvGivenRhsInfo,
+ extendEnvGivenUnfolding,
lookForConstructor,
@@ -30,7 +30,7 @@ module SimplEnv (
SwitchChecker,
SimplEnv,
UnfoldConApp,
- RhsInfo(..),
+ SubstInfo(..),
InId, InBinder, InBinding, InType,
OutId, OutBinder, OutBinding, OutType,
@@ -50,16 +50,16 @@ import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
)
import CoreSyn
import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
- Unfolding(..), SimpleUnfolding(..), FormSummary(..),
+ Unfolding(..), FormSummary(..),
calcUnfoldingGuidance )
import CoreUtils ( coreExprCc )
-import CostCentre ( CostCentre, subsumedCosts, costsAreSubsumed, noCostCentreAttached )
+import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, costsAreSubsumed, noCostCentreAttached )
import FiniteMap -- lots of things
import Id ( getInlinePragma,
nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
IdEnv, IdSet, Id )
-import Literal ( Literal{-instances-} )
+import Literal ( Literal )
import Maybes ( expectJust )
import OccurAnal ( occurAnalyseExpr )
import PprCore -- various instances
@@ -152,7 +152,8 @@ type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope
-- they *must* be substituted for the given OutArg
data SubstInfo
- = SubstArg OutArg -- The Id maps to an already-substituted atom
+ = SubstVar OutId -- The Id maps to an already-substituted atom
+ | SubstLit Literal -- ...ditto literal
| SubstExpr -- Id maps to an as-yet-unsimplified expression
(TyVarEnv Type) -- ...hence we need to capture the substitution
(IdEnv SubstInfo) -- environments too
@@ -168,17 +169,7 @@ type StuffAboutId = (OutId, -- Always has the same unique as the
-- We keep this info so we can modify it when
-- something changes.
- RhsInfo) -- Info about what it is bound to
-\end{code}
-
-The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
-
-\begin{code}
-data RhsInfo = NoRhsInfo
- | OtherLit [Literal] -- It ain't one of these
- | OtherCon [Id] -- It ain't one of these
- | OutUnfolding CostCentre
- SimpleUnfolding -- Already-simplified unfolding
+ Unfolding) -- Info about what it is bound to
\end{code}
@@ -186,7 +177,10 @@ data RhsInfo = NoRhsInfo
nullSimplEnv :: SwitchChecker -> SimplEnv
nullSimplEnv sw_chkr
- = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullConApps
+ = SimplEnv sw_chkr useCurrentCostCentre
+ (emptyTyVarSet, emptyTyVarEnv)
+ (nullIdEnv, nullIdEnv)
+ nullConApps
getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
@@ -203,6 +197,10 @@ setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
ty_subst id_subst
= SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
+
+zapSubstEnvs :: SimplEnv -> SimplEnv
+zapSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
+ = SimplEnv chkr encl_cc (in_scope_tyvars, emptyTyVarEnv) (in_scope_ids, nullIdEnv) con_apps
\end{code}
@@ -270,7 +268,7 @@ switchOffInlining :: SimplEnv -> SimplEnv
switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
= SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps
where
- forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoRhsInfo)
+ forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoUnfolding)
\end{code}
@@ -348,12 +346,12 @@ bindIdToAtom :: SimplEnv
bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
(in_id,occ_info) atom
- = SimplEnv chkr encl_cc ty_env (in_scope_ids', id_subst') con_apps
+ = SimplEnv chkr encl_cc ty_env id_env' con_apps
where
- id_subst' = addOneToIdEnv id_subst in_id (SubstArg atom)
- in_scope_ids' = case atom of
- LitArg _ -> in_scope_ids
- VarArg out_id -> modifyOccInfo in_scope_ids (uniqueOf out_id) occ_info
+ id_env' = case atom of
+ LitArg lit -> (in_scope_ids, addOneToIdEnv id_subst in_id (SubstLit lit))
+ VarArg id -> (modifyOccInfo in_scope_ids (uniqueOf id) occ_info,
+ addOneToIdEnv id_subst in_id (SubstVar id))
bindIdToExpr :: SimplEnv
-> InBinder
@@ -381,32 +379,32 @@ bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst
lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
-lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
+lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding)
lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
-lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
-lookupRhsInfo env id
+lookupUnfolding :: SimplEnv -> OutId -> Unfolding
+lookupUnfolding env id
= case lookupOutIdEnv env id of
Just (_,_,info) -> info
- Nothing -> NoRhsInfo
+ Nothing -> NoUnfolding
-modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
- -> (OutId, BinderInfo, RhsInfo)
- -> (OutId, BinderInfo, RhsInfo)
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)
+ -> (OutId, BinderInfo, Unfolding)
+ -> (OutId, BinderInfo, Unfolding)
modifyOutEnvItem (id, occ, info1) (_, _, info2)
= case (info1, info2) of
(OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
(OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
- (_, NoRhsInfo) -> (id,occ, info1)
+ (_, NoUnfolding) -> (id,occ, info1)
other -> (id,occ, info2)
\end{code}
\begin{code}
-isEvaluated :: RhsInfo -> Bool
+isEvaluated :: Unfolding -> Bool
isEvaluated (OtherLit _) = True
isEvaluated (OtherCon _) = True
-isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
+isEvaluated (CoreUnfolding ValueForm _ expr) = True
isEvaluated other = False
\end{code}
@@ -416,8 +414,8 @@ isEvaluated other = False
mkSimplUnfoldingGuidance chkr out_id rhs
= calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
-extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
-extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv
+extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
out_id occ_info rhs_info
= SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
where
@@ -630,7 +628,7 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst)
-- The "interesting" free variables we want occurrence info for are those
-- in the OutIdEnv that have only a single occurrence right now.
(fv_occ_info, template) = _scc_ "eegnr.occ-anal"
- occurAnalyseExpr is_interesting rhs
+ occurAnalyseExpr is_interesting rhs_w_cc
is_interesting v = _scc_ "eegnr.mkidset"
case lookupIdEnv in_scope_ids v of
@@ -638,15 +636,16 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst)
other -> False
-- Compute unfolding details
- rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
+ rhs_info = CoreUnfolding 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
- | otherwise = expr_cc
- where
- expr_cc = coreExprCc rhs
+ -- Attach a cost centre to the RHS if necessary
+ rhs_w_cc | isCurrentCostCentre encl_cc
+ || not (noCostCentreAttached (coreExprCc rhs))
+ = rhs
+ | otherwise
+ = SCC encl_cc rhs
\end{code}
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 80b02480c8ca77bb594f9d88b9bc09c3b996230d..85cc2fb7accfbb6fa468428701816eb3c1b0d2e4 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -21,7 +21,6 @@ module SimplMonad (
#include "HsVersions.h"
import Id ( GenId, mkSysLocal, mkIdWithNewUniq, Id )
-import CoreUnfold ( SimpleUnfolding )
import SimplEnv
import SrcLoc ( noSrcLoc )
import TyVar ( TyVar )
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index f3f2f7edaa9aa538ac38bed9a8b4a818426162c8..e365817dfcd7ffff7188c891abec3ab11a3dbe11 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -12,7 +12,6 @@ import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations,
switchIsOn, SimplifierSwitch(..), SwitchResult
)
import CoreSyn
-import CoreUnfold ( SimpleUnfolding )
import Id ( mkIdEnv, lookupIdEnv, IdEnv
)
import Maybes ( catMaybes )
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 03ee2bd1e0b2be4f4101c9e5130786f78efb45a2..c72b2c43aaf21e1f855c4005df03f1a5ffe78504 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -24,7 +24,7 @@ module SimplUtils (
import BinderInfo
import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) )
+import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) )
import Id ( idType, isBottomingId, mkSysLocal,
addInlinePragma, addIdDemandInfo,
idWantsToBeINLINEd, dataConArgTys, Id,
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index f35b42da7854d0e5a06cfa7a99ab1507abede29d..498549379b7ac3a029821a3fc3f01eed45ded52d 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -16,18 +16,17 @@ import {-# SOURCE #-} Simplify ( simplExpr )
import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- SimpleUnfolding(..),
FormSummary, whnfOrBottom,
smallEnoughToInline )
-import Specialise ( substSpecEnvRhs )
+import CoreUtils ( coreExprCc )
import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
-import CostCentre ( CostCentre, isCurrentCostCentre )
+import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
import Id ( idType, getIdInfo, getIdUnfolding,
getIdSpecialisation, setIdSpecialisation,
idMustBeINLINEd, idHasNoFreeTyVars,
mkIdWithNewUniq, mkIdWithNewType,
- elemIdEnv, isNullIdEnv, addOneToIdEnv
+ IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
)
import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
import OccurAnal ( occurAnalyseGlobalExpr )
@@ -38,7 +37,7 @@ import SimplMonad
import Type ( instantiateTy, mkTyVarTy )
import TyCon ( tyConFamilySize )
import TyVar ( TyVar, cloneTyVar,
- isEmptyTyVarEnv, addToTyVarEnv,
+ isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
addOneToTyVarSet, elementOfTyVarSet
)
import Maybes ( maybeToBool )
@@ -72,49 +71,59 @@ completeVar env var args result_ty
-- Look for an unfolding. There's a binding for the
-- thing, but perhaps we want to inline it anyway
- | ( maybeToBool maybe_unfolding_info
+ | has_unfolding
&& (not essential_unfoldings_only || idMustBeINLINEd var)
-- If "essential_unfoldings_only" is true we do no inlinings at all,
-- EXCEPT for things that absolutely have to be done
-- (see comments with idMustBeINLINEd)
&& ok_to_inline
- && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
+ && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)
+ =
+{-
+ pprTrace "Unfolding" (ppr var) $
+ simplCount `thenSmpl` \ n ->
+ (if n > 1000 then
+ pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
+ else
+ id
)
- = -- pprTrace "Unfolding" (ppr var) $
- unfold var unf_env unf_template args result_ty
-
+ (if n>4000 then
+ returnSmpl (mkGenApp (Var var) args)
+ else
+-}
+ tickUnfold var `thenSmpl_`
+ simplExpr unf_env unf_template args result_ty
| otherwise
= returnSmpl (mkGenApp (Var var') args)
where
- info_from_env = lookupOutIdEnv env var
- var' = case info_from_env of
- Just (var', _, _) -> var'
- Nothing -> var
-
- unfolding_from_id = getIdUnfolding var
+ (var', occ_info, unfolding) = case lookupOutIdEnv env var of
+ Just stuff -> stuff
+ Nothing -> (var, noBinderInfo, getIdUnfolding var)
---------- Magic unfolding stuff
- maybe_magic_result = case unfolding_from_id of
+ maybe_magic_result = case unfolding of
MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
env args
other -> Nothing
Just magic_result = maybe_magic_result
- maybe_unfolding_info
- = case (info_from_env, unfolding_from_id) of
-
- (Just (_, occ_info, OutUnfolding enc_cc unf), _)
- -> Just (occ_info, setEnclosingCC env enc_cc, unf)
-
- (_, CoreUnfolding unf)
- -> Just (noBinderInfo, env, unf)
-
- other -> Nothing
-
- Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
- SimpleUnfolding form guidance unf_template = simple_unfolding
+ ---------- Unfolding stuff
+ has_unfolding = case unfolding of
+ CoreUnfolding _ _ _ -> True
+ other -> False
+
+ CoreUnfolding form guidance unf_template = unfolding
+ unf_env = zapSubstEnvs env
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
---------- Specialisation stuff
(ty_args, remaining_args) = initialTyArgs args
@@ -130,26 +139,10 @@ completeVar env var args result_ty
small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
arg_evals = [is_evald arg | arg <- args, isValArg arg]
- is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
+ is_evald (VarArg v) = isEvaluated (lookupUnfolding env v)
is_evald (LitArg l) = True
--- Perform the unfolding
-unfold var unf_env unf_template args result_ty
- =
-{-
- simplCount `thenSmpl` \ n ->
- (if n > 1000 then
- pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
- else
- id
- )
- (if n>4000 then
- returnSmpl (mkGenApp (Var var) args)
- else
--}
- tickUnfold var `thenSmpl_`
- simplExpr unf_env unf_template args result_ty
-- costCentreOk checks that it's ok to inline this thing
@@ -162,7 +155,7 @@ unfold var unf_env unf_template args result_ty
-- regardless of whether E is a WHNF or not.
costCentreOk cc_encl cc_rhs
- = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs)
+ = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
\end{code}
@@ -184,7 +177,7 @@ simplBinder env (id, _)
&& empty_ty_subst -- No type substitution to do inside the Id
&& isNullIdEnv id_subst -- No id substitution to do inside the Id
= let
- env' = setIdEnv env (addOneToIdEnv in_scope_ids id id, id_subst)
+ env' = setIdEnv env (new_in_scope_ids id, id_subst)
in
returnSmpl (env', id)
@@ -207,7 +200,7 @@ simplBinder env (id, _)
if not_in_scope then
-- No need to clone
let
- env' = setIdEnv env (addOneToIdEnv in_scope_ids id id2, id_subst)
+ env' = setIdEnv env (new_in_scope_ids id2, id_subst)
in
returnSmpl (env', id2)
else
@@ -215,21 +208,24 @@ simplBinder env (id, _)
getUniqueSmpl `thenSmpl` \ uniq ->
let
id3 = mkIdWithNewUniq id2 uniq
- env' = setIdEnv env (addOneToIdEnv in_scope_ids id3 id3,
- addOneToIdEnv id_subst id (VarArg id3))
+ env' = setIdEnv env (new_in_scope_ids id3,
+ addOneToIdEnv id_subst id (SubstVar id3))
in
returnSmpl (env', id3)
)
where
((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
- empty_ty_subst = isEmptyTyVarEnv ty_subst
- not_in_scope = not (id `elemIdEnv` in_scope_ids)
- ty = idType id
- ty' = instantiateTy ty_subst ty
+ empty_ty_subst = isEmptyTyVarEnv ty_subst
+ not_in_scope = not (id `elemIdEnv` in_scope_ids)
- spec_env = getIdSpecialisation id
- spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
+ new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', noBinderInfo, NoUnfolding)
+
+ 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
@@ -258,3 +254,34 @@ simplTyBinder env tyvar
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 37e42fc5c9e2a6f12beb2347a1681a3b6aa59e6a..f4eef9f930460dc01cb93c0f3edba9072b8b6b6d 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, SimpleUnfolding, mkFormSummary,
+import CoreUnfold ( Unfolding, mkFormSummary,
exprIsTrivial, whnfOrBottom, inlineUnconditionally,
FormSummary(..)
)
@@ -247,16 +247,16 @@ the more sophisticated stuff.
\begin{code}
simplExpr env (Var var) args result_ty
- = case (runEager $ lookupIdSubst env var) of
+ = case lookupIdSubst env var of
Just (SubstExpr ty_subst id_subst expr)
-> simplExpr (setSubstEnvs env ty_subst id_subst) expr args result_ty
- Just (SubstArg (LitArg lit)) -- A boring old literal
+ Just (SubstLit lit) -- A boring old literal
-> ASSERT( null args )
returnSmpl (Lit lit)
- Just (SubstArg (VarArg var')) -- More interesting! An id!
+ Just (SubstVar var') -- More interesting! An id!
-> completeVar env var' args result_ty
Nothing -- Not in the substitution; hand off to completeVar
@@ -1330,9 +1330,10 @@ simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
returnEager (TyArg ty')
simplArg env arg@(VarArg id)
= case lookupIdSubst env id of
- Just (SubstArg arg') -> returnEager arg'
- Just (SubstExpr _) -> panic "simplArg"
- Nothing -> case lookupOutIdEnv env id of
+ Just (SubstVar id') -> returnEager (VarArg id')
+ Just (SubstLit lit) -> returnEager (LitArg lit)
+ Just (SubstExpr _ __) -> panic "simplArg"
+ Nothing -> case lookupOutIdEnv env id of
Just (id', _, _) -> returnEager (VarArg id')
Nothing -> returnEager arg
\end{code}
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index cb5638c739ee96209f6da07939018f7bde6ce2d3..9886e6bcf778a1772a0d07de7550c7d06d1648c0 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -6,8 +6,7 @@
\begin{code}
module Specialise (
specProgram,
- idSpecVars,
- substSpecEnvRhs
+ idSpecVars
) where
#include "HsVersions.h"
@@ -1211,33 +1210,6 @@ idSpecVars id
get_spec (Lam _ b) = get_spec b
get_spec (Var v) = v
--- substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
--- It's placed here because Specialise.lhs built that RHS, so
--- it knows its structure. (Fully general subst
-
-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 arg' -> arg'
- Nothing -> VarArg v)
- go te ve (Var v) = case lookupIdEnv ve v of
- Just (VarArg v') -> Var v'
- Just (LitArg 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
-
----------------------------------------
type SpecM a = UniqSM a
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index a9e2bce751ad920dbef771655d71de68eb7afa60..bc3f8c80125dc71a4c61925da501088d36003429 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -17,7 +17,7 @@ module SaAbsInt (
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
-import CoreUnfold ( Unfolding(..), SimpleUnfolding(..), FormSummary )
+import CoreUnfold ( Unfolding(..), FormSummary )
import CoreUtils ( unTagBinders )
import Id ( idType, getIdStrictness, getIdUnfolding,
dataConTyCon, dataConArgTys, Id
@@ -404,7 +404,7 @@ absId anal var env
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
+ (Nothing, NoStrictnessInfo, CoreUnfolding _ _ unfolding) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id