%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplEnv]{Environment stuff for the simplifier}
#include "HsVersions.h"
module SimplEnv (
- nullSimplEnv,
+ nullSimplEnv, combineSimplEnv,
pprSimplEnv, -- debugging only
---UNUSED: getInEnvs,
- replaceInEnvs, nullInEnvs,
-
- nullTyVarEnv,
extendTyEnv, extendTyEnvList,
simplTy, simplTyInId,
- extendIdEnvWithAtom, extendIdEnvWithAtomList,
- extendIdEnvWithInlining,
+ extendIdEnvWithAtom, extendIdEnvWithAtoms,
extendIdEnvWithClone, extendIdEnvWithClones,
lookupId,
- extendUnfoldEnvGivenRhs,
---OLD: extendUnfoldEnvWithRecInlinings,
- extendUnfoldEnvGivenFormDetails,
- extendUnfoldEnvGivenConstructor,
- lookForConstructor,
- lookupUnfolding, filterUnfoldEnvForInlines,
- getSwitchChecker, switchIsSet,
+ markDangerousOccs,
+ lookupRhsInfo, lookupOutIdEnv, isEvaluated,
+ extendEnvGivenBinding, extendEnvGivenNewRhs,
+ extendEnvForRecBinding, extendEnvGivenRhsInfo,
+
+ lookForConstructor,
---UNUSED: getEnclosingCC,
- setEnclosingCC,
+ getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
- mkFormSummary,
+ setEnclosingCC, getEnclosingCC,
-- Types
- SwitchChecker(..),
- SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..),
- FormSummary(..), EnclosingCcDetails(..),
- InIdEnv(..), IdVal(..), InTypeEnv(..),
- UnfoldEnv, UnfoldItem, UnfoldConApp,
-
- -- re-exported from BinderInfo
- BinderInfo(..),
- FunOrArg, DuplicationDanger, InsideSCC, -- sigh
-
- InId(..), InBinder(..), InType(..), InBinding(..), InUniType(..),
- OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..),
-
- InExpr(..), InAtom(..), InAlts(..), InDefault(..), InArg(..),
- OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..),
-
- -- and to make the interface self-sufficient...
- BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom,
- CoreCaseAlternatives, CoreExpr, Id,
- IdEnv(..), UniqFM, Unique,
- MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType
-
- IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId)
- IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling
+ SYN_IE(SwitchChecker),
+ SimplEnv,
+ SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
+ UnfoldConApp,
+ RhsInfo(..),
+
+ SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType),
+ SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
+
+ SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg),
+ SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg)
) where
-IMPORT_Trace
+IMP_Ubiq(){-uitous-}
-import AbsPrel ( buildId )
-import AbsUniType ( applyTypeEnvToTy, getUniDataTyCon, cmpUniType )
-import Bag ( emptyBag, Bag )
-import BasicLit ( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only
-import BinderInfo
-import CmdLineOpts ( switchIsOn, intSwitchSet,
- SimplifierSwitch(..), SwitchResult
+IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
+
+import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo,
+ BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
)
import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
-import CostCentre
-import FiniteMap
-import Id ( getIdUnfolding, eqId, cmpId, applyTypeEnvToId,
- getIdUniType, getIdStrictness, isWorkerId,
- isBottomingId
+import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
+import CoreSyn
+import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
+ Unfolding(..), SimpleUnfolding(..), FormSummary(..),
+ mkSimpleUnfolding,
+ calcUnfoldingGuidance, UnfoldingGuidance(..)
)
-import IdEnv
-import IdInfo
-import MagicUFs
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
+import CoreUtils ( coreExprCc, unTagBinders )
+import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
+import FiniteMap -- lots of things
+import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
+ applyTypeEnvToId,
+ nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
+ addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
+ SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
+import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
+import Literal ( isNoRepLit, Literal{-instances-} )
+import Maybes ( maybeToBool, expectJust )
+import Name ( isLocallyDefined )
import OccurAnal ( occurAnalyseExpr )
-import PlainCore -- for the "Out*" types and things
-import Pretty -- debugging only
-import SimplUtils ( simplIdWantsToBeINLINEd )
-import TaggedCore -- for the "In*" types and things
-import TyVarEnv
-import UniqFM ( lookupDirectlyUFM, addToUFM_Directly, ufmToList )
-import UniqSet
-import Util
+import Outputable ( Outputable(..){-instances-} )
+import PprCore -- various instances
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType, GenTyVar )
+import Pretty
+import Type ( eqTy, applyTypeEnvToTy )
+import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
+ SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
+ )
+import Unique ( Unique{-instance Outputable-} )
+import UniqFM ( addToUFM_C, ufmToList, eltsUFM
+ )
+--import UniqSet -- lots of things
+import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
+import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
+
+type TypeEnv = TyVarEnv Type
+cmpType = panic "cmpType (SimplEnv)"
\end{code}
%************************************************************************
%* *
%************************************************************************
+\begin{code}
+type InId = Id -- Not yet cloned
+type InBinder = (InId, BinderInfo)
+type InType = Type -- Ditto
+type InBinding = SimplifiableCoreBinding
+type InExpr = SimplifiableCoreExpr
+type InAlts = SimplifiableCoreCaseAlts
+type InDefault = SimplifiableCoreCaseDefault
+type InArg = SimplifiableCoreArg
+
+type OutId = Id -- Cloned
+type OutBinder = Id
+type OutType = Type -- Cloned
+type OutBinding = CoreBinding
+type OutExpr = CoreExpr
+type OutAlts = CoreCaseAlts
+type OutDefault = CoreCaseDefault
+type OutArg = CoreArg
+
+type SwitchChecker = SimplifierSwitch -> SwitchResult
+\end{code}
%************************************************************************
%* *
this? WDP 94/06) This allows us to neglect keeping everything paired
with its static environment.
-The environment contains bindings for all
+The environment contains bindings for all
{\em in-scope,}
{\em locally-defined}
-things.
+things.
For such things, any unfolding is found in the environment, not in the
Id. Unfoldings in the Id itself are used only for imported things
\begin{code}
data SimplEnv
- = SimplEnv
- (SwitchChecker SimplifierSwitch)
-
- EnclosingCcDetails -- the enclosing cost-centre (when profiling)
-
- InTypeEnv -- For cloning types
- -- Domain is all in-scope type variables
-
- InIdEnv -- IdEnv
- -- Domain is
- -- *all*
- -- *in-scope*,
- -- *locally-defined*
- -- *InIds*
- -- (Could omit the exported top-level guys,
- -- since their names mustn't change; and ditto
- -- the non-exported top-level guys which you
- -- don't want to macro-expand, since their
- -- names need not change.)
- --
- -- Starts off empty
-
- UnfoldEnv -- Domain is any *OutIds*, including imports
- -- where we know something more than the
- -- interface file tells about their value (see
- -- below)
-
-nullSimplEnv :: SwitchChecker SimplifierSwitch -> SimplEnv
-
-nullSimplEnv sw_chkr
- = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
-
-pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
- = ppAboves [
- ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
- ppSP, ppStr "** Id Env ** ?????????",
--- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
- ppSP, ppStr "** Unfold Env **",
- ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
- ]
- where
- pp_id_entry (v, idval)
- = ppCat [ppr PprDebug v, ppStr "=>",
- case idval of
- InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
- ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
- ]
-
- pp_uf_entry (UnfoldItem v form encl_cc)
- = ppCat [ppr PprDebug v, ppStr "=>",
- case form of
- NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
- LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
- OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]]
- ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
- OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
- [ppr PprDebug c | c <- cs]]
- GeneralForm t w e g -> ppCat [ppStr "UF:",
- ppr PprDebug t,
- ppr PprDebug w,
- ppr PprDebug g, ppr PprDebug e]
- MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s]
- IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd"
- ]
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @IdVal@ type (for the ``IdEnv'')}
-%* *
-%************************************************************************
-
-The unfoldings for imported things are mostly kept within the Id
-itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For
-example, suppose \tr{x} is imported, and we have
-\begin{verbatim}
- case x of
- (p,q) -> <body>
-\end{verbatim}
-Then within \tr{<body>}, we know that \tr{x} is a pair with components
-\tr{p} and \tr{q}.
-
-\begin{code}
-type InIdEnv = IdEnv IdVal -- Maps InIds to their value
-
-data IdVal
- = InlineIt InIdEnv InTypeEnv InExpr
- -- No binding of the Id is left;
- -- You *have* to replace any occurences
- -- of the id with this expression.
- -- Rather like a macro, really
- -- NB: the InIdEnv/InTypeEnv is necessary to prevent
- -- name caputure. Consider:
- -- let y = ...
- -- x = ...y...
- -- y = ...
- -- in ...x...
- -- If x gets an InlineIt, we must remember
- -- the correct binding for y.
-
- | ItsAnAtom OutAtom -- Used either (a) to record the cloned Id
- -- or (b) if the orig defn is a let-binding, and
- -- the RHS of the let simplifies to an atom,
- -- we just bind the variable to that atom, and
- -- elide the let.
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @UnfoldEnv@, @UnfoldingDetails@, and @UnfoldingGuidance@ types}
-%* *
-%************************************************************************
-
-The @UnfoldEnv@ contains information about the value of some of the
-in-scope identifiers. It obeys the following invariant:
-
- If the @UnfoldEnv@ contains information, it is safe to use it!
-
-In particular, if the @UnfoldEnv@ contains details of an unfolding of
-an Id, then it's safe to use the unfolding. If, for example, the Id
-is used many times, then its unfolding won't be put in the UnfoldEnv
-at all.
-
-The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
-because (a)~it's small, and (b)~we need to search its {\em range} as
-well as its domain.
-
-\begin{code}
-data UnfoldItem -- a glorified triple...
- = UnfoldItem OutId -- key: used in lookForConstructor
- UnfoldingDetails -- for that Id
- EnclosingCcDetails -- so that if we do an unfolding,
- -- we can "wrap" it in the CC
- -- that was in force.
-
-data UnfoldConApp -- yet another glorified triple
- = UCA OutId -- same fields as ConstructorForm;
- [UniType] -- a new type so we can make
- [OutAtom] -- Ord work on it (instead of on
- -- UnfoldingDetails).
-
-data UnfoldEnv -- yup, a glorified triple...
- = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
- IdSet -- The Ids in the domain of the env
- -- which have details (GeneralForm True ...)
- -- i.e., they claim they are duplicatable.
- -- These are the ones we have to worry
- -- about when adding new items to the
- -- unfold env.
- (FiniteMap UnfoldConApp OutId)
- -- Maps applications of constructors (to
- -- types & atoms) back to OutIds that are
- -- bound to them; i.e., this is a reversed
- -- mapping for (part of) the main IdEnv
- -- (1st part of UFE)
-
-null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
-\end{code}
-
-The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
-be small, because it contains bindings only for those things whose
-form or unfolding is known. Basically it maps @Id@ to their
-@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
-need to search it associatively, to look for @Id@s which have a given
-constructor form.
-
-We implement it with @IdEnvs@, possibly overkill, but sometimes these
-things silently grow quite big.... Here are some local functions used
-elsewhere in the module:
-
-\begin{code}
-grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
-lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
-lookup_unfold_env_encl_cc
- :: UnfoldEnv -> OutId -> EnclosingCcDetails
-
-grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
-
-grow_unfold_env (UFE u_env interesting_ids con_apps) id
- uf_details@(GeneralForm True _ _ _) encl_cc
- -- Only interested in Ids which have a "dangerous" unfolding; that is
- -- one that claims to have a single occurrence.
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- (interesting_ids `unionUniqSets` singletonUniqSet id)
- con_apps
-
-grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- interesting_ids
- new_con_apps
- where
- new_con_apps
- = case uf_details of
- ConstructorForm con targs vargs
- -> case (lookupFM con_apps entry) of
- Just _ -> con_apps -- unchanged; we hang onto what we have
- Nothing -> addToFM con_apps entry id
- where
- entry = UCA con targs vargs
-
- not_a_constructor -> con_apps -- unchanged
-
-addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
- = ASSERT(not (any constructor_form_in_those extra_items))
- -- otherwise, we'd need to change con_apps
- UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
- where
- constructor_form_in_those (_, UnfoldItem _ (ConstructorForm _ _ _) _) = True
- constructor_form_in_those _ = False
-
-rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-
-get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
-
-foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
- = UFE (foldr fun u_env stuff) interesting_ids con_apps
-
-lookup_unfold_env (UFE u_env _ _) id
- = case (lookupIdEnv u_env id) of
- Nothing -> NoUnfoldingDetails
- Just (UnfoldItem _ uf _) -> uf
-
-lookup_unfold_env_encl_cc (UFE u_env _ _) id
- = case (lookupIdEnv u_env id) of
- Nothing -> NoEnclosingCcDetails
- Just (UnfoldItem _ _ encl_cc) -> encl_cc
+ = SimplEnv
+ SwitchChecker
+ CostCentre -- The enclosing cost-centre (when profiling)
+ InTypeEnv -- Maps old type variables to new clones
+ InIdEnv -- Maps locally-bound Ids to new clones
+ OutIdEnv -- Info about the values of OutIds
+ ConAppMap -- Maps constructor applications back to OutIds
-lookup_conapp (UFE _ _ con_apps) con ty_args con_args
- = lookupFM con_apps (UCA con ty_args con_args)
-modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
- = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
+nullSimplEnv :: SwitchChecker -> SimplEnv
--- If the current binding claims to be a "unique" one, then
--- we modify it.
-modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
-
-modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
- = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
-\end{code}
-
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
-\begin{code}
-instance Eq UnfoldConApp where
- a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
- a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
-
-instance Ord UnfoldConApp where
- a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-
-cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2)
- = case cmpId c1 c2 of
- LT_ -> LT_
- GT_ -> GT_
- _ -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of
- LT_ -> LT_
- GT_ -> GT_
- _ -> cmp_lists cmp_atom as1 as2
- where
- cmp_lists cmp_item [] [] = EQ_
- cmp_lists cmp_item (x:xs) [] = GT_
- cmp_lists cmp_item [] (y:ys) = LT_
- cmp_lists cmp_item (x:xs) (y:ys)
- = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
-
- cmp_atom (CoVarAtom x) (CoVarAtom y) = x `cmpId` y
- cmp_atom (CoVarAtom _) _ = LT_
- cmp_atom (CoLitAtom x) (CoLitAtom y)
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
-#else
- = if x == y then EQ_ elsid if x < y then LT_ else GT_
-#endif
- cmp_atom (CoLitAtom _) _ = GT_
-\end{code}
-
-\begin{code}
-data UnfoldingDetails
- = NoUnfoldingDetails
-
- | LiteralForm
- BasicLit
-
- | OtherLiteralForm
- [BasicLit] -- It is a literal, but definitely not one of these
-
- | ConstructorForm
- Id -- The constructor
- [UniType] -- Type args
- [OutAtom] -- Value arguments; NB OutAtoms, already cloned
-
- | OtherConstructorForm
- [Id] -- It definitely isn't one of these constructors
- -- This captures the situation in the default branch of
- -- a case: case x of
- -- c1 ... -> ...
- -- c2 ... -> ...
- -- v -> default-rhs
- -- Then in default-rhs we know that v isn't c1 or c2.
- --
- -- NB. In the degenerate: case x of {v -> default-rhs}
- -- x will be bound to
- -- OtherConstructorForm []
- -- which captures the idea that x is eval'd but we don't
- -- know which constructor.
-
-
- | GeneralForm
- Bool -- True <=> At most one textual occurrence of the
- -- binder in its scope, *or*
- -- if we are happy to duplicate this
- -- binding.
- FormSummary -- Tells whether the template is a WHNF or bottom
- TemplateOutExpr -- The template
- UnfoldingGuidance -- Tells about the *size* of the template.
-
- | MagicForm
- FAST_STRING
- MagicUnfoldingFun
-
- {-OLD? Nukable? ("Also turgid" SLPJ)-}
- | IWantToBeINLINEd -- Means this has an INLINE pragma;
- -- Used for things which have a defn in this module
- UnfoldingGuidance -- Guidance from the pragma; usually UnfoldAlways.
-
-data FormSummary
- = WhnfForm -- Expression is WHNF
- | BottomForm -- Expression is guaranteed to be bottom. We're more gung
- -- ho about inlining such things, because it can't waste work
- | OtherForm -- Anything else
-
-instance Outputable FormSummary where
- ppr sty WhnfForm = ppStr "WHNF"
- ppr sty BottomForm = ppStr "Bot"
- ppr sty OtherForm = ppStr "Other"
-
-mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary
-mkFormSummary si expr
- | manifestlyWHNF expr = WhnfForm
- | bottomIsGuaranteed si = BottomForm
-
- -- Chances are that the Id will be decorated with strictness info
- -- telling that the RHS is definitely bottom. This *might* not be the
- -- case, if it's been a while since strictness analysis, but leaving out
- -- the test for manifestlyBottom makes things a little more efficient.
- -- We can always put it back...
- -- | manifestlyBottom expr = BottomForm
-
- | otherwise = OtherForm
-\end{code}
-
-\begin{code}
-data UnfoldingGuidance
- = UnfoldNever -- Don't do it!
-
- | UnfoldAlways -- There is no "original" definition,
- -- so you'd better unfold. Or: something
- -- so cheap to unfold (e.g., 1#) that
- -- you should do it absolutely always.
-
- | EssentialUnfolding -- Like UnfoldAlways, but you *must* do
- -- it absolutely always.
- -- This is what we use for data constructors
- -- and PrimOps, because we don't feel like
- -- generating curried versions "just in case".
-
- | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and
- Int -- those val args are manifestly data constructors
- [Bool] -- the val-arg positions marked True
- -- (i.e., a simplification will definitely
- -- be possible).
- Int -- The "size" of the unfolding; to be elaborated
- -- later. ToDo
-
- | BadUnfolding -- This is used by TcPragmas if the *lazy*
- -- lintUnfolding test fails
- -- It will never escape from the IdInfo as
- -- it is caught by getInfo_UF and converted
- -- to NoUnfoldingDetails
-\end{code}
-
-\begin{code}
-instance Outputable UnfoldingGuidance where
- ppr sty UnfoldNever = ppStr "_N_"
- ppr sty UnfoldAlways = ppStr "_ALWAYS_"
- ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
- ppr sty (UnfoldIfGoodArgs t v cs size)
- = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
- if null cs -- always print *something*
- then ppChar 'X'
- else ppBesides (map pp_c cs),
- ppInt size ]
- where
- pp_c False = ppChar 'X'
- pp_c True = ppChar 'C'
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
-%* *
-%************************************************************************
-
-\begin{code}
-mkGenForm :: Bool -- Ok to Dup code down different case branches,
- -- because of either a flag saying so,
- -- or alternatively the object is *SMALL*
- -> BinderInfo --
- -> FormSummary
- -> TemplateOutExpr -- Template
- -> UnfoldingGuidance -- Tells about the *size* of the template.
- -> UnfoldingDetails
-
-mkGenForm safe_to_dup occ_info WhnfForm template guidance
- = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
-
-mkGenForm safe_to_dup occ_info form_summary template guidance
- | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences
- = GeneralForm True form_summary template guidance
-
- | otherwise -- Not a WHNF, many occurrences
- = NoUnfoldingDetails
-\end{code}
-
-\begin{code}
-modifyUnfoldingDetails
- :: Bool -- OK to dup
- -> BinderInfo -- New occurrence info for the thing
- -> UnfoldingDetails
- -> UnfoldingDetails
-
-modifyUnfoldingDetails ok_to_dup occ_info
- (GeneralForm only_one form_summary template guidance)
- | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance
-
-{- OLD:
- | otherwise = NoUnfoldingDetails
- I can't see why we zap bindings which don't claim to be unique
--}
-
-modifyUnfoldingDetails ok_to_dup occ_info other = other
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @EnclosingCcDetails@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-data EnclosingCcDetails
- = NoEnclosingCcDetails
- | EnclosingCC CostCentre
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
-%* *
-%************************************************************************
+nullSimplEnv sw_chkr
+ = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
-\begin{code}
-type InId = Id -- Not yet cloned
-type InBinder = (InId, BinderInfo)
-type InType = UniType -- Ditto
-type InBinding = SimplifiableCoreBinding
-type InExpr = SimplifiableCoreExpr
-type InAtom = SimplifiableCoreAtom -- same as PlainCoreAtom
-type InAlts = SimplifiableCoreCaseAlternatives
-type InDefault = SimplifiableCoreCaseDefault
-type InArg = CoreArg InId
-type InUniType = UniType
+combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
+combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
+ new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ )
+ = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
-type OutId = Id -- Cloned
-type OutBinder = Id
-type OutType = UniType -- Cloned
-type OutBinding = PlainCoreBinding
-type OutExpr = PlainCoreExpr
-type OutAtom = PlainCoreAtom
-type OutAlts = PlainCoreCaseAlternatives
-type OutDefault = PlainCoreCaseDefault
-type OutArg = CoreArg OutId
-type OutUniType = UniType
-
-type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId
- -- An OutExpr with occurrence info attached
- -- This is used as a template in GeneralForms.
+pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
\end{code}
-\begin{code}
-type SwitchChecker switch = switch -> SwitchResult
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@SimplEnv@ handling}
-%* *
-%************************************************************************
%************************************************************************
%* *
%************************************************************************
\begin{code}
-getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch
-getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
+getSwitchChecker :: SimplEnv -> SwitchChecker
+getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-switchIsSet (SimplEnv chkr _ _ _ _) switch
+switchIsSet (SimplEnv chkr _ _ _ _ _) switch
= switchIsOn chkr switch
+
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+ = 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)
+ = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
+ where
+ chkr' EssentialUnfoldingsOnly = SwBool True
+ chkr' other = chkr other
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
--- UNUSED:
---getEnclosingCC :: SimplEnv -> EnclosingCcDetails
---getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc
+setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
-setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
+setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
+ = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
-setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
- = SimplEnv chkr encl_cc ty_env id_env unfold_env
+getEnclosingCC :: SimplEnv -> CostCentre
+getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type InTypeEnv = TypeEnv -- Maps InTyVars to OutUniTypes
+type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
-extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
-extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
- = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
+extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
+ = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
where
new_ty_env = addOneToTyVarEnv ty_env tyvar ty
-extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv
-extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
- = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
+extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
+extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
+ = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
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
-\end{code}
-
-@replaceInEnvs@ is used to install saved type and id envs
-when pulling an un-simplified expression out of the environment, which
-was saved with its environments.
-
-\begin{code}
-nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
-
--- UNUSED:
---getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv)
---getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env)
-
-replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
-replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (new_ty_env, new_id_env)
- = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
+simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
+simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-extendIdEnvWithAtom
- :: SimplEnv
- -> InBinder -> OutAtom
- -> SimplEnv
-
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit)
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
- where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id, occ_info) atom@(CoVarAtom out_id)
- = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
- where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
+type InIdEnv = IdEnv OutArg -- Maps InIds to their value
+ -- Usually this is just the cloned Id, but if
+ -- if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just bind the variable to that atom, and
+ -- elide the let.
+\end{code}
- new_unfold_env = modify_unfold_env
- unfold_env
- (modifyItem ok_to_dup occ_info)
- out_id
- -- Modify binding for in_id
- -- NO! modify out_id, because its the info on the
- -- atom that interest's us.
+\begin{code}
+lookupId :: SimplEnv -> Id -> OutArg
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
+lookupId (SimplEnv _ _ _ in_id_env _ _) id
+ = case (lookupIdEnv in_id_env id) of
+ Just atom -> atom
+ Nothing -> VarArg id
+\end{code}
-extendIdEnvWithAtomList
+\begin{code}
+extendIdEnvWithAtom
:: SimplEnv
- -> [(InBinder, OutAtom)]
- -> SimplEnv
-extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-
-extendIdEnvWithInlining
- :: SimplEnv -- The Env to modify
- -> SimplEnv -- The Env to record in the inlining. Usually the
- -- same as the previous one, except in the recursive case
- -> InBinder -> InExpr
+ -> InBinder
+ -> OutArg{-Val args only, please-}
-> SimplEnv
-extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
- (in_id,occ_info)
- expr
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
+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
where
- new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
+ 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)
-extendIdEnvWithClone
- :: SimplEnv
- -> InBinder -- Old binder; binderinfo ignored
- -> OutId -- Its new clone, as an Id
- -> SimplEnv
+extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
+extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id,_) out_id
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
- where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id))
-extendIdEnvWithClones -- Like extendIdEnvWithClone
- :: SimplEnv
- -> [InBinder]
- -> [OutId]
- -> SimplEnv
+extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
+
+extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ (in_id,_) out_id
+ = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
+ where
+ new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
-extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- in_binders out_ids
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
+extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
+extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ in_binders out_ids
+ = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
where
- new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
- in_ids = [id | (id,_) <- in_binders]
- out_vals = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids]
-
-lookupId :: SimplEnv -> Id -> Maybe IdVal
-
-lookupId (SimplEnv _ _ _ id_env _) id
-#ifndef DEBUG
- = lookupIdEnv id_env id
-#else
- = case (lookupIdEnv id_env id) of
- xxx@(Just _) -> xxx
- xxx -> --false!: ASSERT(not (isLocallyDefined id))
- xxx
-#endif
+ new_in_id_env = growIdEnvList in_id_env bindings
+ bindings = zipEqual "extendIdEnvWithClones"
+ [id | (id,_) <- in_binders]
+ (map VarArg out_ids)
\end{code}
%************************************************************************
%* *
-\subsubsection{The @UnfoldEnv@}
+\subsubsection{The @OutIdEnv@}
%* *
%************************************************************************
+
+The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
+both locally-bound ones, and perhaps some imported ones too.
+
\begin{code}
-extendUnfoldEnvGivenFormDetails
- :: SimplEnv
- -> OutId
- -> UnfoldingDetails
- -> SimplEnv
+type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
-extendUnfoldEnvGivenFormDetails
- env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- id details
- = case details of
- NoUnfoldingDetails -> env
- good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
- where
- new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
+\end{code}
-extendUnfoldEnvGivenConstructor -- specialised variant
- :: SimplEnv
- -> OutId -- bind this to...
- -> Id -> [OutId] -- "con <tys-to-be-invented> args"
- -> SimplEnv
+The "Id" part is just so that we can recover the domain of the mapping, which
+IdEnvs don't allow directly.
+
+The @BinderInfo@ tells about the occurrences of the @OutId@.
+Anything that isn't in here should be assumed to occur many times.
+We keep this info so we can modify it when something changes.
-extendUnfoldEnvGivenConstructor env var con args
- = let
- -- conjure up the types to which the con should be applied
- scrut_ty = getIdUniType var
- (_, ty_args, _) = getUniDataTyCon scrut_ty
- in
- extendUnfoldEnvGivenFormDetails
- env var (ConstructorForm con ty_args (map CoVarAtom args))
+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
+
+ | InUnfolding SimplEnv -- Un-simplified unfolding
+ SimpleUnfolding -- (need to snag envts therefore)
+
+ | OutUnfolding CostCentre
+ SimpleUnfolding -- Already-simplified unfolding
+
+lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
+lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
+
+lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
+lookupRhsInfo env id
+ = case lookupOutIdEnv env id of
+ Just (_,_,info) -> info
+ Nothing -> NoRhsInfo
+
+modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
+ -> (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
\end{code}
-@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
+\begin{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:
@
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);
+ 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
+ } 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)
+ 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
inside a lambda.
\begin{code}
-extendUnfoldEnvGivenRhs
- :: SimplEnv
- -> InBinder
- -> OutId -- Note: *must* be an "out" Id (post-cloning)
- -> OutExpr -- Its rhs (*simplified*)
- -> SimplEnv
-
-extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- binder@(_,occ_info) out_id rhs
- = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
+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
- -- Occurrence-analyse the RHS
- (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
+ 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)
- interesting_fvs = get_interesting_ids unfold_env
+ -- 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
- details = case rhs of
- CoVar v -> panic "CoVars already dealt with"
- CoLit lit | isNoRepLit lit -> LiteralForm lit
- | otherwise -> panic "non-noRep CoLits already dealt with"
-
- CoCon con tys args -> ConstructorForm con tys args
-
- other -> mkGenForm ok_to_dup occ_info
- (mkFormSummary (getIdStrictness out_id) rhs)
- template guidance
-
- -- Compute resulting unfold env
- new_unfold_env = case details of
- NoUnfoldingDetails -> unfold_env
- GeneralForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
- other -> unfold_env1
-
- -- Add unfolding to unfold env
- unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
-
- -- Modify unfoldings of free vars of rhs, based on their
- -- occurrence info in the rhs [see notes above]
- unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
-
- modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
- modify (u, occ_info) env
- = case (lookupDirectlyUFM env u) of
- Nothing -> env -- ToDo: can this happen?
- Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
-
- -- Compute unfolding guidance
- guidance = if simplIdWantsToBeINLINEd out_id env
- then UnfoldAlways
- else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
-
- bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
- Nothing -> uNFOLDING_CREATION_THRESHOLD
- Just xx -> xx
-
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
- || exprSmallEnoughToDup rhs
- -- [Andy] added, Jun 95
-
-{- Reinstated AJG Jun 95; This is needed
- --example that does not (currently) work
- --without this extention
-
- --let f = g x
- --in
- -- case <exp> of
- -- True -> h i f
- -- False -> f
- -- ==>
- -- case <exp> of
- -- True -> h i f
- -- False -> g x
--}
-{- OLD:
- Omitted SLPJ Feb 95; should, I claim, be unnecessary
- -- is_really_small looks for things like f a b c
- -- but making sure there are not *too* many arguments.
- -- (This is brought to you by *ANDY* Magic Constants, Inc.)
- is_really_small
- = case collectArgs new_rhs of
- (CoVar _, xs) -> length xs < 10
- _ -> False
+ 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...
+
+(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.)
+
+Bad news! (f x) is duplicated! Our solution is to only be prepared to
+inline RHSs in their own RHSs if they are *values* (lambda or constructor).
+
+This means that silly x=y bindings in recursive group will never go away. Sigh. ToDo!
-}
+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
+ (ValueForm, UnfoldNever) -> out_id_env -- No new stuff to put in
+ (ValueForm, _) -> out_id_env_with_unfolding
+ other -> out_id_env -- Not a value
+
+ -- 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
+ rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
+ form_summary = mkFormSummary old_rhs
+ guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
-{- UNUSED:
-extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv
-extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- new_ids old_rhss
- = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
+mkSimplUnfoldingGuidance chkr out_id rhs
+ | not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
+ = UnfoldAlways
+
+ | otherwise
+ = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
where
- extra_unfold_items
- = [ (new_id, UnfoldItem new_id
- (GeneralForm True
- (mkFormSummary (getIdStrictness new_id) old_rhs)
- old_rhs UnfoldAlways)
- encl_cc)
- | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss,
- simplIdWantsToBeINLINEd new_id env
- ]
-
- new_unfold_env = addto_unfold_env unfold_env extra_unfold_items
--}
+ bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
+
+extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
+extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ out_id occ_info rhs_info
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ where
+ new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
+ (out_id, occ_info, rhs_info)
\end{code}
-\begin{code}
-lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
-lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
- | not (isLocallyDefined var) -- Imported, so look inside the id
- = getIdUnfolding var
+\begin{code}
+modifyOccInfo out_id_env (uniq, new_occ)
+ = modifyIdEnv_Directly modify_fn out_id_env uniq
+ where
+ modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
- | otherwise -- Locally defined, so look in the envt.
- -- There'll be nothing inside the Id.
- = lookup_unfold_env unfold_env var
+markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ where
+ new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
+ modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
\end{code}
-We need to remove any @GeneralForm@ bindings from the UnfoldEnv for
-the RHS of an Id which has an INLINE pragma.
+
+
+%************************************************************************
+%* *
+\subsubsection{The @ConAppMap@ type}
+%* *
+%************************************************************************
+
+The @ConAppMap@ maps applications of constructors (to value atoms)
+back to an association list that says "if the constructor was applied
+to one of these lists-of-Types, then this OutId is your man (in a
+non-gender-specific sense)". I.e., this is a reversed mapping for
+(part of) the main OutIdEnv
+
+\begin{code}
+type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
+
+data UnfoldConApp
+ = UCA OutId -- data constructor
+ [OutArg] -- *value* arguments; see use below
+\end{code}
\begin{code}
-filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
+nullConApps = emptyFM
-filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
+extendConApps con_apps id (Con con args)
+ = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
where
- new_unfold_env = null_unfold_env
- -- This version is really simple. INLINEd things are going to
- -- be inlined wherever they are used, and then all the
- -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
- -- much point in doing anything to the as-yet-un-INLINEd rhs.
-
- -- 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.
- --
- -- So he'd like not to filter the unfold env at all. But that's a disaster:
- -- Suppose we have:
- --
- -- 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.
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+extendConApps con_apps id other_rhs = con_apps
\end{code}
-======================
+\begin{code}
+lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
+ = case lookupFM con_apps (UCA con val_args) of
+ Nothing -> Nothing
+
+ Just assocs -> case [id | (tys, id) <- assocs,
+ and (zipWith eqTy tys ty_args)]
+ of
+ [] -> Nothing
+ (id:_) -> Just id
+ where
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+\end{code}
-In @lookForConstructor@ we used (before Apr 94) to have a special case
-for nullary constructors:
+NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
+for nullary constructors, but now we only do constructor re-use in
+let-bindings the special case isn't necessary any more.
-\begin{verbatim}
+\begin{verbatim}
= -- Don't re-use nullary constructors; it's a waste. Consider
- -- let
+ -- let
-- a = leInt#! p q
- -- in
+ -- in
-- case a of
-- True -> ...
-- False -> False
Nothing
\end{verbatim}
-but now we only do constructor re-use in let-bindings the special
-case isn't necessary any more.
+
+The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
+it, so we can use it for a @FiniteMap@ key.
\begin{code}
-lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args
- = lookup_conapp unfold_env con ty_args con_args
+instance Eq UnfoldConApp where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord UnfoldConApp where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+
+instance Ord3 UnfoldConApp where
+ cmp = cmp_app
+
+cmp_app (UCA c1 as1) (UCA c2 as2)
+ = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
+ where
+ -- ToDo: make an "instance Ord3 CoreArg"???
+
+ cmp_arg (VarArg x) (VarArg y) = x `cmp` y
+ cmp_arg (LitArg x) (LitArg y) = x `cmp` y
+ cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
+ cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
+ cmp_arg x y
+ | tag x _LT_ tag y = LT_
+ | otherwise = GT_
+ where
+ tag (VarArg _) = ILIT(1)
+ tag (LitArg _) = ILIT(2)
+ tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
+ tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
\end{code}
+
+
+
projects / ghc-hetmet.git / blobdiff