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,
)
import PragmaInfo ( PragmaInfo(..) )
import CoreSyn
+import Literal ( Literal )
import CoreUtils ( unTagBinders )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( coreExprType )
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
-- 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
mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
+getUnfoldingTemplate (CoreUnfolding _ _ expr)
= unTagBinders expr
getUnfoldingTemplate other = panic "getUnfoldingTemplate"
#include "HsVersions.h"
import CoreSyn
-import CoreUnfold ( Unfolding, SimpleUnfolding )
+import CoreUnfold ( Unfolding )
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
import PrimOp ( PrimOp(..) )
= 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}
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
)
-- 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
-- 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
:: 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
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' ->
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')
\begin{code}
module SimplEnv (
nullSimplEnv,
- getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs,
+ getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
bindTyVar, bindTyVars, simplTy,
bindIdToAtom, bindIdToExpr,
markDangerousOccs,
- lookupRhsInfo, isEvaluated,
+ lookupUnfolding, isEvaluated,
extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvGivenRhsInfo,
+ extendEnvGivenUnfolding,
lookForConstructor,
SwitchChecker,
SimplEnv,
UnfoldConApp,
- RhsInfo(..),
+ SubstInfo(..),
InId, InBinder, InBinding, InType,
OutId, OutBinder, OutBinding, OutType,
)
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
-- 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
-- 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}
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)
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}
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}
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
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}
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
-- 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
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}
#include "HsVersions.h"
import Id ( GenId, mkSysLocal, mkIdWithNewUniq, Id )
-import CoreUnfold ( SimpleUnfolding )
import SimplEnv
import SrcLoc ( noSrcLoc )
import TyVar ( TyVar )
switchIsOn, SimplifierSwitch(..), SwitchResult
)
import CoreSyn
-import CoreUnfold ( SimpleUnfolding )
import Id ( mkIdEnv, lookupIdEnv, IdEnv
)
import Maybes ( catMaybes )
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,
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 )
import Type ( instantiateTy, mkTyVarTy )
import TyCon ( tyConFamilySize )
import TyVar ( TyVar, cloneTyVar,
- isEmptyTyVarEnv, addToTyVarEnv,
+ isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
addOneToTyVarSet, elementOfTyVarSet
)
import Maybes ( maybeToBool )
-- 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
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
-- 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}
&& 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)
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
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
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}
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
+import CoreUnfold ( Unfolding, mkFormSummary,
exprIsTrivial, whnfOrBottom, inlineUnconditionally,
FormSummary(..)
)
\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
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}
\begin{code}
module Specialise (
specProgram,
- idSpecVars,
- substSpecEnvRhs
+ idSpecVars
) where
#include "HsVersions.h"
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
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
(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
projects / ghc-hetmet.git / commitdiff