module SimplEnv (
nullSimplEnv,
getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
+ emptySubstEnvs, getSubstEnvs,
bindTyVar, bindTyVars, simplTy,
-- Types
SwitchChecker,
- SimplEnv,
+ SimplEnv, SubstEnvs,
UnfoldConApp,
SubstInfo(..),
#include "HsVersions.h"
import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
- okToInline, isOneFunOcc,
+ isOneFunOcc,
BinderInfo
)
import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
)
import CoreSyn
import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
+ okToInline,
Unfolding(..), FormSummary(..),
calcUnfoldingGuidance )
import CoreUtils ( coreExprCc )
currentOrSubsumedCosts
)
import FiniteMap -- lots of things
-import Id ( getInlinePragma,
+import Id ( IdEnv, IdSet, Id,
+ getInlinePragma,
nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
- IdEnv, IdSet, Id )
+ idMustBeINLINEd
+ )
import Literal ( Literal )
import Maybes ( expectJust )
import OccurAnal ( occurAnalyseExpr )
-- Ids in the domain of the substitution are *not* in scope;
-- they *must* be substituted for the given OutArg
+type SubstEnvs = (TyVarEnv Type, IdEnv SubstInfo)
+
data SubstInfo
= SubstVar OutId -- The Id maps to an already-substituted atom
| SubstLit Literal -- ...ditto literal
setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
= SimplEnv chkr encl_cc ty_env id_env con_apps
-setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
+getSubstEnvs :: SimplEnv -> SubstEnvs
+getSubstEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) = (ty_subst, id_subst)
+
+emptySubstEnvs :: SubstEnvs
+emptySubstEnvs = (emptyTyVarEnv, nullIdEnv)
+
+setSubstEnvs :: SimplEnv -> SubstEnvs -> SimplEnv
setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
- ty_subst id_subst
+ (ty_subst, id_subst)
+ = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
+
+combineEnvs :: SimplEnv -- Get substitution from here
+ -> SimplEnv -- Get in-scope info from here
+ -> SimplEnv
+combineEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _)
+ (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
= SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
zapSubstEnvs :: SimplEnv -> SimplEnv
the RHS of an Id that's marked with an INLINE pragma. It is going to
be inlined wherever they are used, and then all the inlining will take
effect. Meanwhile, there isn't much point in doing anything to the
-as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
+as-yet-un-INLINEd rhs. Furthermore, it's very important to switch off
inlining! because
(a) not doing so will inline a worker straight back into its wrapper!
that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
simplifications happening in the body of the RHS.
+6/98 update:
+
+We don't prevent inlining from happening for identifiers
+that are marked as must-be-inlined. An example of where
+doing this is crucial is:
+
+ class Bar a => Foo a where
+ ...g....
+ {-# INLINE f #-}
+ f :: Foo a => a -> b
+ f x = ....Foo_sc1...
+
+If `f' needs to peer inside Foo's superclass, Bar, it refers
+to the appropriate super class selector, which is marked as
+must-inlineable. We don't generate any code for a superclass
+selector, so failing to inline it in the RHS of `f' will
+leave a reference to a non-existent id, with bad consequences.
+
\begin{code}
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, NoUnfolding)
+ forget (id, binder_info, rhs_info)
+ | idMustBeINLINEd id = (id, binder_info, rhs_info)
+ | otherwise = (id, noBinderInfo, NoUnfolding)
\end{code}
Just (_,_,info) -> info
Nothing -> NoUnfolding
-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))
- (_, NoUnfolding) -> (id,occ, info1)
- other -> (id,occ, info2)
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding) -- Existing
+ -> (OutId, BinderInfo, Unfolding) -- New
+ -> (OutId, BinderInfo, Unfolding)
+modifyOutEnvItem (_, _, info1) (id, occ, info2)
+ = (id, occ, case (info1, info2) of
+ (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
+ (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
+ (_, NoUnfolding) -> info1
+ other -> info2)
\end{code}
\begin{code}
-mkSimplUnfoldingGuidance chkr out_id rhs
- = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
-
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
- new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id
- (out_id, occ_info, rhs_info)
+ new_in_scope_ids = addToUFM in_scope_ids out_id (out_id, occ_info, rhs_info)
\end{code}
occ_info out_id rhs
= SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
where
- new_in_scope_ids | okToInline (whnfOrBottom form)
+ new_in_scope_ids | okToInline out_id
+ (whnfOrBottom form)
(couldBeSmallEnoughToInline out_id guidance)
occ_info
= env_with_unfolding
form = _scc_ "eegnr.form_sum"
mkFormSummary rhs
guidance = _scc_ "eegnr.guidance"
- mkSimplUnfoldingGuidance chkr out_id rhs
+ calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
-- Attach a cost centre to the RHS if necessary
rhs_w_cc | currentOrSubsumedCosts encl_cc
|| not (noCostCentreAttached (coreExprCc rhs))
= rhs
| otherwise
- = SCC encl_cc rhs
+ = Note (SCC encl_cc) rhs
\end{code}
projects / ghc-hetmet.git / blobdiff