Commit 63592052 authored by simonpj's avatar simonpj
Browse files

[project @ 1998-03-12 17:27:22 by simonpj]

Simplifier fixed - I think!
parent cccb9a1a
......@@ -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"
......
......@@ -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}
......
......@@ -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')
......
......@@ -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}
......@@ -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 )
......
......@@ -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 )
......
......@@ -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,
......
......@@ -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}
......@@ -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)