markDangerousOccs,
lookupRhsInfo, lookupOutIdEnv, isEvaluated,
extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvForRecBinding, extendEnvGivenRhsInfo,
+ extendEnvGivenRhsInfo, extendEnvGivenInlining,
lookForConstructor,
- getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
+ getSwitchChecker, switchIsSet, getSimplIntSwitch,
+ switchOffInlining, setCaseScrutinee,
setEnclosingCC, getEnclosingCC,
IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
+#endif
import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo,
BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
SimplifierSwitch(..), SwitchResult(..)
)
import CoreSyn
-import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
+import CoreUnfold ( mkFormSummary, okToInline, couldBeSmallEnoughToInline,
Unfolding(..), UfExpr, RdrName,
SimpleUnfolding(..), FormSummary(..),
calcUnfoldingGuidance, UnfoldingGuidance(..)
)
import CoreUtils ( coreExprCc, unTagBinders )
-import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
+import CostCentre ( CostCentre, subsumedCosts, noCostCentreAttached )
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
- applyTypeEnvToId,
+ applyTypeEnvToId, getInlinePragma,
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
- SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
+ SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) )
import Literal ( isNoRepLit, Literal{-instances-} )
import Maybes ( maybeToBool, expectJust )
import Name ( isLocallyDefined )
import OccurAnal ( occurAnalyseExpr )
-import Outputable ( Outputable(..){-instances-} )
+import Outputable ( PprStyle(..), Outputable(..){-instances-} )
import PprCore -- various instances
-import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar )
import Pretty
-import Type ( eqTy, applyTypeEnvToTy )
+import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
- SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
+ SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
+ SYN_IE(TyVar)
)
-import Unique ( Unique{-instance Outputable-} )
-import UniqFM ( addToUFM_C, ufmToList, eltsUFM
- )
---import UniqSet -- lots of things
+import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
+import UniqFM ( addToUFM, addToUFM_C, ufmToList )
import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
-import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
+import Util ( SYN_IE(Eager), appEager, returnEager, runEager,
+ zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
-type TypeEnv = TyVarEnv Type
-cmpType = panic "cmpType (SimplEnv)"
\end{code}
%************************************************************************
nullSimplEnv :: SwitchChecker -> SimplEnv
nullSimplEnv sw_chkr
- = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
+ = SimplEnv sw_chkr subsumedCosts nullTyVarEnv nullIdEnv nullIdEnv nullConApps
combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
= expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-- Crude, but simple
-switchOffInlining :: SimplEnv -> SimplEnv
-switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+setCaseScrutinee :: SimplEnv -> SimplEnv
+setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
= SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
where
- chkr' EssentialUnfoldingsOnly = SwBool True
- chkr' other = chkr other
+ chkr' SimplCaseScrutinee = SwBool True
+ chkr' other = chkr other
+\end{code}
+
+@switchOffInlining@ is used to prepare the environment for simplifying
+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
+inlining! because
+ (a) not doing so will inline a worker straight back into its wrapper!
+
+and (b) Consider the following example
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+ Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+ and thence copied multiple times when g is inlined.
+
+ Andy disagrees! Example:
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+ Problem: any won't get deforested, and so if it's exported and
+ the importer doesn't use the inlining, (eg passes it as an arg)
+ then we won't get deforestation at all.
+ We havn't solved this problem yet!
+
+We prepare the envt by simply discarding the out_id_env, which has
+all the unfolding info. At one point we did it by modifying the chkr so
+that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
+simplifications happening in the body of the RHS.
+
+\begin{code}
+switchOffInlining :: SimplEnv -> SimplEnv
+switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+type TypeEnv = TyVarEnv Type
type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
where
new_ty_env = growTyVarEnvList ty_env pairs
-simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
-simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id
+simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty)
+simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
\end{code}
%************************************************************************
\end{code}
\begin{code}
-lookupId :: SimplEnv -> Id -> OutArg
+lookupId :: SimplEnv -> Id -> Eager ans OutArg
lookupId (SimplEnv _ _ _ in_id_env _ _) id
= case (lookupIdEnv in_id_env id) of
- Just atom -> atom
- Nothing -> VarArg id
+ Just atom -> returnEager atom
+ Nothing -> returnEager (VarArg id)
\end{code}
\begin{code}
extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
(in_id,occ_info) atom
- = SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
+ = 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)
| 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
-> (OutId, BinderInfo, RhsInfo)
-> (OutId, BinderInfo, RhsInfo)
modifyOutEnvItem (id, occ, info1) (_, _, info2)
- = (id, occ, new_info)
- where
- new_info = case (info1, info2) of
- (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
- (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
- (_, NoRhsInfo) -> info1
- other -> 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)
+ other -> (id,occ, info2)
\end{code}
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}
-@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:
-@
- type Array_type b = Array Int b;
- type Descr_type = (Int,Int);
-
- tabulate :: (Int -> x) -> Descr_type -> Array_type x;
- tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
-
- f_iaamain a_xs=
- let {
- f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
- f_aareorder a_index a_ar=
- let {
- f_aareorder' a_i= a_ar ! (a_index ! a_i)
- } in tabulate f_aareorder' (bounds a_ar);
- r_index=tabulate ((+) 1) (1,1);
- arr = listArray (1,1) a_xs;
- arg = f_aareorder r_index arr
- } in elems arg
-@
-Now, when the RHS of arg gets simplified, we inline f_aareorder to get
-@
- arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
- in tabulate f_aareorder' (bounds arr)
-@
-Note that r_index is not inlined, because it was bound to a_index which
-occurs inside a lambda.
-
-Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
-then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
-analyse it, we won't spot the inside-lambda property of r_index, so r_index
-will get inlined inside the lambda. AARGH.
-Solution: when we occurrence-analyse the new RHS we have to go back
-and modify the info recorded in the UnfoldEnv for the free vars
-of the RHS. In the example we'd go back and record that r_index is now used
-inside a lambda.
\begin{code}
-extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenNewRhs env out_id rhs
- = extendEnvGivenBinding env noBinderInfo out_id rhs
-
-extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- occ_info out_id rhs
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
- where
- new_con_apps = extendConApps con_apps out_id rhs
- new_out_id_env = case guidance of
- UnfoldNever -> out_id_env -- No new stuff to put in
- other -> out_id_env_with_unfolding
-
- -- If there is an unfolding, we add rhs-info for out_id,
- -- *and* modify the occ info for rhs's interesting free variables.
- --
- -- If the out_id is already in the OutIdEnv, then just replace the
- -- unfolding, leaving occurrence info alone (this must then
- -- be a call via extendEnvGivenNewRhs).
- out_id_env_with_unfolding = foldl modifyOccInfo env1 full_fv_occ_info
- -- full_fv_occ_info combines the occurrence of the current binder
- -- with the occurrences of its RHS's free variables.
- full_fv_occ_info = [ (uniq, fv_occ `andBinderInfo` occ_info)
- | (uniq,fv_occ) <- ufmToList fv_occ_info
- ]
- env1 = addToUFM_C modifyOutEnvItem out_id_env out_id
- (out_id, occ_info, rhs_info)
-
- -- Occurrence-analyse the RHS
- -- 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) = occurAnalyseExpr interesting_fvs rhs
- interesting_fvs = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
-
- -- Compute unfolding details
- rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
- form_summary = mkFormSummary rhs
-
- 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
-
-{- 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 taht
-
-
- 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.
--}
-
-extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- (out_id, ((_,occ_info), old_rhs))
- = 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)
-
-
mkSimplUnfoldingGuidance chkr out_id rhs
- = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs
- where
- inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
+ = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
\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}
+@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:
+@
+ type Array_type b = Array Int b;
+ type Descr_type = (Int,Int);
+
+ tabulate :: (Int -> x) -> Descr_type -> Array_type x;
+ tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
+
+ f_iaamain a_xs=
+ let {
+ f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
+ f_aareorder a_index a_ar=
+ let {
+ f_aareorder' a_i= a_ar ! (a_index ! a_i)
+ } in tabulate f_aareorder' (bounds a_ar);
+ r_index=tabulate ((+) 1) (1,1);
+ arr = listArray (1,1) a_xs;
+ arg = f_aareorder r_index arr
+ } in elems arg
+@
+Now, when the RHS of arg gets simplified, we inline f_aareorder to get
+@
+ arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
+ in tabulate f_aareorder' (bounds arr)
+@
+Note that r_index is not inlined, because it was bound to a_index which
+occurs inside a lambda.
+
+Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
+then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
+analyse it, we won't spot the inside-lambda property of r_index, so r_index
+will get inlined inside the lambda. AARGH.
+
+Solution: when we occurrence-analyse the new RHS we have to go back
+and modify the info recorded in the UnfoldEnv for the free vars
+of the RHS. In the example we'd go back and record that r_index is now used
+inside a lambda.
+
+\begin{code}
+extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
+extendEnvGivenNewRhs env out_id rhs
+ = extendEnvGivenBinding env noBinderInfo out_id rhs
+extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
+extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ 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 | okToInline form occ_info (couldBeSmallEnoughToInline guidance)
+ = 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
+
+ -- Modify the occ info for rhs's interesting free variables.
+ out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
+ foldl modifyOccInfo env1 full_fv_occ_info
+ -- NB: full_fv_occ_info *combines* the occurrence of the current binder
+ -- with the occurrences of its RHS's free variables. That's to take
+ -- account of:
+ -- let a = \x -> BIG in
+ -- let b = \f -> f a
+ -- in ...b...b...b...
+ -- Here "a" occurs exactly once. "b" simplifies to a small value.
+ -- So "b" will be inlined at each call site, and there's a good chance
+ -- that "a" will too. So we'd better modify "a"s occurrence info to
+ -- record the fact that it can now occur many times by virtue that "b" can.
+
+ full_fv_occ_info = _scc_ "eegnr.full_fv"
+ [ (uniq, fv_occ `andBinderInfo` occ_info)
+ | (uniq, fv_occ) <- ufmToList fv_occ_info
+ ]
+
+ -- Add an unfolding and rhs_info for the new Id.
+ -- If the out_id is already in the OutIdEnv (which can happen if
+ -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
+ -- then just replace the unfolding, leaving occurrence info alone.
+ env1 = _scc_ "eegnr.modify_out"
+ addToUFM_C modifyOutEnvItem out_id_env out_id
+ (out_id, occ_info, rhs_info)
+
+ -- Occurrence-analyse the RHS
+ -- 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
+
+ is_interesting v = _scc_ "eegnr.mkidset"
+ case lookupIdEnv out_id_env v of
+ Just (_, OneOcc _ _ _ _ _, _) -> True
+ other -> False
+
+ -- Compute unfolding details
+ 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
+ | otherwise = expr_cc
+ where
+ expr_cc = coreExprCc rhs
+\end{code}
projects / ghc-hetmet.git / blobdiff