pprId,
showId,
+ -- Specialialisation
+ getIdSpecialisation,
+ addIdSpecialisation,
+
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
addIdArity,
addIdDemandInfo,
mkIdEnv,
mkIdSet,
modifyIdEnv,
+ modifyIdEnv_Directly,
nullIdEnv,
rngIdEnv,
unionIdSets,
)
import PprStyle
import Pretty
+import SpecEnv ( SpecEnv(..) )
+import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
-unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-unfoldingUnfriendlyId id
- | not (externallyVisibleId id) -- that settles that...
- = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
- = class_thing wrapper
- where
- -- "class thing": If we're going to use this worker Id in
- -- an interface, we *have* to be able to untangle the wrapper's
- -- strictness when reading it back in. At the moment, this
- -- is not always possible: in precisely those cases where
- -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
- class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
- class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
- class_thing other = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
- -- a SPEC of a DictFunId can end up w/ gratuitous
- -- TyVar(Templates) in the i/face; only a problem
- -- if -fshow-pragma-name-errs; but we can do without the pain.
- -- A HACK in any case (WDP 94/05/02)
- = naughty_DictFunId dfun
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
- = naughty_DictFunId dfun -- similar deal...
-
-unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
- -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _)
- = not (isGroundTy ty)
--}
+unfoldingUnfriendlyId id = not (externallyVisibleId id)
\end{code}
@externallyVisibleId@: is it true that another module might be
%************************************************************************
@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
+and generates an @Unfolding@. The @Ids@ and @TyVars@ don't really
+have to be new, because we are only producing a template.
ToDo: what if @DataConId@'s type has a context (haven't thought about it
--WDP)?
present.)
\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
{-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
+addIdUnfolding :: Id -> Unfolding -> Id
addIdUnfolding id@(Id u n ty info details) unfold_details
= ASSERT(
case (isLocallyDefined id, unfold_details) of
- (_, NoUnfoldingDetails) -> True
+ (_, NoUnfolding) -> True
(True, IWantToBeINLINEd _) -> True
(False, IWantToBeINLINEd _) -> False -- v bad
(False, _) -> True
\end{code}
\begin{code}
-{- LATER:
getIdSpecialisation :: Id -> SpecEnv
getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
addIdSpecialisation :: Id -> SpecEnv -> Id
addIdSpecialisation (Id u n ty details prags info) spec_info
= Id u n ty details prags (info `addInfo` spec_info)
--}
\end{code}
Strictness: we snaffle the info out of the IdInfo.
delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+modifyIdEnv :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
rngIdEnv :: IdEnv a -> [a]
isNullIdEnv :: IdEnv a -> Bool
-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
-- modify function, and put it back.
-modifyIdEnv env mangle_fn key
+modifyIdEnv mangle_fn env key
= case (lookupIdEnv env key) of
Nothing -> env
Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+modifyIdEnv_Directly mangle_fn env key
+ = case (lookupUFM_Directly env key) of
+ Nothing -> env
+ Just xx -> addToUFM_Directly env key (mangle_fn xx)
\end{code}
\begin{code}
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
-import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
DemandInfo -- Whether or not it is definitely
-- demanded
- (MatchEnv [Type] CoreExpr)
- -- Specialisations of this function which exist
- -- This corresponds to a SpecEnv which we do
- -- not import directly to avoid loop
+ SpecEnv -- Specialisations of this function which exist
StrictnessInfo -- Strictness properties, notably
-- how to conjure up "worker" functions
- UnfoldingDetails -- Its unfolding; for locally-defined
- -- things, this can *only* be NoUnfoldingDetails
+ Unfolding -- Its unfolding; for locally-defined
+ -- things, this can *only* be NoUnfolding
UpdateInfo -- Which args should be updated
_ {- no f/b w/w -}
_ {- src_loc: no effect on interfaces-}
)
- | null (mEnvToList specenv)
+ | isNullSpecEnv specenv
&& boring_strictness strictness
&& boring_unfolding unfolding
= True
boring_strictness BottomGuaranteed = False
boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
- boring_unfolding NoUnfoldingDetails = True
- boring_unfolding _ = False
+ boring_unfolding NoUnfolding = True
+ boring_unfolding _ = False
boringIdInfo _ = False
\begin{code}
apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
update deforest arg_usage fb_ww srcloc)
- | isEmptyMEnv spec
+ | isNullSpecEnv spec
= idinfo
| otherwise
= panic "IdInfo:apply_to_IdInfo"
-> Id -- The Id for which we're printing this IdInfo
-> Bool -- True <=> print specialisations, please
-> (Id -> Id) -- to look up "better Ids" w/ better IdInfos;
- -> IdEnv UnfoldingDetails
+ -> IdEnv Unfolding
-- inlining info for top-level fns in this module
-> IdInfo -- see MkIface notes
-> Pretty
else pp_unfolding sty for_this_id inline_env unfold,
if specs_please
- then ppSpecs sty (not (isDataCon for_this_id))
- better_id_fn inline_env (mEnvToList specenv)
+ then panic "ppSpecs (ToDo)" -- sty (not (isDataCon for_this_id))
+ -- better_id_fn inline_env (mEnvToList specenv)
else pp_NONE,
-- DemandInfo needn't be printed since it has no effect on interfaces
See SpecEnv.lhs
\begin{code}
-instance OptIdInfo (MatchEnv [Type] CoreExpr) where
- noInfo = nullMEnv
+instance OptIdInfo SpecEnv where
+ noInfo = nullSpecEnv
getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
- addInfo id_info spec | null (mEnvToList spec) = id_info
+ addInfo id_info spec | isNullSpecEnv spec = id_info
addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
- ppInfo sty better_id_fn spec
- = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
-
-ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
- = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
+ ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
+-- = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
\end{code}
%************************************************************************
\begin{code}
mkUnfolding guide expr
- = GenForm (mkFormSummary NoStrictnessInfo expr)
- (occurAnalyseGlobalExpr expr)
- guide
+ = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
+ guide
+ (occurAnalyseGlobalExpr expr))
\end{code}
\begin{code}
-noInfo_UF = NoUnfoldingDetails
-
-getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
- = case unfolding of
- GenForm _ _ BadUnfolding -> NoUnfoldingDetails
- unfolding_as_was -> unfolding_as_was
+noInfo_UF = NoUnfolding
--- getInfo_UF ensures that any BadUnfoldings are never returned
--- We had to delay the test required in TcPragmas until now due
--- to strictness constraints in TcPragmas
+getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
-addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
-addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
+addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
+addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
\end{code}
\begin{code}
Nothing -> pp uf_details
Just dt -> pp dt
where
- pp NoUnfoldingDetails = pp_NONE
+ pp NoUnfolding = pp_NONE
- pp (MagicForm tag _)
+ pp (MagicUnfolding tag _)
= ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
- pp (GenForm _ _ BadUnfolding) = pp_NONE
-
- pp (GenForm _ template guide)
+ pp (CoreUnfolding (SimpleUnfolding _ guide template))
= let
untagged = unTagBinders template
in
import BinderInfo ( BinderInfo )
import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
-import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ SimpleUnfolding(..), FormSummary(..) )
import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
unfoldingUnfriendlyId, getIdInfo, nmbrId,
nullIdEnv, lookupIdEnv, IdEnv(..),
Id(..), GenId
)
+import CostCentre ( CostCentre )
import IdInfo ( IdInfo )
+import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv )
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import OccurAnal ( occurAnalyseGlobalExpr )
import Util ( Ord3(..) )
import WwLib ( mAX_WORKER_ARGS )
+nullSpecEnv :: SpecEnv
+isNullSpecEnv :: SpecEnv -> Bool
+
occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
externallyVisibleId :: Id -> Bool
isDataCon :: GenId ty -> Bool
instance (Outputable a) => Outputable (GenId a)
instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+data SpecEnv
data NmbrEnv
data MagicUnfoldingFun
-data FormSummary = WhnfForm | BottomForm | OtherForm
-data UnfoldingDetails
- = NoUnfoldingDetails
- | OtherLitForm [Literal]
- | OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
- | GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
- | MagicForm Unique MagicUnfoldingFun
+data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
+
+data Unfolding
+ = NoUnfolding
+ | CoreUnfolding SimpleUnfolding
+ | MagicUnfolding Unique MagicUnfoldingFun
+
+
+data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique)
+
data UnfoldingGuidance
= UnfoldNever
| UnfoldAlways
- | EssentialUnfolding
| UnfoldIfGoodArgs Int Int [Bool] Int
- | BadUnfolding
+
+data CostCentre
\end{code}
+
+
+
+
__exports__
CoreSyn CoreExpr
CoreUnfold FormSummary (..)
-CoreUnfold UnfoldingDetails (..)
+CoreUnfold Unfolding (..)
CoreUnfold UnfoldingGuidance (..)
CoreUtils unTagBinders (..)
Id IdEnv
MagicUFs mkMagicUnfoldingFun (..)
OccurAnal occurAnalyseGlobalExpr (..)
PprType pprParendGenType (..)
+SpecEnv isNullSpecEnv (..)
+SpecEnv nullSpecEnv (..)
WwLib mAX_WORKER_ARGS (..)
\end{code}
IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
import CoreSyn
-import CoreUnfold ( UnfoldingGuidance(..) )
+import CoreUnfold ( UnfoldingGuidance(..), Unfolding )
import Id ( mkImported, mkTemplateLocals )
import IdInfo -- quite a few things
+import SpecEnv ( SpecEnv )
import Name ( mkPrimitiveName, OrigName(..) )
import PrelMods ( gHC_BUILTINS )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
= mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
(noIdInfo `addInfo` (mkArityInfo arity)
- `addInfo_UF` (mkUnfolding EssentialUnfolding
+ `addInfo_UF` (mkUnfolding UnfoldAlways
(mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
where
key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
\begin{code}
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
- = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
+ = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
\end{code}
Lookup is expected to find a binding for the @Id@.
mkApp, mkCon, mkPrim,
mkValLam, mkTyLam, mkUseLam,
mkLam,
- collectBinders, isValBinder, notValBinder,
+ collectBinders, collectUsageAndTyBinders, collectValBinders,
+ isValBinder, notValBinder,
- collectArgs, isValArg, notValArg, numValArgs,
+ collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
mkCoLetsAny [] expr = expr
mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
-mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
-mkCoLetAny bind@(NonRec binder rhs) body
- = case body of
- Var binder2 | binder == binder2
- -> rhs -- hey, I have the rhs
- other
- -> Let bind body
+mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
+mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
\end{code}
\begin{code}
([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
collectBinders expr
+ = (usages, tyvars, vals, body)
+ where
+ (usages, tyvars, body1) = collectUsageAndTyBinders expr
+ (vals, body) = collectValBinders body1
+
+
+collectUsageAndTyBinders expr
= usages expr []
where
usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
usages other uacc
- = case (tyvars other []) of { (tacc, vacc, expr) ->
- (reverse uacc, tacc, vacc, expr) }
+ = case (tyvars other []) of { (tacc, expr) ->
+ (reverse uacc, tacc, expr) }
- tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
+ tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
tyvars other tacc
= ASSERT(not (usage_lambda other))
- case (valvars other []) of { (vacc, expr) ->
- (reverse tacc, vacc, expr) }
-
- valvars (Lam (ValBinder v) body) vacc = valvars body (v:vacc)
- valvars other vacc
- = ASSERT(not (usage_lambda other))
- ASSERT(not (tyvar_lambda other))
- (reverse vacc, other)
+ (reverse tacc, other)
---------------------------------------
usage_lambda (Lam (UsageBinder _) _) = True
tyvar_lambda (Lam (TyBinder _) _) = True
tyvar_lambda _ = False
+
+
+collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
+ ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
+collectValBinders expr
+ = go [] expr
+ where
+ go acc (Lam (ValBinder v) b) = go (v:acc) b
+ go acc body = (reverse acc, body)
+
\end{code}
%************************************************************************
= (fun,uacc)
\end{code}
+
+\begin{code}
+initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
+ -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
+initialTyArgs (TyArg ty : args) = (ty:tys, args')
+ where
+ (tys, args') = initialTyArgs args
+initialTyArgs other = ([],other)
+
+initialValArgs :: [GenCoreArg val_occ tyvar uvar]
+ -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
+initialValArgs args = span isValArg args
+\end{code}
+
+
%************************************************************************
%* *
\subsection{The main @Core*@ instantiation of the @GenCore*@ types}
Unfoldings (which can travel across module boundaries) are in Core
syntax (namely @CoreExpr@s).
-The type @UnfoldingDetails@ sits ``above'' simply-Core-expressions
+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 @GenForm@ unfolding, you will
+literal''). In the corner of a @SimpleUnfolding@ unfolding, you will
find, unsurprisingly, a Core expression.
\begin{code}
#include "HsVersions.h"
module CoreUnfold (
- UnfoldingDetails(..), UnfoldingGuidance(..), -- types
- FormSummary(..),
+ SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
- mkFormSummary,
- mkGenForm, mkLitForm, mkConForm,
- whnfDetails,
+ FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
+
+ smallEnoughToInline, couldBeSmallEnoughToInline,
+
+ mkSimpleUnfolding,
mkMagicUnfolding,
calcUnfoldingGuidance,
mentionedInUnfolding
IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
import Bag ( emptyBag, unitBag, unionBags, Bag )
-import BinderInfo ( oneTextualOcc, oneSafeOcc )
import CgCompInfo ( uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
import CoreSyn
-import CoreUtils ( coreExprType, manifestlyWHNF )
+import CoreUtils ( coreExprType )
import CostCentre ( ccMentionsId )
-import Id ( SYN_IE(IdSet), GenId{-instances-} )
-import IdInfo ( bottomIsGuaranteed )
+import Id ( idType, getIdArity, isBottomingId,
+ SYN_IE(IdSet), GenId{-instances-} )
+import PrimOp ( fragilePrimOp, PrimOp(..) )
+import IdInfo ( arityMaybe, bottomIsGuaranteed )
import Literal ( isNoRepLit, isLitLitLit )
import Pretty
import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
addOneToUniqSet, unionUniqSets
)
import Usage ( SYN_IE(UVar) )
-import Util ( isIn, panic )
+import Util ( isIn, panic, assertPanic )
whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
%************************************************************************
%* *
-\subsection{@UnfoldingDetails@ and @UnfoldingGuidance@ types}
+\subsection{@Unfolding@ and @UnfoldingGuidance@ types}
%* *
%************************************************************************
-(And @FormSummary@, too.)
-
\begin{code}
-data UnfoldingDetails
- = NoUnfoldingDetails
-
- | OtherLitForm
- [Literal] -- It is a literal, but definitely not one of these
-
- | OtherConForm
- [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
- -- OtherConForm []
- -- which captures the idea that x is eval'd but we don't
- -- know which constructor.
-
-
- | GenForm
- FormSummary -- Tells whether the template is a WHNF or bottom
- TemplateOutExpr -- The template
- UnfoldingGuidance -- Tells about the *size* of the template.
-
- | MagicForm
+data Unfolding
+ = NoUnfolding
+ | CoreUnfolding SimpleUnfolding
+ | MagicUnfolding
Unique -- of the Id whose magic unfolding this is
MagicUnfoldingFun
+
+data SimpleUnfolding
+ = SimpleUnfolding FormSummary -- Tells whether the template is a WHNF or bottom
+ UnfoldingGuidance -- Tells about the *size* of the template.
+ TemplateOutExpr -- The template
+
type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
-- An OutExpr with occurrence info attached. This is used as
-- a template in GeneralForms.
-mkMagicUnfolding :: Unique -> UnfoldingDetails
-mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag)
-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
+mkSimpleUnfolding form guidance template
+ = SimpleUnfolding form guidance template
-instance Outputable FormSummary where
- ppr sty WhnfForm = ppStr "WHNF"
- ppr sty BottomForm = ppStr "Bot"
- ppr sty OtherForm = ppStr "Other"
+mkMagicUnfolding :: Unique -> Unfolding
+mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
---???mkFormSummary :: StrictnessInfo -> GenCoreExpr 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
-
-whnfDetails :: UnfoldingDetails -> Bool -- True => thing is evaluated
-whnfDetails (GenForm WhnfForm _ _) = True
-whnfDetails (OtherLitForm _) = True
-whnfDetails (OtherConForm _) = True
-whnfDetails other = False
-\end{code}
-\begin{code}
data UnfoldingGuidance
- = UnfoldNever -- Don't do it!
-
+ = UnfoldNever
| 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
+ | UnfoldIfGoodArgs Int -- if "m" type args
+ Int -- and "n" value args
+ [Int] -- Discount if the argument is evaluated.
-- (i.e., a simplification will definitely
- -- be possible).
+ -- be possible). One elt of the list per *value* arg.
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 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),
+ else ppBesides (map (ppStr . show) cs),
ppInt size ]
- where
- pp_c False = ppChar 'X'
- pp_c True = ppChar 'C'
\end{code}
%************************************************************************
%* *
-\subsection{@mkGenForm@ and friends}
+\subsection{Figuring out things about expressions}
%* *
%************************************************************************
\begin{code}
-mkGenForm :: FormSummary
- -> TemplateOutExpr -- Template
- -> UnfoldingGuidance -- Tells about the *size* of the template.
- -> UnfoldingDetails
+data FormSummary
+ = VarForm -- Expression is a variable (or scc var, etc)
+ | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
+ | 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 VarForm = ppStr "Var"
+ ppr sty ValueForm = ppStr "Value"
+ ppr sty BottomForm = ppStr "Bot"
+ ppr sty OtherForm = ppStr "Other"
+
+mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
-mkGenForm = GenForm
+mkFormSummary expr
+ = go (0::Int) expr -- The "n" is the number of (value) arguments so far
+ where
+ go n (Lit _) = ASSERT(n==0) ValueForm
+ go n (Con _ _) = ASSERT(n==0) ValueForm
+ go n (SCC _ e) = go n e
+ go n (Coerce _ _ e) = go n e
+ go n (Let _ e) = OtherForm
+ go n (Case _ _) = OtherForm
+
+ go 0 (Lam (ValBinder x) e) = ValueForm -- NB: \x.bottom /= bottom!
+ go n (Lam (ValBinder x) e) = go (n-1) e -- Applied lambda
+ go n (Lam other_binder e) = go n e
+
+ go n (App fun arg) | isValArg arg = go (n+1) fun
+ go n (App fun other_arg) = go n fun
+
+ go n (Var f) | isBottomingId f = BottomForm
+ go 0 (Var f) = VarForm
+ go n (Var f) = case (arityMaybe (getIdArity f)) of
+ Just arity | n < arity -> ValueForm
+ other -> OtherForm
+
+whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
+whnfOrBottom e = case mkFormSummary e of
+ VarForm -> True
+ ValueForm -> True
+ BottomForm -> True
+ OtherForm -> False
+\end{code}
--- two shorthand variants:
-mkLitForm lit = mk_go_for_it (Lit lit)
-mkConForm con args = mk_go_for_it (Con con args)
-mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways
+\begin{code}
+exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
+exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
+exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+exprSmallEnoughToDup expr
+ = case (collectArgs expr) of { (fun, _, _, vargs) ->
+ case fun of
+ Var v | length vargs == 0 -> True
+ _ -> False
+ }
+
+{- LATER:
+WAS: MORE CLEVER:
+exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
+ = case (collectArgs expr) of { (fun, _, _, vargs) ->
+ case fun of
+ Var v -> v /= buildId
+ && v /= augmentId
+ && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
+ _ -> False
+ }
+-}
\end{code}
+Question (ADR): What is the above used for? Is a _ccall_ really small
+enough?
%************************************************************************
%* *
\begin{code}
calcUnfoldingGuidance
- :: Bool -- True <=> OK if _scc_s appear in expr
- -> Int -- bomb out if size gets bigger than this
- -> CoreExpr -- expression to look at
+ :: Bool -- True <=> OK if _scc_s appear in expr
+ -> Int -- bomb out if size gets bigger than this
+ -> CoreExpr -- expression to look at
-> UnfoldingGuidance
calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
uf = UnfoldIfGoodArgs
(length ty_binders)
(length val_binders)
- [ b `is_elem` cased_args | b <- val_binders ]
+ (map discount_for val_binders)
size
+ discount_for b | b `is_elem` cased_args = tyConFamilySize tycon
+ | otherwise = 0
+ where
+ (tycon, _, _) = getAppDataTyConExpandingDicts (idType b)
in
-- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
uf
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
- (tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
+ (tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
getAppDataTyConExpandingDicts scrut_ty
size_up_alts _ (PrimAlts alts deflt)
%************************************************************************
%* *
+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
+%* *
+%************************************************************************
+
+We have very limited information about an unfolding expression: (1)~so
+many type arguments and so many value arguments expected---for our
+purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
+a single integer. (3)~An ``argument info'' vector. For this, what we
+have at the moment is a Boolean per argument position that says, ``I
+will look with great favour on an explicit constructor in this
+position.''
+
+Assuming we have enough type- and value arguments (if not, we give up
+immediately), then we see if the ``discounted size'' is below some
+(semi-arbitrary) threshold. It works like this: for every argument
+position where we're looking for a constructor AND WE HAVE ONE in our
+hands, we get a (again, semi-arbitrary) discount [proportion to the
+number of constructors in the type being scrutinized].
+
+\begin{code}
+smallEnoughToInline :: Int -> Int -- Constructor discount and size threshold
+ -> [Bool] -- Evaluated-ness of value arguments
+ -> UnfoldingGuidance
+ -> Bool -- True => unfold it
+
+smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True
+smallEnoughToInline con_discount size_threshold _ UnfoldNever = False
+smallEnoughToInline con_discount size_threshold arg_is_evald_s
+ (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
+ = n_vals_wanted <= length arg_is_evald_s &&
+ discounted_size <= size_threshold
+
+ where
+ discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
+
+ arg_discount no_of_constrs is_evald
+ | is_evald = 1 + no_of_constrs * con_discount
+ | otherwise = 1
+\end{code}
+
+We use this one to avoid exporting inlinings that we ``couldn't possibly
+use'' on the other side. Can be overridden w/ flaggery.
+Just the same as smallEnoughToInline, except that it has no actual arguments.
+
+\begin{code}
+couldBeSmallEnoughToInline :: Int -> Int -- Constructor discount and size threshold
+ -> UnfoldingGuidance
+ -> Bool -- True => unfold it
+
+couldBeSmallEnoughToInline con_discount size_threshold guidance
+ = smallEnoughToInline con_discount size_threshold (repeat True) guidance
+\end{code}
+
+%************************************************************************
+%* *
\subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
%* *
%************************************************************************
#include "HsVersions.h"
module CoreUtils (
- coreExprType, coreAltsType,
+ coreExprType, coreAltsType, coreExprCc,
substCoreExpr, substCoreBindings
, mkCoreIfThenElse
, argToExpr
, unTagBinders, unTagBindersAlts
- , manifestlyWHNF, manifestlyBottom
+
, maybeErrorApp
, nonErrorRHSs
, squashableDictishCcExpr
- , exprSmallEnoughToDup
{-
coreExprArity,
isWrapperFor,
import CoreSyn
-import CostCentre ( isDictCC )
+import CostCentre ( isDictCC, CostCentre, noCostCentre )
import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
-import Pretty ( ppAboves )
+import Pretty ( ppAboves, ppStr )
import PrelVals ( augmentId, buildId )
-import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
+import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( cloneTyVar,
isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
Just (_, res_ty) -> res_ty
\end{code}
+coreExprCc gets the cost centre enclosing an expression, if any.
+It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
+
+\begin{code}
+coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
+coreExprCc (SCC cc e) = cc
+coreExprCc (Lam _ e) = coreExprCc e
+coreExprCc other = noCostCentre
+\end{code}
+
%************************************************************************
%* *
\subsection{Routines to manufacture bits of @CoreExpr@}
\end{code}
\begin{code}
-exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-exprSmallEnoughToDup expr
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
- case fun of
- Var v | length vargs == 0 -> True
- _ -> False
- }
-
-{- LATER:
-WAS: MORE CLEVER:
-exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
- case fun of
- Var v -> v /= buildId
- && v /= augmentId
- && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
- _ -> False
- }
--}
-\end{code}
-Question (ADR): What is the above used for? Is a _ccall_ really small
-enough?
-
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form. It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
-
-\begin{code}
-manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyWHNF (Var _) = True
-manifestlyWHNF (Lit _) = True
-manifestlyWHNF (Con _ _) = True
-manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e) = False
-manifestlyWHNF (Case _ _) = False
-
-manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
-
-manifestlyWHNF other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
- case fun of
- Var f -> let
- num_val_args = length vargs
- in
- num_val_args == 0 -- Just a type application of
- -- a variable (f t1 t2 t3);
- -- counts as WHNF.
- ||
- case (arityMaybe (getIdArity f)) of
- Nothing -> False
- Just arity -> num_val_args < arity
-
- _ -> False
- }
-\end{code}
-
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point. It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
-
-\begin{code}
-manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyBottom (Var v) = isBottomingId v
-manifestlyBottom (Lit _) = False
-manifestlyBottom (Con _ _) = False
-manifestlyBottom (Prim _ _) = False
-manifestlyBottom (SCC _ e) = manifestlyBottom e
-manifestlyBottom (Coerce _ _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e) = manifestlyBottom e
-
- -- We do not assume \x.bottom == bottom:
-manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
-
-manifestlyBottom (Case e a)
- = manifestlyBottom e
- || (case a of
- AlgAlts alts def -> all mbalg alts && mbdef def
- PrimAlts alts def -> all mbprim alts && mbdef def
- )
- where
- mbalg (_,_,e') = manifestlyBottom e'
-
- mbprim (_,e') = manifestlyBottom e'
-
- mbdef NoDefault = True
- mbdef (BindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, _, _) ->
- case fun of
- Var f | isBottomingId f -> True
- -- Application of a function which always gives
- -- bottom; we treat this as a WHNF, because it
- -- certainly doesn't need to be shared!
- _ -> False
- }
-\end{code}
-
-\begin{code}
{-LATER:
coreExprArity
:: (Id -> Maybe (GenCoreExpr bndr Id))
nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
+import IdLoop ( Unfolding ) -- Needed by IdInfo.hi?
import Literal ( Literal{-instances-} )
import Name ( isSymLexeme )
import Outputable -- quite a few things
pragmas =
ifnotPprForUser sty
- (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
+ (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
(getIdInfo binder))
pprBabyCoreBinder sty binder
)
import Match ( matchWrapper )
-import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
- FormSummary )
+import CoreUnfold ( Unfolding )
import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
mkCoreIfThenElse, unTagBinders )
import CostCentre ( mkUserCC )
-- we might should look out for SectionLs, etc., here, but we don't
-dsApp (HsVar v) args
- = lookupEnvDs v `thenDs` \ maybe_expr ->
+dsApp (HsVar v) args = mkAppDs (Var v) args
+
+{- No need to do unfolding in desugarer now
+ = lookupEnvDs v `thenDs` \ maybe_expr ->
case maybe_expr of
Just expr -> mkAppDs expr args
Nothing -> -- we're only saturating constructors and PrimOps
case getIdUnfolding v of
- GenForm _ the_unfolding EssentialUnfolding
+ SimpleUnfolding _ the_unfolding EssentialUnfolding
-> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
_ -> mkAppDs (Var v) args
-
+-}
dsApp anything_else args
= dsExpr anything_else `thenDs` \ core_expr ->
\end{code}
\begin{code}
-do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
- = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
-
-do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
- = dsExprToAtom arg $ \ arg_atom ->
- do_unfold ty_env
- (addOneToIdEnv val_env binder (argToExpr arg_atom))
- body args
-
-do_unfold ty_env val_env body args
- = -- Clone the remaining part of the template
- uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' ->
-
- -- Apply result to remaining arguments
- mkAppDs body' args
+-- do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
+-- = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
+--
+-- do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
+-- = dsExprToAtom arg $ \ arg_atom ->
+-- do_unfold ty_env
+-- (addOneToIdEnv val_env binder (argToExpr arg_atom))
+-- body args
+--
+-- do_unfold ty_env val_env body args
+-- = -- Clone the remaining part of the template
+-- uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' ->
+--
+-- -- Apply result to remaining arguments
+-- mkAppDs body' args
\end{code}
Basically does the translation given in the Haskell~1.3 report:
> SYN_IE(SigmaType), Type
> )
> import CmdLineOpts ( SwitchResult, switchIsOn )
-> import CoreUnfold ( UnfoldingDetails(..) )
+> import CoreUnfold ( Unfolding(..) )
> import CoreUtils ( mkValLam, unTagBinders, coreExprType )
> import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
> isInstId_maybe
> then no_unfold
>
> else case (getIdUnfolding id) of
-> GenForm _ expr guidance ->
-> panic "DefExpr:GenForm has changed a little; needs mod here"
+> SimpleUnfolding _ expr guidance ->
+> panic "DefExpr:SimpleUnfolding has changed a little; needs mod here"
> -- SLPJ March 95
>
>--??? -- ToDo: too much overhead here.
-- others:
import IdInfo
+import SpecEnv ( SpecEnv )
import Outputable ( Outputable(..) )
import Pretty
\end{code}
CHK_Ubiq() -- debugging consistency check
+import CgCompInfo -- Default values for some flags
+
import Maybes ( assocMaybe, firstJust, maybeToBool )
import Util ( startsWith, panic, panic#, assertPanic )
\end{code}
| MaxSimplifierIterations Int
| SimplUnfoldingUseThreshold Int -- per-simplification variants
+ | SimplUnfoldingConDiscount Int
| SimplUnfoldingCreationThreshold Int
| KeepSpecPragmaIds -- We normally *toss* Ids we can do without
',' : _ -> IGNORE_ARG() -- it is for the parser
"-fsimplify" -> -- gather up SimplifierSwitches specially...
- simpl_sep opts [] core_td stg_td
+ simpl_sep opts defaultSimplSwitches core_td stg_td
"-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1)
"-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2)
simpl_sep (opt1:opts) simpl_sw core_td stg_td
= case (_UNPK_ opt1) of
- "(" -> ASSERT (null simpl_sw)
- simpl_sep opts [] core_td stg_td
+ "(" -> simpl_sep opts simpl_sw core_td stg_td
")" -> let
this_simpl = CoreDoSimplify (isAmongSimpl simpl_sw)
in
o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
| starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
| starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
+ | starts_with_sucd -> SIMPL_SW(SimplUnfoldingConDiscount (read after_sucd))
where
maybe_suut = startsWith "-fsimpl-uf-use-threshold" o
maybe_suct = startsWith "-fsimpl-uf-creation-threshold" o
+ maybe_sucd = startsWith "-fsimpl-uf-con-discount" o
maybe_msi = startsWith "-fmax-simplifier-iterations" o
starts_with_suut = maybeToBool maybe_suut
starts_with_suct = maybeToBool maybe_suct
+ starts_with_sucd = maybeToBool maybe_sucd
starts_with_msi = maybeToBool maybe_msi
(Just after_suut) = maybe_suut
(Just after_suct) = maybe_suct
+ (Just after_sucd) = maybe_sucd
(Just after_msi) = maybe_msi
_ -> -- NB: the driver is really supposed to handle bad options
tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20)
tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21)
tagOf_SimplSwitch (SimplUnfoldingUseThreshold _) = ILIT(22)
-tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(23)
-tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(24)
-tagOf_SimplSwitch KeepUnusedBindings = ILIT(25)
-tagOf_SimplSwitch SimplNoLetFromCase = ILIT(26)
-tagOf_SimplSwitch SimplNoLetFromApp = ILIT(27)
-tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(28)
-tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(29)
+tagOf_SimplSwitch (SimplUnfoldingConDiscount _) = ILIT(23)
+tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(24)
+tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(25)
+tagOf_SimplSwitch KeepUnusedBindings = ILIT(26)
+tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27)
+tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28)
+tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29)
+tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(30)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
-isAmongSimpl on_switches
+isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
+ -- in the list; defaults right at the end.
= let
tidied_on_switches = foldl rm_dups [] on_switches
+ -- The fold*l* ensures that we keep the latest switches;
+ -- ie the ones that occur earliest in the list.
sw_tbl :: Array Int SwitchResult
where
mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl
mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
+ mk_assoc_elem k@(SimplUnfoldingConDiscount i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i
mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool True -- I'm here, Mom!
-- cannot have duplicates if we are going to use the array thing
-
rm_dups switches_so_far switch
= if switch `is_elem` switches_so_far
then switches_so_far
|| sw `is_elem` ss
\end{code}
+Default settings for simplifier switches
+
+\begin{code}
+defaultSimplSwitches = [SimplUnfoldingCreationThreshold uNFOLDING_CREATION_THRESHOLD,
+ SimplUnfoldingUseThreshold uNFOLDING_USE_THRESHOLD,
+ SimplUnfoldingConDiscount uNFOLDING_CON_DISCOUNT_WEIGHT,
+ MaxSimplifierIterations 1
+ ]
+\end{code}
+
%************************************************************************
%* *
\subsection{Misc functions for command-line options}
import AbsCSyn ( absCNop, AbstractC )
import AbsCUtils ( flattenAbsC )
+import CoreUnfold ( Unfolding )
import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
import ErrUtils ( pprBagOfErrors, ghcExit )
g_con_tycons
= listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ]
+min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
+ = [ boolTyCon
+ , charTyCon
+ , intTyCon
+ , floatTyCon
+ , doubleTyCon
+ , integerTyCon
+ , liftTyCon
+ , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
+ , returnIntAndGMPTyCon
+ ]
+
+
data_tycons
= [ addrTyCon
, boolTyCon
import PreludePS ( _PackedString )
import Class ( GenClass )
-import CoreUnfold ( mkMagicUnfolding, UnfoldingDetails )
+import CoreUnfold ( mkMagicUnfolding, Unfolding )
import IdUtils ( primOpNameInfo )
import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag )
import PrimOp ( PrimOp )
import Unique ( Unique )
import Usage ( GenUsage )
-mkMagicUnfolding :: Unique -> UnfoldingDetails
+mkMagicUnfolding :: Unique -> Unfolding
mkPrimitiveName :: Unique -> OrigName -> Name
mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
*********************************************************
\begin{code}
-getSourceNames ::
+getSourceNames :: -- Collects global *binders* (not uses)
[RdrNameTyDecl]
-> [RdrNameClassDecl]
-> RdrNameHsBinds
BinderInfo(..),
FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!)
- inlineUnconditionally, oneTextualOcc, oneSafeOcc,
+ inlineUnconditionally, okToInline,
- addBinderInfo, orBinderInfo,
+ addBinderInfo, orBinderInfo,
- argOccurrence, funOccurrence,
+ argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
markMany, markDangerousToDup, markInsideSCC,
getBinderInfoArity,
setBinderInfoArityToZero,
IMP_Ubiq(){-uitous-}
+import CoreUnfold ( FormSummary(..) )
import Pretty
import Util ( panic )
\end{code}
data InsideSCC
= InsideSCC -- Inside an SCC; so be careful when substituting.
| NotInsideSCC -- It's ok.
+
+noBinderInfo = ManyOcc 0 -- A non-committal value
\end{code}
Predicates
~~~~~~~~~~
-@oneTextualOcc@ checks for one occurrence, in any position.
-The occurrence may be inside a lambda, that's all right.
-
\begin{code}
-oneTextualOcc :: Bool -> BinderInfo -> Bool
-
-oneTextualOcc ok_to_dup (OneOcc _ _ _ n_alts _) = n_alts <= 1 || ok_to_dup
-oneTextualOcc _ other = False
-\end{code}
-
-@safeSingleOcc@ detects single occurences of values that are safe to
-inline, {\em including} ones in an argument position.
+okToInline
+ :: FormSummary -- What the thing to be inlined is like
+ -> BinderInfo -- How the thing to be inlined occurs
+ -> Bool -- True => it's small enough to inline
+ -> Bool -- True => yes, inline it
+
+-- Always inline bottoms
+okToInline BottomForm occ_info small_enough
+ = True -- Unless one of the type args is unboxed??
+ -- This used to be checked for, but I can't
+ -- see why so I've left it out.
+
+-- Non-WHNFs can be inlined if they occur once, or are small
+okToInline OtherForm (OneOcc _ _ _ n_alts _) small_enough | n_alts <= 1 = True
+okToInline OtherForm any_occ small_enough = small_enough
+
+-- A WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or
+-- occurs once in each branch of a case and is small
+okToInline form (OneOcc _ NoDupDanger _ n_alts _) small_enough
+ = is_whnf_form form &&
+ (n_alts <= 1 || small_enough)
+ where
+ is_whnf_form VarForm = True
+ is_whnf_form ValueForm = True
+ is_whnf_form other = False
-\begin{code}
-oneSafeOcc :: Bool -> BinderInfo -> Bool
-oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _)
- = n_alts <= 1 || ok_to_dup
-oneSafeOcc _ other = False
+okToInline form any_occ small_enough = False
\end{code}
@inlineUnconditionally@ decides whether a let-bound thing can
= OneOcc posn DupDanger in_scc n_alts ar
markDangerousToDup other = other
+dangerousArgOcc = OneOcc ArgOcc DupDanger NotInsideSCC 1 0
+
markInsideSCC (OneOcc posn dup_danger _ n_alts ar)
= OneOcc posn dup_danger InsideSCC n_alts ar
markInsideSCC other = other
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( whnfDetails, UnfoldingDetails(..), FormSummary(..) )
+import CoreUnfold ( Unfolding(..), SimpleUnfolding )
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
= returnSmpl (Lit (mkMachInt 1))
completePrim env op@SeqOp args@[TyArg ty, VarArg var]
- | whnfDetails (lookupUnfolding env var)
- = returnSmpl (Lit (mkMachInt 1))
- | otherwise
- = returnSmpl (Prim op args)
+ | isEvaluated (lookupRhsInfo env var) = returnSmpl (Lit (mkMachInt 1)) -- var is eval'd
+ | otherwise = returnSmpl (Prim op args) -- var not eval'd
\end{code}
\begin{code}
-- to think that something is top-level when it isn't.
rhs_small_enough rhs
- = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
+ = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of
UnfoldNever -> False
_ -> True -- we didn't BOMB, so it must be OK
lIBERATE_BOMB_SIZE = bombOutSize env
+ cON_DISCOUNT = error "libCaseBind"
\end{code}
-- (note: we can get simplifier switches
-- from the SimplEnv)
-> [CoreArg] -- arguments
- -> SmplM (Maybe CoreExpr))
+ -> Maybe (SmplM CoreExpr))
-- Just result, or Nothing
\end{code}
:: MagicUnfoldingFun
-> SimplEnv
-> [CoreArg]
- -> SmplM (Maybe CoreExpr)
+ -> Maybe (SmplM CoreExpr)
applyMagicUnfoldingFun (MUF fun) env args = fun env args
\end{code}
build_fun :: SimplEnv
-> [CoreArg]
- -> SmplM (Maybe CoreExpr)
+ -> Maybe (SmplM CoreExpr)
build_fun env [TypeArg ty,ValArg (VarArg e)]
- | switchIsSet env SimplDoInlineFoldrBuild =
- let
- tyL = mkListTy ty
- ourCons = CoTyApp (Var consDataCon) ty
- ourNil = CoTyApp (Var nilDataCon) ty
- in
- newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
- returnSmpl(Just (Let (NonRec c ourCons)
- (Let (NonRec n ourNil)
- (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))))
+ | switchIsSet env SimplDoInlineFoldrBuild
+ = Just result
+ where
+ tyL = mkListTy ty
+ ourCons = CoTyApp (Var consDataCon) ty
+ ourNil = CoTyApp (Var nilDataCon) ty
+
+ result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
+ returnSmpl(Let (NonRec c ourCons)
+ (Let (NonRec n ourNil)
+ (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
+
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
-build_fun env _ =
- ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
- returnSmpl Nothing
+build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
+ Nothing
\end{code}
\begin{code}
augment_fun :: SimplEnv
-> [CoreArg]
- -> SmplM (Maybe CoreExpr)
+ -> Maybe (SmplM CoreExpr)
augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
- | switchIsSet env SimplDoInlineFoldrBuild =
- let
- tyL = mkListTy ty
- ourCons = CoTyApp (Var consDataCon) ty
- in
- newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
- returnSmpl (Just (Let (NonRec c ourCons)
- (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)))
+ | switchIsSet env SimplDoInlineFoldrBuild
+ = Just result
+ where
+ tyL = mkListTy ty
+ ourCons = CoTyApp (Var consDataCon) ty
+ result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
+ returnSmpl (Let (NonRec c ourCons)
+ (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
-augment_fun env _ =
- ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
- returnSmpl Nothing
+
+augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
+ Nothing
\end{code}
Now foldr, the way we consume lists.
\begin{code}
foldr_fun :: SimplEnv
-> [CoreArg]
- -> SmplM (Maybe CoreExpr)
+ -> Maybe (SmplM CoreExpr)
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
| do_fb_red && isConsFun env arg_k && isNilForm env arg_z
- = -- foldr (:) [] ==> id
+ -- foldr (:) [] ==> id
-- this transformation is *always* benificial
-- cf. foldr (:) [] (build g) == g (:) []
-- with foldr (:) [] (build g) == build g
-- after unfolding build, they are the same thing.
- tick Foldr_Cons_Nil `thenSmpl_`
- newId (mkListTy ty1) `thenSmpl` \ x ->
- returnSmpl({-trace "foldr (:) []"-} (Just (mkGenApp (Lam x (Var x)) rest_args)))
+ = Just (tick Foldr_Cons_Nil `thenSmpl_`
+ newId (mkListTy ty1) `thenSmpl` \ x ->
+ returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
| do_fb_red && isNilForm env arg_list
- = -- foldr f z [] = z
+ -- foldr f z [] = z
-- again another short cut, helps with unroling of constant lists
- tick Foldr_Nil `thenSmpl_`
- returnSmpl (Just (argToExpr arg_z))
+ = Just (tick Foldr_Nil `thenSmpl_`
+ returnSmpl (argToExpr arg_z)
+ )
| do_fb_red && arg_list_isBuildForm
- = -- foldr k z (build g) ==> g k z
+ -- foldr k z (build g) ==> g k z
-- this next line *is* the foldr/build rule proper.
- tick FoldrBuild `thenSmpl_`
- returnSmpl (Just (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
+ = Just (tick FoldrBuild `thenSmpl_`
+ returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
+ )
| do_fb_red && arg_list_isAugmentForm
- = -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
+ -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
-- this next line *is* the foldr/augment rule proper.
- tick FoldrAugment `thenSmpl_`
- newId ty2 `thenSmpl` \ v ->
- returnSmpl (Just
- (Let (NonRec v (mkGenApp (Var foldrId)
+ = Just (tick FoldrAugment `thenSmpl_`
+ newId ty2 `thenSmpl` \ v ->
+ returnSmpl (
+ Let (NonRec v (mkGenApp (Var foldrId)
[TypeArg ty1,TypeArg ty2,
ValArg arg_k,
ValArg arg_z,
ValArg h]))
- (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))))
+ (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
+ )
| do_fb_red && arg_list_isListForm
- = -- foldr k z (a:b:c:rest) =
+ -- foldr k z (a:b:c:rest) =
-- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
-- NB: 'k' is used just one by foldr, but 'f' is used many
-- times inside the list structure. This means that
-- ele_3 = f b ele_2
-- in f a ele_3
--
- tick Foldr_List `thenSmpl_`
- newIds (
+ = Just (tick Foldr_List `thenSmpl_`
+ newIds (
mkFunTys [ty1, ty2] ty2 :
nOfThem (length the_list) ty2
- ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
- let
- fst_bind = NonRec
+ ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
+ let
+ fst_bind = NonRec
ele_id1
(mkGenApp (Var foldrId)
[TypeArg ty1,TypeArg ty2,
ValArg (VarArg f_id),
ValArg arg_z,
ValArg the_tl])
- rest_binds = zipWith3Equal "Foldr:rest_binds"
+ rest_binds = zipWith3Equal "Foldr:rest_binds"
(\ e v e' -> NonRec e (mkRhs v e'))
ele_ids
(reverse (tail the_list))
(init (ele_id1:ele_ids))
- mkRhs v e = App (App (Var f_id) v) (VarArg e)
- core_list = foldr
+ mkRhs v e = App (App (Var f_id) v) (VarArg e)
+ core_list = foldr
Let
(mkRhs (head the_list) (last (ele_id1:ele_ids)))
(fst_bind:rest_binds)
- in
- returnSmpl (Just (mkGenApp (Lam f_id core_list)
- (ValArg arg_k:rest_args)))
+ in
+ returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
+ )
--
| do_fb_red && arg_list_isStringForm -- ok, its a string!
-- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
- = tick Str_FoldrStr `thenSmpl_`
- returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId)
+ = Just (tick Str_FoldrStr `thenSmpl_`
+ returnSmpl (mkGenApp (Var unpackCStringFoldrId)
(TypeArg ty2:
ValArg (LitArg (MachStr str_val)):
ValArg arg_k:
ValArg arg_z:
- rest_args)))
+ rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
| doing_inlining && isConsFun env arg_k && not dont_fold_back_append
- = -- foldr (:) z xs = xs ++ z
- tick Foldr_Cons `thenSmpl_`
- newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
- returnSmpl (Just (mkGenApp
+ -- foldr (:) z xs = xs ++ z
+ = Just (tick Foldr_Cons `thenSmpl_`
+ newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
+ returnSmpl (mkGenApp
(Lam z (Lam x (mkGenApp
(Var appendId) [
TypeArg ty1,
ValArg (VarArg x),
- ValArg (VarArg z)])))
+ ValArg (VarArg z)]))
rest_args))
+ )
+
| doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
- = -- foldr k args =
+ -- foldr k args =
-- (\ f z xs ->
-- letrec
-- h x = case x of
-- h xs) k args
--
-- tick FoldrInline `thenSmpl_`
- newIds [
+ = Just (newIds [
ty1, -- a :: t1
mkListTy ty1, -- b :: [t1]
ty2, -- v :: t2
(VarArg a))
(VarArg v))
in
- returnSmpl (Just
- (mkGenApp
+ returnSmpl (
+ mkGenApp
(Lam f (Lam z (Lam xs
(Let (Rec [(h,h_rhs)])
(App (Var h) (VarArg xs))))))
- (ValArg arg_k:rest_args)))
+ (ValArg arg_k:rest_args))
+ )
where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
- dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
-foldr_fun _ _ = returnSmpl Nothing
+ doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+ dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
+
+foldr_fun _ _ = Nothing
isConsFun :: SimplEnv -> CoreArg -> Bool
isConsFun env (VarArg v)
= case lookupUnfolding env v of
- GenForm _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
+ SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
| con == consDataCon && x==x' && y==y'
-> ASSERT ( length tys == 1 ) True
_ -> False
isNilForm :: SimplEnv -> CoreArg -> Bool
isNilForm env (VarArg v)
= case lookupUnfolding env v of
- GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
- GenForm _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
+ SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
+ SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
_ -> False
isNilForm env _ = False
getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
getBuildForm env (VarArg v)
= case lookupUnfolding env v of
- GenForm False _ _ _ -> Nothing
+ SimpleUnfolding False _ _ _ -> Nothing
-- not allowed to inline :-(
- GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+ SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
| bld == buildId -> Just g
- GenForm _ (App (App (CoTyApp (Var bld) _)
+ SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
(VarArg g)) h) _
| bld == augmentId && isNilForm env h -> Just g
_ -> Nothing
getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
getAugmentForm env (VarArg v)
= case lookupUnfolding env v of
- GenForm False _ _ _ -> Nothing
+ SimpleUnfolding False _ _ _ -> Nothing
-- not allowed to inline :-(
- GenForm _ (App (App (CoTyApp (Var bld) _)
+ SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
(VarArg g)) h) _
| bld == augmentId -> Just (g,h)
_ -> Nothing
getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
getAppendForm env (VarArg v) =
case lookupUnfolding env v of
- GenForm False _ _ _ -> Nothing -- not allowed to inline :-(
- GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+ SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-(
+ SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
| fld == foldrId && isConsFun env con -> Just (xs,ys)
_ -> Nothing
getAppendForm env _ = Nothing
-> Maybe ([CoreArg],CoreArg)
getListForm env (VarArg v)
= case lookupUnfolding env v of
- GenForm _ (Con id [ty_arg,head,tail]) _
+ SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
| id == consDataCon ->
case getListForm env tail of
Nothing -> Just ([head],tail)
isInterestingArg :: SimplEnv -> CoreArg -> Bool
isInterestingArg env (VarArg v)
= case lookupUnfolding env v of
- GenForm False _ _ UnfoldNever -> False
- GenForm _ exp guide -> True
+ SimpleUnfolding False _ _ UnfoldNever -> False
+ SimpleUnfolding _ exp guide -> True
_ -> False
isInterestingArg env _ = False
foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
| do_fb_red && isNilForm env arg_list
- = -- foldl f z [] = z
+ -- foldl f z [] = z
-- again another short cut, helps with unroling of constant lists
- tick Foldl_Nil `thenSmpl_`
- returnSmpl (Just (argToExpr arg_z))
+ = Just (tick Foldl_Nil `thenSmpl_`
+ returnSmpl (argToExpr arg_z)
+ )
| do_fb_red && arg_list_isBuildForm
- = -- foldl t1 t2 k z (build t3 g) ==>
+ -- foldl t1 t2 k z (build t3 g) ==>
-- let c {- INLINE -} = \ b g' a -> g' (f a b)
-- n {- INLINE -} = \ a -> a
-- in g t1 c n z
-- this next line *is* the foldr/build rule proper.
- tick FoldlBuild `thenSmpl_`
+ = Just(tick FoldlBuild `thenSmpl_`
-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-- n :: t1 -> t1
- newIds [
- {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
- {- pre_n -} mkFunTys [ty1] ty1,
- {- b -} ty2,
- {- g' -} mkFunTys [ty1] ty1,
- {- a -} ty1,
- {- a' -} ty1,
- {- t -} ty1
- ] `thenSmpl` \ [pre_c,
+ newIds [
+ {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+ {- pre_n -} mkFunTys [ty1] ty1,
+ {- b -} ty2,
+ {- g' -} mkFunTys [ty1] ty1,
+ {- a -} ty1,
+ {- a' -} ty1,
+ {- t -} ty1
+ ] `thenSmpl` \ [pre_c,
pre_n,
b,
g',
a',
t] ->
- let
- c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
- c_rhs = Lam b (Lam g' (Lam a
- (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+ let
+ c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
+ c_rhs = Lam b (Lam g' (Lam a
+ (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
(App (Var g') (VarArg t)))))
- n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
- n_rhs = Lam a' (Var a')
- in
- returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
- (mkGenApp (Var g)
- (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
- :ValArg arg_z:rest_args)))))
+ n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+ n_rhs = Lam a' (Var a')
+ in
+ returnSmpl (Let (NonRec c c_rhs) $
+ Let (NonRec n n_rhs) $
+ mkGenApp (Var g)
+ (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
+ :ValArg arg_z:rest_args))
+ )
| do_fb_red && arg_list_isAugmentForm
- = -- foldl t1 t2 k z (augment t3 g h) ==>
+ -- foldl t1 t2 k z (augment t3 g h) ==>
-- let c {- INLINE -} = \ b g' a -> g' (f a b)
-- n {- INLINE -} = \ a -> a
-- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
-- in g t1 c r z
-- this next line *is* the foldr/build rule proper.
- tick FoldlAugment `thenSmpl_`
+ = Just (tick FoldlAugment `thenSmpl_`
-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-- n :: t1 -> t1
- newIds [
- {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
- {- pre_n -} mkFunTys [ty1] ty1,
- {- pre_r -} mkFunTys [ty1] ty1,
- {- b -} ty2,
- {- g_ -} mkFunTys [ty1] ty1,
- {- a -} ty1,
- {- a' -} ty1,
- {- t -} ty1
- ] `thenSmpl` \ [pre_c,
+ newIds [
+ {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+ {- pre_n -} mkFunTys [ty1] ty1,
+ {- pre_r -} mkFunTys [ty1] ty1,
+ {- b -} ty2,
+ {- g_ -} mkFunTys [ty1] ty1,
+ {- a -} ty1,
+ {- a' -} ty1,
+ {- t -} ty1
+ ] `thenSmpl` \ [pre_c,
pre_n,
pre_r,
b,
a',
t] ->
- let
- c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
- c_rhs = Lam b (Lam g_ (Lam a
- (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+ let
+ c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
+ c_rhs = Lam b (Lam g_ (Lam a
+ (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
(App (Var g_) (VarArg t)))))
- n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
- n_rhs = Lam a' (Var a')
- r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
- r_rhs = mkGenApp (Var foldrId)
+ n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+ n_rhs = Lam a' (Var a')
+ r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
+ r_rhs = mkGenApp (Var foldrId)
[TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
ValArg (VarArg c),
ValArg (VarArg n),
ValArg h]
- in
- returnSmpl (Just (Let (NonRec c c_rhs)
- (Let (NonRec n n_rhs)
- (Let (NonRec r r_rhs)
- (mkGenApp (Var g')
+ in
+ returnSmpl (Let (NonRec c c_rhs) $
+ Let (NonRec n n_rhs) $
+ Let (NonRec r r_rhs) $
+ mkGenApp (Var g')
(TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
- :ValArg arg_z:rest_args))))))
+ :ValArg arg_z:rest_args))
+ )
| do_fb_red && arg_list_isListForm
- = -- foldl k z (a:b:c:rest) =
+ -- foldl k z (a:b:c:rest) =
-- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
-- NB: 'k' is used just one by foldr, but 'f' is used many
-- times inside the list structure. This means that
-- ele_3 = f ele_2 c
-- in foldl f ele_3 rest
--
- tick Foldl_List `thenSmpl_`
- newIds (
+ = Just (tick Foldl_List `thenSmpl_`
+ newIds (
mkFunTys [ty1, ty2] ty1 :
nOfThem (length the_list) ty1
- ) `thenSmpl` \ (f_id:ele_ids) ->
- let
- rest_binds = zipWith3Equal "foldl:rest_binds"
+ ) `thenSmpl` \ (f_id:ele_ids) ->
+ let
+ rest_binds = zipWith3Equal "foldl:rest_binds"
(\ e v e' -> NonRec e (mkRhs v e'))
ele_ids -- :: [Id]
the_list -- :: [CoreArg]
(init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
- mkRhs v e = App (App (Var f_id) e) v
+ mkRhs v e = App (App (Var f_id) e) v
- last_bind = mkGenApp (Var foldlId)
+ last_bind = mkGenApp (Var foldlId)
[TypeArg ty1,TypeArg ty2,
ValArg (VarArg f_id),
ValArg (VarArg (last ele_ids)),
ValArg the_tl]
- core_list = foldr
+ core_list = foldr
Let
last_bind
rest_binds
- in
- returnSmpl (Just (mkGenApp (Lam f_id core_list)
- (ValArg arg_k:rest_args)))
+ in
+ returnSmpl (mkGenApp (Lam f_id core_list)
+ (ValArg arg_k:rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
| doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
- = -- foldl k args =
+ -- foldl k args =
-- (\ f z xs ->
-- letrec
-- h x r = case x of
-- in
-- h xs z) k args
--
+ = Just (
-- tick FoldrInline `thenSmpl_`
newIds [
ty2, -- a :: t1
(VarArg b))
(VarArg v))
in
- returnSmpl (Just
+ returnSmpl (
(mkGenApp
(Lam f (Lam z (Lam xs
(Let (Rec [(h,h_rhs)])
(App (App (Var h) (VarArg xs))
(VarArg z))))))
- (ValArg arg_k:rest_args)))
+ (ValArg arg_k:rest_args))
+ )
where
doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
-foldl_fun env _ = returnSmpl Nothing
+foldl_fun env _ = Nothing
\end{code}
--
unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
| switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
- = tick Str_UnpackCons `thenSmpl_`
- returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
+ = Just (tick Str_UnpackCons `thenSmpl_`
+ returnSmpl (mkGenApp (Var unpackCStringAppendId)
[ValArg str,
- ValArg arg_z]))
-unpack_foldr_fun env _ = returnSmpl Nothing
+ ValArg arg_z])
+ )
+unpack_foldr_fun env _ = Nothing
unpack_append_fun env
[ValArg (LitArg (MachStr str_val)),ValArg arg_z]
| switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
- = tick Str_UnpackNil `thenSmpl_`
- returnSmpl (Just (Lit (NoRepStr str_val)))
-unpack_append_fun env _ = returnSmpl Nothing
+ = Just (tick Str_UnpackNil `thenSmpl_`
+ returnSmpl (Lit (NoRepStr str_val))
+ )
+unpack_append_fun env _ = Nothing
-}
\end{code}
= (emptyDetails, Var v)
occAnal env (Lit lit) = (emptyDetails, Lit lit)
-occAnal env (Con con args) = (occAnalArgs env args, Con con args)
occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+\end{code}
+
+We regard variables that occur as constructor arguments as "dangerousToDup":
+
+\begin{verbatim}
+module A where
+f x = let y = expensive x in
+ let z = (True,y) in
+ (case z of {(p,q)->q}, case z of {(p,q)->q})
+\end{verbatim}
+
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
+\begin{code}
+occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
+ Con con args)
occAnal env (SCC cc body)
= (mapIdEnv markInsideSCC usage, SCC cc body')
(fun_usage, fun') = occAnal env fun
arg_usage = occAnalArg env arg
-occAnal env (Lam (ValBinder binder) body)
+-- For value lambdas we do a special hack. Consider
+-- (\x. \y. ...x...)
+-- If we did nothing, x is used inside the \y, so would be marked
+-- as dangerous to dup. But in the common case where the abstraction
+-- is applied to two arguments this is over-pessimistic.
+-- So instead we don't take account of the \y when dealing with x's usage;
+-- instead, the simplifier is careful when partially applying lambdas
+
+occAnal env expr@(Lam (ValBinder binder) body)
= (mapIdEnv markDangerousToDup final_usage,
- Lam (ValBinder tagged_binder) body')
+ foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
where
- (body_usage, body') = occAnal (env `addNewCand` binder) body
- (final_usage, tagged_binder) = tagBinder body_usage binder
+ (binders,body) = collectValBinders expr
+ (body_usage, body') = occAnal (env `addNewCands` binders) body
+ (final_usage, tagged_binders) = tagBinders body_usage binders
-- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
occAnal env (Lam (TyBinder tyvar) body)
import AnnCoreSyn
import CoreSyn
-import CoreUtils ( coreExprType, manifestlyWHNF, manifestlyBottom )
+import CoreUtils ( coreExprType )
+import CoreUnfold ( whnfOrBottom )
import FreeVars -- all of it
import Id ( idType, mkSysLocal, toplevelishId,
nullIdEnv, addOneToIdEnv, growIdEnvList,
offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
- manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
+ manifestly_whnf = whnfOrBottom de_ann_expr
maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
maybe_unTopify lvl = lvl
| otherwise = -- No point in adding a fresh let-binding for a WHNF, because
-- floating it isn't beneficial enough.
isWorthFloatingExpr expr &&
- not (manifestlyWHNF expr || manifestlyBottom expr)
+ not (whnfOrBottom expr)
********** -}
isWorthFloatingExpr :: CoreExpr -> Bool
canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
-valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
+valSuggestsLeakFree expr = whnfOrBottom expr
\end{code}
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( whnfDetails, mkConForm, mkLitForm,
- UnfoldingDetails(..), UnfoldingGuidance(..),
- FormSummary(..)
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
+import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
import TysPrim ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
-- Eliminate unused rhss if poss
rhss = case scrut_form of
- OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
- not (alt_lit `is_elem` not_these)
- ]
+ OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
+ not (alt_lit `is_elem` not_these)
+ ]
other -> [rhs | (_,rhs) <- alts]
AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
-- Eliminate unused alts if poss
possible_alts = case scrut_form of
- OtherConForm not_these ->
+ OtherCon not_these ->
-- Remove alts which can't match
[alt | alt@(alt_con,_,_) <- alts,
not (alt_con `is_elem` not_these)]
-- If the scrutinee is a variable, look it up to see what we know about it
scrut_form = case scrut of
- Var v -> lookupUnfolding env v
- other -> NoUnfoldingDetails
+ Var v -> lookupRhsInfo env v
+ other -> NoRhsInfo
-- If the scrut is already eval'd then there's no worry about
-- eliminating the case
- scrut_is_evald = whnfDetails scrut_form
+ scrut_is_evald = isEvaluated scrut_form
scrut_is_eliminable_primitive
= case scrut of
rhs1_is_scrutinee = case (scrut, rhs1) of
(Var scrut_var, Var rhs_var)
-> case lookupId env rhs_var of
- Just (ItsAnAtom (VarArg rhs_var'))
- -> rhs_var' == scrut_var
- other -> False
+ VarArg rhs_var' -> rhs_var' == scrut_var
+ other -> False
other -> False
is_elem x ys = isIn "completeCase" x ys
simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
returnSmpl (AlgAlts alts' deflt')
where
- deflt_form = OtherConForm [con | (con,_,_) <- alts]
+ deflt_form = OtherCon [con | (con,_,_) <- alts]
do_alt (con, con_args, rhs)
= cloneIds env con_args `thenSmpl` \ con_args' ->
let
env1 = extendIdEnvWithClones env con_args con_args'
new_env = case scrut of
- Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
+ Var v -> extendEnvGivenNewRhs env1 v (Con con args)
+ where
+ (_, ty_args, _) = getAppDataTyConExpandingDicts (idType v)
+ args = map TyArg ty_args ++ map VarArg con_args'
+
other -> env1
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
returnSmpl (PrimAlts alts' deflt')
where
- deflt_form = OtherLitForm [lit | (lit,_) <- alts]
+ deflt_form = OtherLit [lit | (lit,_) <- alts]
do_alt (lit, rhs)
= let
new_env = case scrut of
- Var v -> extendUnfoldEnvGivenFormDetails env v (mkLitForm lit)
+ Var v -> extendEnvGivenNewRhs env v (Lit lit)
other -> env
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
:: SimplEnv
-> OutExpr -- Simplified scrutinee
-> InDefault -- Default alternative to be completed
- -> UnfoldingDetails -- Gives form of scrutinee
+ -> RhsInfo -- Gives form of scrutinee
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
-> SmplM OutDefault
= returnSmpl NoDefault
-- Special case for variable scrutinee; see notes above.
-simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
+simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
+ info_from_this_case rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
- env1 = extendIdEnvWithAtom env binder (VarArg binder')
+ env1 = extendIdEnvWithClone env binder binder'
+ env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
-- Add form details for the default binder
- scrut_form = lookupUnfolding env scrut_var
- final_form
- = case (form_from_this_case, scrut_form) of
- (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
- (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
- other -> form_from_this_case
-
- env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
-
- -- Change unfold details for scrut var. We now want to unfold it
- -- to binder'
- new_scrut_var_form = GenForm WhnfForm (Var binder') UnfoldAlways
-
- new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
-
+ scrut_info = lookupRhsInfo env scrut_var
+ env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
+ new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
-simplDefault env scrut (BindDefault binder rhs) form rhs_c
+simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
+ info_from_this_case rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
- env1 = extendIdEnvWithAtom env binder (VarArg binder')
- new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
+ env1 = extendIdEnvWithClone env binder binder'
+ new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
| alt_con == con
= -- Matching alternative!
let
- new_env = extendIdEnvWithAtomList env (zipEqual "SimplCase" alt_args (filter isValArg con_args))
+ new_env = extendIdEnvWithAtoms env
+ (zipEqual "SimplCase" alt_args (filter isValArg con_args))
in
rhs_c new_env rhs
NoDefault -> -- Blargh!
panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
- BindDefault binder rhs -> -- OK, there's a default case
+ BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
-- let-bind the binder to the constructor
cloneId env binder `thenSmpl` \ id' ->
let
- env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenFormDetails env1 id'
- (mkConForm con con_args)
+ new_env = extendEnvGivenBinding env occ_info id' (Con con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
v | scrut_is_var = Var scrut_var
| otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
- arg_tys = case (maybeAppDataTyConExpandingDicts (idType deflt_var)) of
- Just (_, arg_tys, _) -> arg_tys
+ arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
+ (_, arg_tys, _) -> arg_tys
mkCoCase scrut (PrimAlts
outer_alts
import CoreLint ( lintCoreBindings )
import CoreSyn
import CoreUnfold
-import CoreUtils ( substCoreBindings, manifestlyWHNF )
+import CoreUtils ( substCoreBindings, whnfOrBottom )
import ErrUtils ( ghcExit )
import FiniteMap ( FiniteMap )
import FloatIn ( floatInwards )
import SAT ( doStaticArgs )
import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
import SimplPgm ( simplifyPgm )
-import SimplVar ( leastItCouldCost )
import Specialise
import SpecUtils ( pprSpecErrs )
import StrictAnal ( saWwTopBinds )
-> [CoreBinding] -- input...
-> IO
([CoreBinding], -- results: program, plus...
- IdEnv UnfoldingDetails, -- unfoldings to be exported from here
+ IdEnv Unfolding, -- unfoldings to be exported from here
SpecialiseData) -- specialisation data
core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
\begin{code}
calcInlinings :: Bool -- True => inlinings with _scc_s are OK
- -> IdEnv UnfoldingDetails
+ -> IdEnv Unfolding
-> [CoreBinding]
- -> IdEnv UnfoldingDetails
+ -> IdEnv Unfolding
calcInlinings scc_s_OK inline_env_so_far top_binds
= let
pp_item (binder, details)
= ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
where
- pp_det NoUnfoldingDetails = ppStr "_N_"
+ pp_det NoUnfolding = ppStr "_N_"
--LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
- pp_det (GenForm _ expr guide)
+ pp_det (CoreUnfolding (SimpleUnfolding _ guide expr))
= ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
pp_det other = ppStr "???"
| rhs_mentions_an_unmentionable
|| (not explicit_INLINE_requested
- && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
+ && (rhs_looks_like_a_caf || guidance_size_too_big))
= let
my_my_trace
= if explicit_INLINE_requested
guidance_size
= case guidance of
UnfoldAlways -> 0 -- *extremely* small
- EssentialUnfolding -> 0 -- ditto
UnfoldIfGoodArgs _ _ _ size -> size
- guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
-
guidance_size_too_big
-- Does the guidance suggest that this unfolding will
-- be of no use *no matter* the arguments given to it?
-- Could be more sophisticated...
- = case guidance of
- UnfoldAlways -> False
- EssentialUnfolding -> False
- UnfoldIfGoodArgs _ no_val_args arg_info_vec size
-
- -> if explicit_creation_threshold then
- False -- user set threshold; don't second-guess...
-
- else if no_val_args == 0 && rhs_looks_like_a_data_val then
- False -- we'd like a top-level data constr to be
- -- visible even if it is never unfolded
- else
- let
- cost
- = leastItCouldCost con_discount_weight size no_val_args
- arg_info_vec rhs_arg_tys
- in
--- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
- unfold_use_threshold < cost
--- )
+ = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance)
- rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
+ rhs_looks_like_a_caf = not (whnfOrBottom rhs)
rhs_looks_like_a_data_val
= case (collectBinders rhs) of
#include "HsVersions.h"
module SimplEnv (
- nullSimplEnv,
+ nullSimplEnv, combineSimplEnv,
pprSimplEnv, -- debugging only
- replaceInEnvs, nullInEnvs,
-
extendTyEnv, extendTyEnvList,
simplTy, simplTyInId,
- extendIdEnvWithAtom, extendIdEnvWithAtomList,
- extendIdEnvWithInlining,
+ extendIdEnvWithAtom, extendIdEnvWithAtoms,
extendIdEnvWithClone, extendIdEnvWithClones,
lookupId,
- extendUnfoldEnvGivenRhs,
- extendUnfoldEnvGivenFormDetails,
- extendUnfoldEnvGivenConstructor,
+
+ markDangerousOccs,
+ lookupRhsInfo, lookupOutIdEnv, isEvaluated,
+ extendEnvGivenBinding, extendEnvGivenNewRhs,
+ extendEnvForRecBinding, extendEnvGivenRhsInfo,
+
lookForConstructor,
- lookupUnfolding, filterUnfoldEnvForInlines,
- getSwitchChecker, switchIsSet,
+ getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
- setEnclosingCC,
+ setEnclosingCC, getEnclosingCC,
-- Types
SYN_IE(SwitchChecker),
- SimplEnv, EnclosingCcDetails(..),
- SYN_IE(InIdEnv), IdVal(..), SYN_IE(InTypeEnv),
- UnfoldEnv, UnfoldItem, UnfoldConApp,
+ 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),
IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
-import BinderInfo ( orBinderInfo, oneSafeOcc,
+import BinderInfo ( orBinderInfo, noBinderInfo,
BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
)
import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
-import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
+import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), mkGenForm, mkConForm,
- calcUnfoldingGuidance, UnfoldingGuidance(..),
- mkFormSummary, FormSummary(..)
+import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
+ Unfolding(..), SimpleUnfolding(..), FormSummary(..),
+ mkSimpleUnfolding,
+ calcUnfoldingGuidance, UnfoldingGuidance(..)
)
-import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
+import CoreUtils ( coreExprCc, unTagBinders )
+import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
import FiniteMap -- lots of things
-import Id ( idType, getIdUnfolding, getIdStrictness,
+import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
applyTypeEnvToId,
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
- addOneToIdEnv, modifyIdEnv, mkIdSet,
+ addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
import Literal ( isNoRepLit, Literal{-instances-} )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, expectJust )
import Name ( isLocallyDefined )
import OccurAnal ( occurAnalyseExpr )
import Outputable ( Outputable(..){-instances-} )
SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
)
import Unique ( Unique{-instance Outputable-} )
-import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly,
- delFromUFM, ufmToList
+import UniqFM ( addToUFM_C, ufmToList, eltsUFM
)
--import UniqSet -- lots of things
import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
%* *
%************************************************************************
+\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}
%************************************************************************
%* *
data SimplEnv
= 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
- 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 -> 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"
- OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
- [ppr PprDebug l | l <- ls]]
- OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
- [ppr PprDebug c | c <- cs]]
- GenForm w e g -> ppCat [ppStr "UF:", ppr PprDebug w,
- ppr PprDebug g, ppr PprDebug e]
- MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
- ]
-\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 OutArg -- 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@ type}
-%* *
-%************************************************************************
-
-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!
+ = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
-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.
+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
-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 pair
- = UCA OutId -- data constructor
- [OutArg] -- *value* arguments; see use below
-
-data UnfoldEnv -- yup, a glorified triple...
- = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
-
- (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all)
- -- in-scope ids. The "Id" part is just so that
- -- we can recover the domain of the mapping, which
- -- IdEnvs don't allow directly.
- --
- -- Anything that isn't in here
- -- should be assumed to occur many times.
- -- The things in here all occur once, and the
- -- binder-info tells about whether that "once"
- -- is inside a lambda, or perhaps once in each branch
- -- of a case etc.
- -- We keep this info so we can modify it when
- -- something changes.
-
- (FiniteMap UnfoldConApp [([Type], OutId)])
- -- 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 IdEnv
- -- (1st part of UFE)
-
-null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
+pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
\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 -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
-lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
-lookup_unfold_env_encl_cc
- :: UnfoldEnv -> OutId -> EnclosingCcDetails
-
-grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
-
-grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- new_occ_env
- new_con_apps
- where
- new_occ_env = modify_occ_info occ_env id occ_info
-
- new_con_apps
- = case uf_details of
- GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
- not_a_constructor -> con_apps -- unchanged
-
-addto_unfold_env (UFE u_env occ_env 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) occ_env con_apps
- where
- constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
- constructor_form_in_those _ = False
-
-rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-
-get_interesting_ids (UFE _ occ_env _)
- = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
-
-foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
- = UFE u_env (foldr fun occ_env stuff) 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
-
-lookup_conapp (UFE _ _ con_apps) con args
- = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp"))
-
--- Returns two things; we just fst or snd the one we want:
-lookup_conapp_help con_apps con args outid
- = case (span notValArg args) of { (ty_args, val_args) ->
- let
- entry = UCA con val_args
- arg_tys = [ t | TyArg t <- ty_args ]
- in
- case (lookupFM con_apps entry) of
- Nothing -> (Nothing,
- addToFM con_apps entry [(arg_tys, outid)])
- Just assocs
- -> ASSERT(not (null assocs))
- case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of
- [o] -> (Just o,
- con_apps) -- unchanged; we hang onto what we have
- [] -> (Nothing,
- addToFM con_apps entry ((arg_tys, outid) : assocs))
- _ -> panic "grow_unfold_env:dup in assoc list"
- }
- where
- eq_tys ts1 ts2
- = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False }
-
- cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
- = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
-
-modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
- = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
-
-modify_occ_info occ_env id other_new_occ
- = -- Many or Dead occurrence, just delete from occ_env
- delFromUFM occ_env id
-\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 (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}
-
-%************************************************************************
-%* *
-\subsubsection{The @EnclosingCcDetails@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-data EnclosingCcDetails
- = NoEnclosingCcDetails
- | EnclosingCC CostCentre
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
-%* *
-%************************************************************************
-
-\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}
-
-%************************************************************************
-%* *
-\subsection{@SimplEnv@ handling}
-%* *
-%************************************************************************
%************************************************************************
%* *
\begin{code}
getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
+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}
-setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
+setEnclosingCC :: SimplEnv -> CostCentre -> 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}
%************************************************************************
type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
extendTyEnv :: SimplEnv -> TyVar -> Type -> 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 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,Type)] -> 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 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)
-
-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 -> OutArg{-Val args only, please-}
- -> SimplEnv
-
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id,occ_info) atom@(LitArg lit)
- = SimplEnv chkr encl_cc ty_env new_id_env 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}
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps))
- (in_id, occ_info) atom@(VarArg 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)
- new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps
- -- Modify occ info for out_id
+\begin{code}
+lookupId :: SimplEnv -> Id -> OutArg
-#ifdef DEBUG
-extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
-#endif
+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, OutArg)]
- -> 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 (VarArg 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 (zipEqual "extendIdEnvWithClones" in_ids out_vals)
- in_ids = [id | (id,_) <- in_binders]
- out_vals = [ItsAnAtom (VarArg 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 fake_occ_info good_details encl_cc
- fake_occ_info = {-ToDo!-} ManyOcc 0 -- generally paranoid
-
-extendUnfoldEnvGivenConstructor -- specialised variant
- :: SimplEnv
- -> OutId -- bind this to...
- -> Id -> [OutId] -- "con <tys-to-be-invented> args"
- -> SimplEnv
+\end{code}
+
+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 = idType var
- (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
- in
- extendUnfoldEnvGivenFormDetails
- env var (mkConForm con (map TyArg ty_args ++ map VarArg 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}
+\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:
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
+ 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 (ufmToList fv_occ_info)
+ env1 = addToUFM_C modifyOutEnvItem out_id_env out_id
+ (out_id, occ_info, OutUnfolding unf_cc unfolding)
+
-- 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
+ unfolding = SimpleUnfolding form_summary guidance template
+ form_summary = mkFormSummary rhs
+
+ guidance | not (switchIsSet env IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
+ = UnfoldAlways
- interesting_fvs = get_interesting_ids unfold_env -- Ids in dom of OccEnv
+ | otherwise
+ = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
+
+ bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
+
+ -- Compute cost centre for thing
+ unf_cc | noCostCentreAttached expr_cc = encl_cc
+ | otherwise = expr_cc
+ where
+ expr_cc = coreExprCc rhs
+
+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 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,
+ -- 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, InUnfolding env unfolding)
-- Compute unfolding details
- details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs)
- template guidance
-
- -- Compute resulting unfold env
- new_unfold_env = case details of
- NoUnfoldingDetails -> unfold_env
- other -> unfold_env1
-
- -- Add unfolding to unfold env
- unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc
-
-{- OLD: done in grow_unfold_env
- -- Modify unfoldings of free vars of rhs, based on their
- -- occurrence info in the rhs [see notes above]
- unfold_env2
- = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info)
- where
- modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo)
- modify (u, item@(i,occ_info)) env
- = if maybeToBool (lookupUFM_Directly env u) then
- -- it occurred before, so now it occurs multiple times;
- -- therefore, *delete* it from the occ(urs once) env.
- delFromUFM_Directly env u
-
- else if not (oneSafeOcc ok_to_dup occ_info) then
- env -- leave it alone
- else
- addToUFM_Directly env u item
--}
-
- -- 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
---NO: || 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
- (Var _, _, _, xs) -> length xs < 10
- _ -> False
--}
+ unfolding = SimpleUnfolding form_summary guidance old_rhs
+ form_summary = mkFormSummary old_rhs
+
+ guidance | not (switchIsSet env IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
+ = UnfoldAlways
+
+ | otherwise
+ = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE (unTagBinders old_rhs)
+
+ 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 @GenForm@ 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,con)]
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
-- a = leInt#! p q
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 args
- = lookup_conapp unfold_env 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}
+
+
+
IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of
import Id ( mkSysLocal, mkIdWithNewUniq )
+import CoreUnfold ( SimpleUnfolding )
import SimplEnv
import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( cloneTyVar )
| CaseOfError
| TyBetaReduction
| BetaReduction
+ | SpecialisationDone
{- BEGIN F/B ENTRIES -}
-- the 8 rules
| FoldrBuild -- foldr f z (build g) ==>
showsPrec p CaseOfError = showString "CaseOfError "
showsPrec p TyBetaReduction = showString "TyBetaReduction "
showsPrec p BetaReduction = showString "BetaReduction "
+ showsPrec p SpecialisationDone
+ = showString "Specialisation "
+
-- Foldr/Build Stuff:
showsPrec p FoldrBuild = showString "FoldrBuild "
showsPrec p FoldrAugment = showString "FoldrAugment "
(CaseOfError, 0),
(TyBetaReduction,0),
(BetaReduction,0),
+ (SpecialisationDone,0),
-- Foldr/Build Stuff:
(FoldrBuild, 0),
(FoldrAugment, 0),
tickN :: TickType -> Int -> SmplM ()
+tickN tick_type 0 us counts
+ = ((), counts)
tickN tick_type IBOX(increment) us (SimplCount n stuff)
= ((), SimplCount (n _ADD_ increment)
#ifdef OMIT_SIMPL_COUNTS
IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_D_verbose_core2core,
- switchIsOn, intSwitchSet, SimplifierSwitch(..)
+ switchIsOn, SimplifierSwitch(..)
)
import CoreSyn
+import CoreUnfold ( SimpleUnfolding )
import CoreUtils ( substCoreExpr )
import Id ( externallyVisibleId,
mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
occur_anal = occurAnalyseBinds
- max_simpl_iterations
- = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
- Nothing -> 1 -- default
- Just max -> max
+ max_simpl_iterations = getSimplIntSwitch s_sw_chkr MaxSimplifierIterations
simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUtils ( manifestlyWHNF )
+import CoreUnfold ( SimpleUnfolding, mkFormSummary, FormSummary(..) )
import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
getIdArity, GenId{-instance Eq-}
)
try (App (App (Var bld) _) _) | bld == buildId = True
try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
- try other = manifestlyWHNF other
- {- but *not* necessarily "manifestlyBottom other"...
+ try other = case mkFormSummary other of
+ VarForm -> True
+ ValueForm -> True
+ other -> False
+ {- but *not* necessarily "BottomForm"...
We may want to float a let out of a let to expose WHNFs,
but to do that to expose a "bottom" is a Bad Idea:
#include "HsVersions.h"
module SimplVar (
- completeVar,
- leastItCouldCost
+ completeVar
) where
IMP_Ubiq(){-uitous-}
import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
-import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
+import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( whnfDetails, UnfoldingDetails(..), UnfoldingGuidance(..),
- FormSummary(..)
- )
-import Id ( idType, getIdInfo,
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
+ FormSummary,
+ smallEnoughToInline )
+import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
+
+import CostCentre ( CostCentre, noCostCentreAttached )
+import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
GenId{-instance Outputable-}
)
+import SpecEnv ( SpecEnv, lookupSpecEnv )
import IdInfo ( DeforestInfo(..) )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
import TyCon ( tyConFamilySize )
import Type ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts )
import Util ( pprTrace, assertPanic, panic )
+import Maybes ( maybeToBool )
\end{code}
%************************************************************************
This where all the heavy-duty unfolding stuff comes into its own.
-
+\begin{code}
completeVar env var args
- | has_magic_unfolding
+
+ | maybeToBool maybe_magic_result
= tick MagicUnfold `thenSmpl_`
- doMagicUnfold
+ magic_result
- | has_unfolding && ok_to_inline
+ | not do_deforest &&
+ maybeToBool maybe_unfolding_info &&
+ (always_inline || (ok_to_inline && not essential_unfoldings_only)) &&
+ costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
= tick UnfoldingDone `thenSmpl_`
- simplExpr env the_unfolding args
+ simplExpr unfold_env unf_template args
- | has_specialisation
+ | maybeToBool maybe_specialisation
= tick SpecialisationDone `thenSmpl_`
simplExpr (extendTyEnvList env spec_bindings)
- the_specialisation
- remaining_args
-
- | otherwise
- = mkGenApp (Var var) args
-
- where
- unfolding = lookupUnfolding env var
-
- (has_magic_unfolding, do_magic_unfold)
- = case unfolding of
- MagicForm str magic_fn
-
-\begin{code}
-completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
-
-completeVar env var args
- = let
- boring_result = mkGenApp (Var var) args
- in
- case (lookupUnfolding env var) of
-
- GenForm form_summary template guidance
- -> considerUnfolding env var args
- (False{-ToDo:!-}{-txt_occ-}) form_summary template guidance
-
- MagicForm str magic_fun
- -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
- case result of
- Nothing -> returnSmpl boring_result
- Just magic_result ->
- {- pprTrace "MagicForm:- " (ppAbove
- (ppBesides [
- ppr PprDebug var,
- ppr PprDebug args])
- (ppBesides [
- ppStr "AFTER :- ",
- ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
- -}
- tick MagicUnfold `thenSmpl_`
- returnSmpl magic_result
-
--- LATER:
--- IWantToBeINLINEd _ -> returnSmpl boring_result
-
- other -> returnSmpl boring_result
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
-%* *
-%************************************************************************
-
-We have very limited information about an unfolding expression: (1)~so
-many type arguments and so many value arguments expected---for our
-purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
-a single integer. (3)~An ``argument info'' vector. For this, what we
-have at the moment is a Boolean per argument position that says, ``I
-will look with great favour on an explicit constructor in this
-position.''
-
-Assuming we have enough type- and value arguments (if not, we give up
-immediately), then we see if the ``discounted size'' is below some
-(semi-arbitrary) threshold. It works like this: for every argument
-position where we're looking for a constructor AND WE HAVE ONE in our
-hands, we get a (again, semi-arbitrary) discount [proportion to the
-number of constructors in the type being scrutinized].
-
-\begin{code}
-considerUnfolding
- :: SimplEnv
- -> OutId -- Id we're thinking about
- -> [OutArg] -- Applied to these
- -> Bool -- If True then *always* inline,
- -- because it's the only one
- -> FormSummary
- -> InExpr -- Template for unfolding;
- -> UnfoldingGuidance -- To help us decide...
- -> SmplM CoreExpr -- Result!
-
-considerUnfolding env var args txt_occ form_summary template guidance
- | switchIsOn sw_chkr EssentialUnfoldingsOnly
- = dont_go_for_it -- we're probably in a hurry in this simpl round...
-
- | do_deforest
- = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
- ppr PprDebug var,
- ppStr "' due to DEFOREST pragma"])
- dont_go_for_it
-
- | txt_occ
- = go_for_it
-
- | (case form_summary of {BottomForm -> True; other -> False} &&
- not (any isPrimType [ ty | (TyArg ty) <- args ]))
- -- Always inline bottoming applications, unless
- -- there's a primitive type lurking around...
- = go_for_it
+ spec_template
+ (map TyArg leftover_ty_args ++ remaining_args)
| otherwise
- =
- -- If this is a deforestable Id, then don't unfold it (the deforester
- -- will do it).
-
- case getInfo (getIdInfo var) of {
- DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
- ppr PprDebug var,
- ppStr "' due to DEFOREST pragma"])
- dont_go_for_it;
- Don'tDeforest ->
-
- case guidance of
- UnfoldNever -> dont_go_for_it
-
- UnfoldAlways -> go_for_it
-
- EssentialUnfolding -> go_for_it
-
- UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
- -> if m_tys_wanted > no_tyargs
- || n_vals_wanted > no_valargs then
- --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
- dont_go_for_it
-
- else if n_vals_wanted == 0
- && rhs_looks_like_a_Con then
- -- we are very keen on inlining data values
- -- (see comments elsewhere); we ignore any size issues!
- go_for_it
+ = returnSmpl (mkGenApp (Var var) args)
- else -- we try the fun stuff
- let
- discounted_size
- = discountedCost env con_discount size no_valargs is_con_vec valargs
- in
- if discounted_size <= unfold_use_threshold then
- go_for_it
- else
- --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
- dont_go_for_it
- }
where
- sw_chkr = getSwitchChecker env
-
- unfold_use_threshold
- = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
- Nothing -> uNFOLDING_USE_THRESHOLD
- Just xx -> xx
-
- con_discount -- ToDo: ************ get from a switch *********
- = uNFOLDING_CON_DISCOUNT_WEIGHT
-
- (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
- no_tyargs = length tyargs
- no_valargs = length valargs
- args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
- -- we concoct this dummy expr, just so we can use collectArgs
- -- (rather than make up a special-purpose bit of code)
-
- rhs_looks_like_a_Con
- = let
- (_,_,val_binders,body) = collectBinders template
- in
- case (val_binders, body) of
- ([], Con _ _) -> True
- other -> False
-
- dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
-
- go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
- tick UnfoldingDone `thenSmpl_`
- simplExpr env template args
- --)
+ unfolding_from_id = getIdUnfolding var
+
+ ---------- Magic unfolding stuff
+ maybe_magic_result = case unfolding_from_id of
+ MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
+ env args
+ other -> Nothing
+ (Just magic_result) = maybe_magic_result
+
+ ---------- Unfolding stuff
+ maybe_unfolding_info
+ = case (lookupOutIdEnv env var, unfolding_from_id) of
+ (Just (_, occ_info, OutUnfolding enc_cc unf), _)
+ -> Just (occ_info, setEnclosingCC env enc_cc, unf)
+ (Just (_, occ_info, InUnfolding env_unf unf), _)
+ -> Just (occ_info, combineSimplEnv env env_unf, unf)
+ (_, CoreUnfolding unf)
+ -> Just (noBinderInfo, env, unf)
+
+ other -> Nothing
+
+ Just (occ_info, unfold_env, simple_unfolding) = maybe_unfolding_info
+ SimpleUnfolding form guidance unf_template = simple_unfolding
+
+ ---------- Specialisation stuff
+ (ty_args, remaining_args) = initialTyArgs args
+ maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
+ (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation
+
+
+ ---------- Switches
+ sw_chkr = getSwitchChecker env
+ essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
+ always_inline = case guidance of {UnfoldAlways -> True; other -> False}
+ ok_to_inline = okToInline form
+ occ_info
+ small_enough
+ small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
+ arg_evals = [is_evald arg | arg <- args, isValArg arg]
+
+ is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
+ is_evald (LitArg l) = True
+
+ con_disc = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
+ unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
#if OMIT_DEFORESTER
do_deforest = False
#else
do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
#endif
-\end{code}
-\begin{code}
-type ArgInfoVector = [Bool]
-
-discountedCost
- :: SimplEnv -- so we can look up things about the args
- -> Int -- the discount for a "constructor" hit;
- -- we multiply by the # of cons in the type.
- -> Int -- the size/cost of the expr
- -> Int -- the number of val args (== length args)
- -> ArgInfoVector -- what we know about the *use* of the arguments
- -> [OutArg] -- *an actual set of value arguments*!
- -> Int
-
- -- If we apply an expression (usually a function) of given "costs"
- -- to a particular set of arguments (possibly none), what will
- -- the resulting expression "cost"?
-
-discountedCost env con_discount_weight size no_args is_con_vec args
- = ASSERT(no_args == length args)
- disc (size - no_args) is_con_vec args
- -- we start w/ a "discount" equal to the # of args...
- where
- disc size [] _ = size
- disc size _ [] = size
-
- disc size (want_con_here:want_cons) (arg:rest_args)
- = let
- full_price = disc size
- take_something_off v = let
- (tycon, _, _) = getAppDataTyConExpandingDicts (idType v)
- no_cons = tyConFamilySize tycon
- reduced_size
- = size - (no_cons * con_discount_weight)
- in
- disc reduced_size
- in
- (if not want_con_here then
- full_price
- else
- case arg of
- LitArg _ -> full_price
- VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v
- | otherwise -> full_price
- ) want_cons rest_args
-\end{code}
+-- costCentreOk checks that it's ok to inline this thing
+-- The time it *isn't* is this:
+--
+-- f x = let y = E in
+-- scc "foo" (...y...)
+--
+-- Here y has a subsumed cost centre, and we can't inline it inside "foo",
+-- regardless of whether E is a WHNF or not.
-We use this one to avoid exporting inlinings that we ``couldn't possibly
-use'' on the other side. Can be overridden w/ flaggery.
-\begin{code}
-leastItCouldCost
- :: Int
- -> Int -- the size/cost of the expr
- -> Int -- number of value args
- -> ArgInfoVector -- what we know about the *use* of the arguments
- -> [Type] -- NB: actual arguments *not* looked at;
- -- but we know their types
- -> Int
-
-leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
- = ASSERT(no_val_args == length arg_tys)
- disc (size - no_val_args) is_con_vec arg_tys
- -- we start w/ a "discount" equal to the # of args...
- where
- -- ToDo: rather sad that this isn't commoned-up w/ the one above...
-
- disc size [] _ = size
- disc size _ [] = size
-
- disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
- = let
- take_something_off tycon
- = let
- no_cons = tyConFamilySize tycon
-
- reduced_size
- = size - (no_cons * con_discount_weight)
- in
- reduced_size
- in
- if not want_con_here then
- disc size want_cons rest_arg_tys
- else
- case (maybeAppDataTyConExpandingDicts arg_ty, isPrimType arg_ty) of
- (Just (tycon, _, _), False) ->
- disc (take_something_off tycon) want_cons rest_arg_tys
-
- other -> disc size want_cons rest_arg_tys
-\end{code}
+costCentreOk cc_encl cc_rhs
+ = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs)
+\end{code}
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
+import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, FormSummary(..) )
import CostCentre ( isSccCountCostCentre, cmpCostCentre )
import CoreSyn
import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
- unTagBinders, squashableDictishCcExpr,
- manifestlyWHNF
+ unTagBinders, squashableDictishCcExpr
)
import Id ( idType, idWantsToBeINLINEd,
getIdDemandInfo, addIdDemandInfo,
2. Conditional. In all other situations, the simplifer simplifies
the RHS anyway, and keeps the new binding. It also binds the new
-(cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
+(cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
-Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
+Here, ``suitable'' might mean NoUnfolding (if the occurrence
info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
the variable has an INLINE pragma on it). The idea is that anything
in the UnfoldEnv is safe to use, but also has an enclosing binding if
things in the UnfoldEnv with UnfoldAlways flags, which originated in
other INLINE pragmas.)
-So, we clean out the UnfoldEnv of all GenForm inlinings before
+So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
going into such an RHS.
What about imports? They don't really matter much because we only
-- Dead code is now discarded by the occurrence analyser,
-simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
- | inlineUnconditionally ok_to_dup_code occ_info
- = let
- new_env = extendIdEnvWithInlining env env binder rhs
- in
- simplTopBinds new_env binds
- where
- ok_to_dup_code = switchIsSet env SimplOkToDupCode
-
simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
= -- No cloning necessary at top level
-- Process the binding
- simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- let
- new_env = case rhs' of
- Var v -> extendIdEnvWithAtom env binder (VarArg v)
- Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
- other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
- in
+ simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
+ completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds1') ->
+
-- Process the other bindings
- simplTopBinds new_env binds `thenSmpl` \ binds' ->
+ simplTopBinds new_env binds `thenSmpl` \ binds2' ->
-- Glue together and return ...
- -- We leave it to susequent occurrence analysis to throw away
- -- an unused atom binding. This localises the decision about
- -- discarding top-level bindings.
- returnSmpl (NonRec in_id rhs' : binds')
+ returnSmpl (binds1' ++ binds2')
simplTopBinds env (Rec pairs : binds)
- = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
+ = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) ->
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds' ->
-- Glue together and return
returnSmpl (bind' : binds')
where
- triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
- -- No cloning necessary at top level
+ ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level
\end{code}
%************************************************************************
\begin{code}
simplExpr env (Var v) args
= case (lookupId env v) of
- Nothing -> let
- new_v = simplTyInId env v
- in
- completeVar env new_v args
-
- Just info ->
- case info of
- ItsAnAtom (LitArg lit) -- A boring old literal
- -- Paranoia check for args empty
- -> case args of
- [] -> returnSmpl (Lit lit)
- other -> panic "simplExpr:coVar"
-
- ItsAnAtom (VarArg var) -- More interesting! An id!
- -- No need to substitute the type env here,
- -- because we already have!
- -> completeVar env var args
-
- InlineIt id_env ty_env in_expr -- A macro-expansion
- -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
+ LitArg lit -- A boring old literal
+ -> ASSERT( null args )
+ returnSmpl (Lit lit)
+
+ VarArg var -- More interesting! An id!
+ -> completeVar env var args
+ -- Either Id is in the local envt, or it's a global.
+ -- In either case we don't need to apply the type
+ -- environment to it.
\end{code}
Literals
\begin{code}
simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
= -- ASSERT(not (isPrimType ty))
- let
- new_env = extendTyEnv env tyvar ty
- in
tick TyBetaReduction `thenSmpl_`
- simplExpr new_env body args
+ simplExpr (extendTyEnv env tyvar ty) body args
simplExpr env tylam@(Lam (TyBinder tyvar) body) []
= do_tylambdas env [] tylam
Ordinary lambdas
~~~~~~~~~~~~~~~~
-\begin{code}
-simplExpr env (Lam (ValBinder binder) body) args
- | null leftover_binders
- = -- The lambda is saturated (or over-saturated)
- tick BetaReduction `thenSmpl_`
- simplExpr env_for_enough_args body leftover_args
-
- | otherwise
- = -- Too few args to saturate the lambda
- ASSERT( null leftover_args )
+There's a complication with lambdas that aren't saturated.
+Suppose we have:
- (if not (null args) -- ah, we must've gotten rid of some...
- then tick BetaReduction
- else returnSmpl (panic "BetaReduction")
- ) `thenSmpl_`
+ (\x. \y. ...x...)
- simplLam env_for_too_few_args leftover_binders body
- 0 {- Guaranteed applied to at least 0 args! -}
+If we did nothing, x is used inside the \y, so would be marked
+as dangerous to dup. But in the common case where the abstraction
+is applied to two arguments this is over-pessimistic.
+So instead we don't take account of the \y when dealing with x's usage;
+instead, the simplifier is careful when partially applying lambdas.
+\begin{code}
+simplExpr env expr@(Lam (ValBinder binder) body) orig_args
+ = go 0 env expr orig_args
where
- (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
-
- env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
-
- env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
-
- -- Since there aren't enough args the binders we are cancelling with
- -- the args supplied are, in effect, ocurring inside a lambda.
- -- So we modify their occurrence info to reflect this fact.
- -- Example: (\ x y z -> e) p q
- -- ==> (\z -> e[p/x, q/y])
- -- but we should behave as if x and y are marked "inside lambda".
- -- The occurrence analyser does not mark them so itself because then we
- -- do badly on the very common case of saturated lambdas applications:
- -- (\ x y z -> e) p q r
- -- ==> e[p/x, q/y, r/z]
- --
- zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
- | ((id, occ_info), arg) <- binder_args_pairs ]
-
- collect_val_args :: InBinder -- Binder
- -> [OutArg] -- Arguments
- -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
- [InBinder], -- Leftover binders (ToDo: a maybe)
- [OutArg]) -- Leftover args
-
- -- collect_val_args strips off the leading ValArgs from
- -- the current arg list, returning them along with the
- -- depleted list
- collect_val_args binder [] = ([], [binder], [])
- collect_val_args binder (arg : args) | isValArg arg
- = ([(binder,arg)], [], args)
-
-#ifdef DEBUG
- collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
- -- TyArg should never meet a Lam
-#endif
+ go n env (Lam (ValBinder binder) body) (val_arg : args)
+ | isValArg val_arg -- The lambda has an argument
+ = tick BetaReduction `thenSmpl_`
+ go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
+
+ go n env expr@(Lam (ValBinder binder) body) args
+ -- The lambda is un-saturated, so we must zap the occurrence info
+ -- on the arguments we've already beta-reduced into the body of the lambda
+ = ASSERT( null args ) -- Value lambda must match value argument!
+ let
+ new_env = markDangerousOccs env (take n orig_args)
+ in
+ simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
+
+ go n env non_val_lam_expr args -- The lambda had enough arguments
+ = simplExpr env non_val_lam_expr args
\end{code}
\begin{code}
simplExpr env (Let bind body) args
-
-{- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
- and it doesn't seem worth retaining the ability to not float applications
- into let/case
-
- | switchIsSet env SimplNoLetFromApp
- = simplBind env bind (\env -> simplExpr env body [])
- (computeResultType env body []) `thenSmpl` \ let_expr' ->
- returnSmpl (mkGenApp let_expr' args)
-
- | otherwise -- No float from application
--}
-
= simplBind env bind (\env -> simplExpr env body args)
(computeResultType env body args)
\end{code}
\begin{code}
simplExpr env (SCC cost_centre body) args
= let
- new_env = setEnclosingCC env (EnclosingCC cost_centre)
+ new_env = setEnclosingCC env cost_centre
in
simplExpr new_env body args `thenSmpl` \ body' ->
returnSmpl (SCC cost_centre body')
| otherwise -- Have a go at eta expansion
= -- Deal with the big lambda part
+ ASSERT( null uvars ) -- For now
+
mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
let
lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
in
-- Deal with the little lambda part
- -- Note that we call simplLam even if there are no binders, in case
- -- it can do arity expansion.
- simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
+ -- Note that we call simplLam even if there are no binders,
+ -- in case it can do arity expansion.
+ simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' ->
-- Put it back together
returnSmpl (
else mkTyLam) tyvars' lambda'
)
where
- -- Note from ANDY:
- -- If you say {-# INLINE #-} then you get what's coming to you;
- -- you are saying inline the rhs, please.
- -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
- rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
- | otherwise = env
- (uvars, tyvars, binders, body) = collectBinders rhs
+ rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
+ idWantsToBeINLINEd id
+ = switchOffInlining env
+ | otherwise
+ = env
+
+ -- Switch off all inlining in the RHS of things that have an INLINE pragma.
+ -- They are 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.
+ -- It's very important to switch off inlining! Consider:
+ --
+ -- 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.
- min_no_of_args | not (null binders) && -- It's not a thunk
- switchIsSet env SimplDoArityExpand -- Arity expansion on
- = getBinderInfoArity occ_info - length binders
+ -- 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!
- | otherwise -- Not a thunk
- = 0 -- Play safe!
+ (uvars, tyvars, body) = collectUsageAndTyBinders rhs
-- dont_eta_expand prevents eta expansion in silly situations.
-- For example, consider the defn
the abstraction will always be applied to at least min_no_of_args.
\begin{code}
-simplLam env binders body min_no_of_args
+simplValLam env expr min_no_of_args
| not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
+ null binders || -- or it's a thunk
null potential_extra_binder_tys || -- or ain't a function
- no_of_extra_binders == 0 -- or no extra binders needed
+ no_of_extra_binders <= 0 -- or no extra binders needed
= cloneIds env binders `thenSmpl` \ binders' ->
let
new_env = extendIdEnvWithClones env binders binders'
)
where
+ (binders,body) = collectValBinders expr
(potential_extra_binder_tys, res_ty)
= splitFunTy (simplTy env (coreExprType (unTagBinders body)))
- -- Note: it's possible that simplLam will be applied to something
+ -- Note: it's possible that simplValLam will be applied to something
-- with a forall type. Eg when being applied to the rhs of
-- let x = wurble
-- where wurble has a forall-type, but no big lambdas at the top.
no_of_extra_binders = -- First, use the info about how many args it's
-- always applied to in its scope
- min_no_of_args
+ (min_no_of_args - length binders)
-- Next, try seeing if there's a lambda hidden inside
-- something cheap
-- Try cancellation; we do this "on the way up" because
-- I think that's where it'll bite best
- mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
mkCoerce coercion ty body = Coerce coercion ty body
\end{code}
-- Dead code is now discarded by the occurrence analyser,
simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
- | inlineUnconditionally ok_to_dup occ_info
- = body_c (extendIdEnvWithInlining env env binder rhs)
-
--- Try let-to-case
--- It's important to try let-to-case before floating. Consider
---
--- let a*::Int = case v of {p1->e1; p2->e2}
--- in b
---
--- (The * means that a is sure to be demanded.)
--- If we do case-floating first we get this:
---
--- let k = \a* -> b
--- in case v of
--- p1-> let a*=e1 in k a
--- p2-> let a*=e2 in k a
---
--- Now watch what happens if we do let-to-case first:
---
--- case (case v of {p1->e1; p2->e2}) of
--- Int a# -> let a*=I# a# in b
--- ===>
--- let k = \a# -> let a*=I# a# in b
--- in case v of
--- p1 -> case e1 of I# a# -> k a#
--- p1 -> case e1 of I# a# -> k a#
---
--- The latter is clearly better. (Remember the reboxing let-decl
--- for a is likely to go away, because after all b is strict in a.)
-
- | will_be_demanded &&
- try_let_to_case &&
- type_ok_for_let_to_case rhs_ty &&
- not (manifestlyWHNF rhs)
- -- note: no "manifestlyBottom rhs" in there... (comment below)
- = tick Let2Case `thenSmpl_`
- mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
- simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
- {-
- We do not do let to case for WHNFs, e.g.
-
- let x = a:b in ...
- =/=>
- case a:b of x in ...
-
- as this is less efficient.
- but we don't mind doing let-to-case for "bottom", as that
- will
- allow us to remove more dead code, if anything:
- let x = error in ...
- ===>
- case error of x -> ...
- ===>
- error
+ = simpl_bind env rhs
+ where
+ -- Try let-to-case; see notes below about let-to-case
+ simpl_bind env rhs | will_be_demanded &&
+ try_let_to_case &&
+ type_ok_for_let_to_case rhs_ty &&
+ rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
+ = tick Let2Case `thenSmpl_`
+ mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
+ simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty
+
+ -- Try let-from-let
+ simpl_bind env (Let bind rhs) | let_floating_ok
+ = tick LetFloatFromLet `thenSmpl_`
+ simplBind env (fix_up_demandedness will_be_demanded bind)
+ (\env -> simpl_bind env rhs) body_ty
- Notice that let to case occurs only if x is used strictly in
- its body (obviously).
- -}
+ -- Try case-from-let; this deals with a strict let of error too
+ simpl_bind env (Case scrut alts) | will_be_demanded ||
+ (float_primops && is_cheap_prim_app scrut)
+ = tick CaseFloatFromLet `thenSmpl_`
- | (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
- floatExposesHNF float_lets float_primops ok_to_dup rhs
- = try_float env rhs body_c
+ -- First, bind large let-body if necessary
+ if ok_to_dup || isSingleton (nonErrorRHSs alts)
+ then
+ simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
+ else
+ bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
+ let
+ body_c' = \env -> simplExpr env new_body []
+ case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
+ in
+ simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
+ returnSmpl (Let extra_binding case_expr)
- | otherwise
- = done_float env rhs body_c
+ -- None of the above; simplify rhs and tidy up
+ simpl_bind env rhs
+ = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
+ completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds) ->
+ body_c new_env `thenSmpl` \ body' ->
+ returnSmpl (mkCoLetsAny binds body')
- where
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- rhs_ty = idType id
+ -- All this stuff is computed at the start of the simpl_bind loop
float_lets = switchIsSet env SimplFloatLetsExposingWHNF
float_primops = switchIsSet env SimplOkToFloatPrimOps
ok_to_dup = switchIsSet env SimplOkToDupCode
try_let_to_case = switchIsSet env SimplLetToCase
no_float = switchIsSet env SimplNoLetFromStrictLet
- -------------------------------------------
- done_float env rhs body_c
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeLet env binder rhs' body_c body_ty
+ will_be_demanded = willBeDemanded (getIdDemandInfo id)
+ rhs_ty = idType id
- ---------------------------------------
- try_float env (Let bind rhs) body_c
- = tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
- (\env -> try_float env rhs body_c) body_ty
+ rhs_is_whnf = case mkFormSummary rhs of
+ VarForm -> True
+ ValueForm -> True
+ other -> False
- try_float env (Case scrut alts) body_c
- | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
- = tick CaseFloatFromLet `thenSmpl_`
+ let_floating_ok = (will_be_demanded && not no_float) ||
+ always_float_let_from_let ||
+ floatExposesHNF float_lets float_primops ok_to_dup rhs
+\end{code}
- -- First, bind large let-body if necessary
- if no_need_to_bind_large_body then
- simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
- else
- bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
- let
- body_c' = \env -> simplExpr env new_body []
- in
- simplCase env scrut alts
- (\env rhs -> try_float env rhs body_c')
- body_ty `thenSmpl` \ case_expr ->
+Let to case
+~~~~~~~~~~~
+It's important to try let-to-case before floating. Consider
- returnSmpl (Let extra_binding case_expr)
- where
- no_need_to_bind_large_body
- = ok_to_dup || isSingleton (nonErrorRHSs alts)
+ let a*::Int = case v of {p1->e1; p2->e2}
+ in b
+
+(The * means that a is sure to be demanded.)
+If we do case-floating first we get this:
+
+ let k = \a* -> b
+ in case v of
+ p1-> let a*=e1 in k a
+ p2-> let a*=e2 in k a
+
+Now watch what happens if we do let-to-case first:
+
+ case (case v of {p1->e1; p2->e2}) of
+ Int a# -> let a*=I# a# in b
+===>
+ let k = \a# -> let a*=I# a# in b
+ in case v of
+ p1 -> case e1 of I# a# -> k a#
+ p1 -> case e1 of I# a# -> k a#
+
+The latter is clearly better. (Remember the reboxing let-decl for a
+is likely to go away, because after all b is strict in a.)
+
+We do not do let to case for WHNFs, e.g.
+
+ let x = a:b in ...
+ =/=>
+ case a:b of x in ...
+
+as this is less efficient. but we don't mind doing let-to-case for
+"bottom", as that will allow us to remove more dead code, if anything:
+
+ let x = error in ...
+ ===>
+ case error of x -> ...
+ ===>
+ error
+
+Notice that let to case occurs only if x is used strictly in its body
+(obviously).
- try_float env other_rhs body_c = done_float env other_rhs body_c
-\end{code}
Letrec expressions
~~~~~~~~~~~~~~~~~~
\begin{code}
simplBind env (Rec pairs) body_c body_ty
= -- Do floating, if necessary
- (if float_lets || always_float_let_from_let
- then
- mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
- returnSmpl (concat floated_pairs_s)
- else
- returnSmpl pairs
- ) `thenSmpl` \ floated_pairs ->
let
- binders = map fst floated_pairs
- in
- cloneIds env binders `thenSmpl` \ ids' ->
- let
- env_w_clones = extendIdEnvWithClones env binders ids'
- triples = zipEqual "simplBind" ids' floated_pairs
- in
-
- simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
-
- body_c new_env `thenSmpl` \ body' ->
-
- returnSmpl (Let binding body')
+ floated_pairs | do_floating = float_pairs pairs
+ | otherwise = pairs
- where
- ------------ Floating stuff -------------------
-
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+ ticks | do_floating = length floated_pairs - length pairs
+ | otherwise = 0
- float (binder,rhs)
- = let
- pairs_s = float_pair (binder,rhs)
- in
- case pairs_s of
- [_] -> returnSmpl pairs_s
- more_than_one
- -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
+ binders = map fst floated_pairs
+ in
+ tickN LetFloatFromLet ticks `thenSmpl_`
-- It's important to increment the tick counts if we
-- do any floating. A situation where this turns out
-- to be important is this:
-- mention x, in which case the y binding can be pulled
-- out as an enclosing let(rec), which in turn gives
-- the strictness analyser more chance.
- returnSmpl pairs_s
+
+ cloneIds env binders `thenSmpl` \ ids' ->
+ let
+ env_w_clones = extendIdEnvWithClones env binders ids'
+ in
+ simplRecursiveGroup env ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
+
+ body_c new_env `thenSmpl` \ body' ->
+
+ returnSmpl (Let binding body')
+
+ where
+ ------------ Floating stuff -------------------
+
+ float_lets = switchIsSet env SimplFloatLetsExposingWHNF
+ always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+ do_floating = float_lets || always_float_let_from_let
float_pairs pairs = concat (map float_pair pairs)
(pairs', body') = do_float body
do_float other = ([], other)
-simplRecursiveGroup env triples
- = -- Toss out all the dead pairs? No, there shouldn't be any!
- -- Dead code is discarded by the occurrence analyser
+simplRecursiveGroup env new_ids pairs
+ = -- Add unfoldings to the new_ids corresponding to their RHS
let
- -- Separate the live triples into "inline"able and
- -- "ordinary" We're paranoid about duplication!
- (inline_triples, ordinary_triples)
- = partition is_inline_triple triples
-
- is_inline_triple (_, ((_,occ_info),_))
- = inlineUnconditionally False {-not ok_to_dup-} occ_info
-
- -- Now add in the inline_pairs info (using "env_w_clones"),
- -- so that we will save away suitably-clone-laden envs
- -- inside the InlineIts...).
-
- -- NOTE ALSO that we tie a knot here, because the
- -- saved-away envs must also include these very inlinings
- -- (they aren't stored anywhere else, and a late one might
- -- be used in an early one).
-
- env_w_inlinings = foldl add_inline env inline_triples
-
- add_inline env (id', (binder,rhs))
- = extendIdEnvWithInlining env env_w_inlinings binder rhs
-
- -- Separate the remaining bindings into the ones which
- -- need to be dealt with first (the "early" ones)
- -- and the others (the "late" ones)
- (early_triples, late_triples)
- = partition is_early_triple ordinary_triples
-
- is_early_triple (_, (_, Con _ _)) = True
- is_early_triple (i, _ ) = idWantsToBeINLINEd i
+ occs = [occ | ((_,occ), _) <- pairs]
+ new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
+ rhs_env = foldl extendEnvForRecBinding
+ env new_ids_w_pairs
in
- -- Process the early bindings first
- mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
- -- Now further extend the environment to record our knowledge
- -- about the form of the binders bound in the constructor bindings
- let
- env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
- add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
- in
- -- Now process the non-constructor bindings
- mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
+ mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
- -- Phew! We're done
let
- binding = Rec (map snd early_triples' ++ map snd late_triples')
+ new_pairs = zipEqual "simplRecGp" new_ids new_rhss
+ occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
+ new_env = foldl (\env (occ_info,(new_id,new_rhs)) ->
+ extendEnvGivenBinding env occ_info new_id new_rhs)
+ env occs_w_new_pairs
in
- returnSmpl (binding, env_w_early_info)
- where
-
- do_one_binding env (id', (binder,rhs))
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- returnSmpl (binder, (id', rhs'))
+ returnSmpl (Rec new_pairs, new_env)
\end{code}
where it is always good to ditch the binding for y, and replace y by
x. That's just what completeLetBinding does.
-\begin{code}
-completeLet
- :: SimplEnv
- -> InBinder
- -> OutExpr -- The simplified RHS
- -> (SimplEnv -> SmplM OutExpr) -- Body handler
- -> OutType -- Type of body
- -> SmplM OutExpr
-completeLet env binder new_rhs body_c body_ty
+\begin{code}
+ -- Sigh: rather disgusting case for coercions. We want to
+ -- ensure that all let-bound Coerces have atomic bodies, so
+ -- they can freely be inlined.
+completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
+ = (case rhs of
+ Var v -> returnSmpl (env, [], rhs)
+ Lit l -> returnSmpl (env, [], rhs)
+ other -> newId (coreExprType rhs) `thenSmpl` \ inner_id ->
+ completeNonRec env
+ (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) ->
+ -- Dangerous occ because, like constructor args,
+ -- it can be duplicated easily
+ let
+ atomic_rhs = case lookupId env1 inner_id of
+ LitArg l -> Lit l
+ VarArg v -> Var v
+ in
+ returnSmpl (env1, extra_bind, atomic_rhs)
+ ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) ->
+ -- Tiresome to do all this, but we must treat the lit/var cases specially
+ -- or we get a tick for atomic rhs when effectively it's a no-op.
+
+ cloneId env1 binder `thenSmpl` \ new_id ->
+ let
+ new_rhs = Coerce coercion ty atomic_rhs
+ env2 = extendIdEnvWithClone env1 binder new_id
+ new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs
+ in
+ returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
+
+completeNonRec env binder new_rhs
-- See if RHS is an atom, or a reusable constructor
| maybeToBool maybe_atomic_rhs
= let
new_env = extendIdEnvWithAtom env binder rhs_atom
in
tick atom_tick_type `thenSmpl_`
- body_c new_env
+ returnSmpl (new_env, [])
where
- maybe_atomic_rhs :: Maybe (OutArg, TickType)
- maybe_atomic_rhs = exprToAtom env new_rhs
- -- If the RHS is atomic, we return Just (atom, tick type)
- -- otherwise Nothing
+ maybe_atomic_rhs = exprToAtom env new_rhs
Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-completeLet env binder@(id,_) new_rhs body_c body_ty
- -- Maybe the rhs is an application of error, and sure to be demanded
- | will_be_demanded &&
- maybeToBool maybe_error_app
- = tick CaseOfError `thenSmpl_`
- returnSmpl retyped_error_app
- where
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
- Just retyped_error_app = maybe_error_app
-
-{-
-completeLet env binder (Coerce coercion ty rhs) body_c body_ty
- -- Rhs is a coercion
- | maybeToBool maybe_atomic_coerce_rhs
- = tick tick_type `thenSmpl_`
- complete_coerce env rhs_atom rhs
- where
- maybe_atomic_coerce_rhs = exprToAtom env rhs
- Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
-
- returnSmpl (CoerceForm coercion rhs_atom, env)
- Nothing
- newId (coreExprType rhs) `thenSmpl` \ inner_id ->
-
- complete_coerce env atom rhs
- = cloneId env binder `thenSmpl` \ id' ->
- let
- env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
- in
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
--}
-
-completeLet env binder new_rhs body_c body_ty
- -- The general case
- = cloneId env binder `thenSmpl` \ id' ->
+completeNonRec env binder@(_,occ_info) new_rhs
+ = cloneId env binder `thenSmpl` \ new_id ->
let
- env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
+ env1 = extendIdEnvWithClone env binder new_id
+ new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
in
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec id' new_rhs) body')
+ returnSmpl (new_env, [NonRec new_id new_rhs])
\end{code}
%************************************************************************
simplArg env (LitArg lit) = LitArg lit
simplArg env (TyArg ty) = TyArg (simplTy env ty)
-
-simplArg env (VarArg id)
- | isLocallyDefined id
- = case lookupId env id of
- Just (ItsAnAtom atom) -> atom
- Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
- Nothing -> VarArg id -- Must be an uncloned thing
-
- | otherwise
- = -- Not locally defined, so no change
- VarArg id
+simplArg env (VarArg id) = lookupId env id
\end{code}
module SpecEnv (
SYN_IE(SpecEnv), MatchEnv,
nullSpecEnv, isNullSpecEnv,
- addOneToSpecEnv, lookupSpecEnv,
- specEnvToList
+ addOneToSpecEnv, lookupSpecEnv
) where
IMP_Ubiq()
import MatchEnv
import Type ( matchTys, isTyVarTy )
import Usage ( SYN_IE(UVar) )
+import OccurAnal ( occurAnalyseGlobalExpr )
+import CoreSyn ( CoreExpr(..), SimplifiableCoreExpr(..) )
+import Maybes ( MaybeErr(..) )
\end{code}
-A @SpecEnv@ holds details of an @Id@'s specialisations:
+A @SpecEnv@ holds details of an @Id@'s specialisations. It should be
+a newtype (ToDo), but for 1.2 compatibility we make it a data type.
+It can't be a synonym because there's an IdInfo instance of it
+that doesn't work if it's (MatchEnv a b).
+Furthermore, making it a data type makes it easier to break the IdInfo loop.
\begin{code}
-type CoreExpr = GenCoreExpr Id Id TyVar Unique
-type SpecEnv = MatchEnv [Type] CoreExpr
+data SpecEnv = SpecEnv (MatchEnv [Type] SimplifiableCoreExpr)
\end{code}
For example, if \tr{f}'s @SpecEnv@ contains the mapping:
\begin{code}
nullSpecEnv :: SpecEnv
-nullSpecEnv = nullMEnv
+nullSpecEnv = SpecEnv nullMEnv
isNullSpecEnv :: SpecEnv -> Bool
-isNullSpecEnv env = null (mEnvToList env)
+isNullSpecEnv (SpecEnv env) = null (mEnvToList env)
-specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
-specEnvToList env = mEnvToList env
-
-addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
-addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
+addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], SimplifiableCoreExpr)
+addOneToSpecEnv (SpecEnv env) tys rhs
+ = case (insertMEnv matchTys env tys (occurAnalyseGlobalExpr rhs)) of
+ Succeeded menv -> Succeeded (SpecEnv menv)
+ Failed err -> Failed err
-lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
-lookupSpecEnv env tys
+lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (SimplifiableCoreExpr, ([(TyVar,Type)], [Type]))
+lookupSpecEnv (SpecEnv env) tys
| all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
| otherwise = lookupMEnv matchTys env tys
\end{code}
-
-
-
-=================================================================
- BELOW HERE SCHEDULED FOR DELETION!
-
-
-The details of one specialisation, held in an @Id@'s
-@SpecEnv@ are as follows:
-\begin{pseudocode}
-data SpecInfo
- = SpecInfo [Maybe Type] -- Instance types; no free type variables in here
- Int -- No. of dictionaries to eat
- Id -- Specialised version
-\end{pseudocode}
-
-For example, if \tr{f} has this @SpecInfo@:
-\begin{verbatim}
- SpecInfo [Just t1, Nothing, Just t3] 2 f'
-\end{verbatim}
-then
-\begin{verbatim}
- f t1 t2 t3 d1 d2 ===> f t2
-\end{verbatim}
-The \tr{Nothings} identify type arguments in which the specialised
-version is polymorphic.
-
-\begin{pseudocode}
-data SpecEnv = SpecEnv [SpecInfo]
-
-mkSpecEnv = SpecEnv
-nullSpecEnv = SpecEnv []
-addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
-
-
-lookupConstMethodId :: Id -> Type -> Maybe Id
- -- slight variant on "lookupSpecEnv" below
-
-lookupConstMethodId sel_id spec_ty
- = case (getInfo (getIdInfo sel_id)) of
- SpecEnv spec_infos -> firstJust (map try spec_infos)
- where
- try (SpecInfo (Just ty:nothings) _ const_meth_id)
- = ASSERT(all nothing_is_nothing nothings)
- case (cmpType True{-properly-} ty spec_ty) of
- EQ_ -> Just const_meth_id
- _ -> Nothing
-
- nothing_is_nothing Nothing = True -- debugging only
- nothing_is_nothing _ = panic "nothing_is_nothing!"
-
-lookupSpecId :: Id -- *un*specialised Id
- -> [Maybe Type] -- types to which it is to be specialised
- -> Id -- specialised Id
-
-lookupSpecId unspec_id ty_maybes
- = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
-
- case (firstJust (map try spec_infos)) of
- Just id -> id
- Nothing -> pprError "ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"
- (ppr PprDebug unspec_id)
- }
- where
- try (SpecInfo template_maybes _ id)
- | and (zipWith same template_maybes ty_maybes)
- && length template_maybes == length ty_maybes = Just id
- | otherwise = Nothing
-
- same Nothing Nothing = True
- same (Just ty1) (Just ty2) = ty1 == ty2
- same _ _ = False
-
-lookupSpecEnv :: SpecEnv
- -> [Type]
- -> Maybe (Id,
- [Type],
- Int)
-
-lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
-
-lookupSpecEnv spec_env [] = Nothing -- another common case
-
- -- This can happen even if there is a non-empty spec_env, because
- -- of eta reduction. For example, we might have a defn
- --
- -- f = /\a -> \d -> g a d
- -- which gets transformed to
- -- f = g
- --
- -- Now g isn't applied to any arguments
-
-lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
- = select_match spec_infos
- where
- select_match [] -- no matching spec_infos
- = Nothing
- select_match (SpecInfo ty_maybes toss spec_id : rest)
- = case (match ty_maybes spec_tys) of
- Nothing -> select_match rest
- Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
-
- -- Ambiguity can only arise as a result of specialisations with
- -- an explicit spec_id. The best match is deemed to be the match
- -- with least polymorphism i.e. has the least number of tys left.
- -- This is a non-critical approximation. The only type arguments
- -- where there may be some discretion is for non-overloaded boxed
- -- types. Unboxed types must be matched and we insist that we
- -- always specialise on overloaded types (and discard all the dicts).
-
- select_next best _ toss []
- = case best of
- [match] -> Just match -- Unique best match
- ambig -> pprPanic "Ambiguous Specialisation:\n"
- (ppAboves [ppStr "(check specialisations with explicit spec ids)",
- ppCat (ppStr "between spec ids:" :
- map (ppr PprDebug) [id | (id, _, _) <- ambig]),
- pp_stuff])
-
- select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
- = ASSERT(dnum == toss)
- case (match ty_maybes spec_tys) of
- Nothing -> select_next best tnum dnum rest
- Just tys_left ->
- let tys_len = length tys_left in
- case _tagCmp tnum tys_len of
- _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
- _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
- _GT -> select_next best tnum dnum rest -- worse match
-
-
- match [{-out of templates-}] [] = Just []
-
- match (Nothing:ty_maybes) (spec_ty:spec_tys)
- = case (isUnboxedType spec_ty) of
- True -> Nothing -- Can only match boxed type against
- -- type argument which has not been
- -- specialised on
- False -> case match ty_maybes spec_tys of
- Nothing -> Nothing
- Just tys -> Just (spec_ty:tys)
-
- match (Just ty:ty_maybes) (spec_ty:spec_tys)
- = case (cmpType True{-properly-} ty spec_ty) of
- EQ_ -> match ty_maybes spec_tys
- other -> Nothing
-
- match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
- -- This is a Real Problem
-
- match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
- -- Partial eta abstraction might make this happen;
- -- meanwhile let's leave in the check
-
- pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
-\end{pseudocode}
-
-
-\begin{pseudocode}
-instance OptIdInfo SpecEnv where
- noInfo = nullSpecEnv
-
- getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
-
- addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
- = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
- -- We *add* the new specialisation info rather than just replacing it
- -- so that we don't lose old specialisation details.
-
- ppInfo sty better_id_fn spec_env
- = pp_specs sty True better_id_fn nullIdEnv spec_env
-
-pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
-pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
- = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
- ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
- ppInt numds,
- let
- better_spec_id = better_id_fn spec_id
- spec_id_info = getIdInfo better_spec_id
- in
- if not print_spec_ids || boringIdInfo spec_id_info then
- ppNil
- else
- ppCat [ppChar '{',
- ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
- ppChar '}']
- ]
- | (SpecInfo ty_maybes numds spec_id) <- specs ])
- where
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
-
- pp_maybe Nothing = ifPprInterface sty pp_NONE
- pp_maybe (Just t) = pprParendGenType sty t
-\end{pseudocode}
-
--ToDo:kill
data SpecInfo = SpecInfo [Maybe Type] Int Id
-
+lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
-lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
mkSpecId = panic "Specialise.mkSpecId (ToDo)"
selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
unionUDList :: [UsageDetails] -> UsageDetails
-tickSpecCall :: Bool -> UsageDetails -> UsageDetails
+-- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
tickSpecInsts :: UsageDetails -> UsageDetails
-tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
+-- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
+-- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
= UsageDetails cis ty_cis dbs fvs c (i+1)
NoLift vatom@(VarArg new_v)
-> mapSM specOutArg args `thenSM` \ arg_info ->
mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
- mkCall new_v arg_info `thenSM` \ ~(speced, call) ->
+ mkCall new_v arg_info `thenSM` \ call ->
let
uds = unionUDList [call_uds,
singleFvUDs vatom,
unionUDList [uds | (_,uds,_) <- arg_info]
]
in
- returnSM (call, tickSpecCall speced uds)
+ returnSM (call, {- tickSpecCall speced -} uds)
specExpr expr@(Lit _) null_args
= ASSERT (null null_args)
-- "required" by one of the other Ids in the Rec
| top_lev && maybeToBool lookup_orig_spec
= (if opt_SpecialiseTrace
- then trace_nospec " Exists: " exists_id
+ then trace_nospec " Exists: " orig_id
else id) (
returnSM (Nothing, emptyUDs, Nothing)
tickSpecInsts final_uds, spec_info)
where
lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
- Just (exists_id, _, _) = lookup_orig_spec
explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
[CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
\begin{code}
mkCall :: Id
-> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM (Bool, CoreExpr)
+ -> SpecM CoreExpr
-mkCall new_id args
+mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
+
+{-
| maybeToBool (isSuperDictSelId_maybe new_id)
&& any isUnboxedType ty_args
-- No specialisations for super-dict selectors
ppCat [ppr PprDebug spec_id,
ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
else id
+-}
\end{code}
\begin{code}
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), FormSummary )
+import CoreUnfold ( Unfolding(..), SimpleUnfolding(..), FormSummary )
import CoreUtils ( unTagBinders )
import Id ( idType, getIdStrictness, getIdUnfolding,
dataConTyCon, dataConArgTys
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, GenForm _ unfolding _) ->
+ (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
(Nothing, strictness_info, _) ->
- -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
+ -- Includes MagicUnfolding, NoUnfolding
-- Try the strictness info
absValFromStrictness anal strictness_info
in
-> Id -- Augmented with strictness
addStrictnessInfoToId strflags str_val abs_val binder body
- = if isWrapperId binder then
- binder -- Avoid clobbering existing strictness info
+
+{- SCHEDULED FOR NUKING
+ | isWrapperId binder
+ = binder -- Avoid clobbering existing strictness info
-- (and, more importantly, worker info).
-- Deeply suspicious (SLPJ)
- else
- if (isBot str_val) then
- binder `addIdStrictness` mkBottomStrictnessInfo
- else
- case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
- let
- tys = map idType lambda_bounds
- strictness = findStrictness strflags tys str_val abs_val
- in
- binder `addIdStrictness` mkStrictnessInfo strictness Nothing
- }
+-}
+
+ | isBot str_val
+ = binder `addIdStrictness` mkBottomStrictnessInfo
+
+ | otherwise
+ = case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
+ let
+ tys = map idType lambda_bounds
+ strictness = findStrictness strflags tys str_val abs_val
+ in
+ binder `addIdStrictness` mkStrictnessInfo strictness Nothing
+ }
\end{code}
\begin{code}
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..){-ToDo:rm-}, UnfoldingGuidance(..) )
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..) )
IMPORT_DELOOPER(IdLoop) -- ToDo:rm when iWantToBeINLINEd goes
import CoreUtils ( coreExprType )
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
import WwLib
-iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
-iWantToBeINLINEd x = NoUnfoldingDetails --ToDo:panic "WorkWrap.iWantToBeINLINEd (ToDo)"
+iWantToBeINLINEd :: UnfoldingGuidance -> Unfolding
+iWantToBeINLINEd x = NoUnfolding --ToDo:panic "WorkWrap.iWantToBeINLINEd (ToDo)"
\end{code}
We take Core bindings whose binders have their strictness attached (by
import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE,
newDicts, tyVarsOfInst, instToId )
import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars )
+import SpecEnv ( SpecEnv )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars
box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty ->
- unifyTauTy (mkTyVarTy tyvar) boxed_ty
+ unifyTauTy boxed_ty (mkTyVarTy tyvar)
in
ASSERT( null unboxed_kind_tyvars ) -- The instCantBeGeneralised stuff in tcSimplify
import MatchEnv ( lookupMEnv, insertMEnv )
import Name ( mkLocalName, getLocalName, Name )
import Outputable
-import PprType ( GenClass, TyCon, GenType, GenTyVar )
+import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )
import PprStyle ( PprStyle(..) )
import Pretty
import SpecEnv ( SYN_IE(SpecEnv) )
ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
= ppHang (ppr_orig orig loc)
- 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
+ 4 (ppCat [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
= ppHang (ppr_orig orig loc)
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
+import SpecEnv ( SpecEnv )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcPolyType )
import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
+import SpecEnv ( SpecEnv )
import TcInstDcls ( processInstBinds )
import TcKind ( unifyKind, TcKind )
import TcMonad hiding ( rnMtoTcM )
)
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
-import IdInfo ( noIdInfo )
+import IdInfo
import Name ( isLocallyDefined, origName, getLocalName )
import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec,
+ noIdInfo)
\end{code}
import TcMonad hiding ( rnMtoTcM )
import Inst ( InstOrigin(..) )
import TcEnv ( tcLookupClassByKey )
+import SpecEnv ( SpecEnv )
import TcMonoType ( tcMonoType )
import TcSimplify ( tcSimplifyCheckThetas )
import TcMonad
import Inst ( SYN_IE(InstanceMapper) )
import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
+import SpecEnv ( SpecEnv )
import TcKind ( TcKind )
import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
tcExtendGlobalTyVars
)
+import SpecEnv ( SpecEnv )
import TcMatches ( tcMatchesCase, tcMatch )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
tcAddErrCtxt (sectionRAppCtxt in_expr) $
- unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_`
+ unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty `thenTc_`
returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
\end{code}
tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
tcAddErrCtxt (predCtxt pred) (
- unifyTauTy predTy boolTy
+ unifyTauTy boolTy predTy
) `thenTc_`
tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
let
(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
in
- unifyTauTy tau_ty sig_tau' `thenTc_`
+ unifyTauTy sig_tau' tau_ty `thenTc_`
-- Check the type variables of the signature
checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
-- See comments with tcListComp on GeneratorQual
get_m_arg exp_ty `thenTc` \ a ->
- unifyTauTy a pat_ty `thenTc_`
+ unifyTauTy pat_ty a `thenTc_`
returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
)) `thenTc` \ (a, pat', exp', stmt_lie) ->
go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
import TcBinds ( tcPragmaSigs )
import TcDeriv ( tcDeriving )
import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import SpecEnv ( SpecEnv )
import TcGRHSs ( tcGRHSsAndBinds )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcKind ( TcKind, unifyKind )
-- Make the method_tyvars into signature tyvars so they
-- won't get unified with anything.
tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
- unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys `thenTc_`
+ unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars) `thenTc_`
newLocalId occ method_tau `thenNF_Tc` \ local_id ->
newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
Nothing -> -- Not a function type (eg type variable)
-- So use tcMatch instead
tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
- unifyTauTy match_ty expected_ty `thenTc_`
+ unifyTauTy expected_ty match_ty `thenTc_`
returnTc (match', lie_match)
Just (arg_ty,rest_ty) -> -- It's a function type!
in
newMonoIds binders mkTypeKind (\ _ ->
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- unifyTauTy arg_ty pat_ty `thenTc_`
+ unifyTauTy pat_ty arg_ty `thenTc_`
tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
returnTc (PatMatch pat' match',
plusLIE lie_pat lie_match)
tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
= tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
- unifyTauTy grhss_ty expected_ty `thenTc_`
+ unifyTauTy expected_ty grhss_ty `thenTc_`
returnTc (GRHSMatch grhss_and_binds', lie)
tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
getEnv_TyCons, getEnv_Classes,
tcLookupLocalValueByKey, tcLookupTyConByKey )
+import SpecEnv ( SpecEnv )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, InstInfo )
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
+import SpecEnv ( SpecEnv )
import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
checkTc (con_arity == no_of_args)
(arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
- unifyTauTyLists arg_tys con_args `thenTc_`
+ unifyTauTyLists con_args arg_tys `thenTc_`
returnTc (con_id, con_result)
\end{code}
-> Maybe Type
-> Id -- final Id (do not *touch*)
-> ImpStrictness Name
- -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
+ -> Baby_TcM (StrictnessInfo, Unfolding)
tc_strictness e ty_maybe rec_final_id info
= getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
-- NB: We cant check the lint result and return noInfo_UF if
-- lintUnfolding failed as this is too strict
-- Instead getInfo_UF tests for BadUnfolding and converts
- -- to NoUnfoldingDetails when the unfolding is accessed
+ -- to NoUnfolding when the unfolding is accessed
maybe_lint_expr = lintUnfolding locn core_expr
plusLIE, unitLIE, consLIE, InstOrigin(..),
OverloadedLit )
import TcEnv ( tcGetGlobalTyVars )
+import SpecEnv ( SpecEnv )
import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
import Unify ( unifyTauTy )
-- See if any default works, and if so bind the type variable to it
try_default default_tys `thenTc` \ chosen_default_ty ->
tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
- unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
+ unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
where
(_,_,tyvar) = head dict_infos -- Should be non-empty
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
tcTyVarScope )
+import SpecEnv ( SpecEnv )
import TcKind ( TcKind, newKindVars )
import TcTyDecls ( tcTyDecl, mkDataBinds )
matchTy :: GenType t1 u1 -- Template
-> GenType t2 u2 -- Proposed instance of template
-> Maybe [(t1,GenType t2 u2)] -- Matching substitution
+
matchTys :: [GenType t1 u1] -- Templates
-> [GenType t2 u2] -- Proposed instance of template
- -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
+ -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
+ [GenType t2 u2]) -- Left over instance types
+
+matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) []
+matchTys tys1 tys2 = go [] tys1 tys2
+ where
+ go s [] tys2 = Just (s,tys2)
+ go s (ty1:tys1) [] = panic "matchTys"
+ go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
+
-matchTy ty1 ty2 = match [] [] ty1 ty2
-matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
\end{code}
@match@ is the main function.
\begin{code}
-match :: [(t1, GenType t2 u2)] -- r, the accumulating result
- -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list
- -> GenType t1 u1 -> GenType t2 u2 -- Current match pair
- -> Maybe [(t1, GenType t2 u2)]
-
-match r w (TyVarTy v) ty = match' ((v,ty) : r) w
-match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2
-match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2
-match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w
-match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
-match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2
-match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2
+match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair
+ -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation
+ -> [(t1, GenType t2 u2)] -- Current substitution
+ -> Maybe result
+
+match (TyVarTy v) ty k = \s -> k ((v,ty) : s)
+match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k)
+match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
+match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k
+match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
+match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k
+match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k
-- With type synonyms, we have to be careful for the exact
-- same reasons as in the unifier. Please see the
-- here! (WDP 95/05)
-- Catch-all fails
-match _ _ _ _ = Nothing
-
-match' r [] = Just r
-match' r ((ty1,ty2):w) = match r w ty1 ty2
+match _ _ _ = \s -> Nothing
\end{code}
%************************************************************************
import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
GenCoreCaseAlts, GenCoreCaseDefault, Coercion
)
-import CoreUnfold ( UnfoldingDetails, UnfoldingGuidance )
+import CoreUnfold ( Unfolding, UnfoldingGuidance )
import CostCentre ( CostCentre )
import FieldLabel ( FieldLabel )
import FiniteMap ( FiniteMap )
data UniqFM a
data UpdateInfo
data UniqSupply
-data UnfoldingDetails
+data Unfolding
data UnfoldingGuidance
data Unique -- NB: fails the optimisation criterion
ClosureInfo ClosureInfo
CmdLineOpts SwitchResult
CoreSyn GenCoreExpr
-CoreUnfold UnfoldingDetails
+CoreUnfold Unfolding
CoreUnfold UnfoldingGuidance
CostCentre CostCentre
HeapOffs HeapOffset
unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
- addToUFM,
- addListToUFM,
+ addToUFM,addToUFM_C,
+ addListToUFM,addListToUFM_C,
addToUFM_Directly,
addListToUFM_Directly,
- IF_NOT_GHC(addToUFM_C COMMA)
- addListToUFM_C,
delFromUFM,
delFromUFM_Directly,
delListFromUFM,
projects / ghc-hetmet.git / commitdiff