Commit 12899612 authored by partain's avatar partain
Browse files

[project @ 1996-07-15 16:16:46 by partain]

simonpj changes through 960715
parent 573ef10b
......@@ -90,6 +90,10 @@ module Id (
pprId,
showId,
-- Specialialisation
getIdSpecialisation,
addIdSpecialisation,
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
addIdArity,
addIdDemandInfo,
......@@ -126,6 +130,7 @@ module Id (
mkIdEnv,
mkIdSet,
modifyIdEnv,
modifyIdEnv_Directly,
nullIdEnv,
rngIdEnv,
unionIdSets,
......@@ -160,6 +165,8 @@ import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
)
import PprStyle
import Pretty
import SpecEnv ( SpecEnv(..) )
import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
......@@ -778,46 +785,7 @@ unfoldingUnfriendlyId -- return True iff it is definitely a bad
-> 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
......@@ -1482,9 +1450,8 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing
%************************************************************************
@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)?
......@@ -1497,16 +1464,16 @@ dictionaries, in the even of an overloaded data-constructor---none at
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
......@@ -1574,14 +1541,12 @@ addIdFBTypeInfo (Id u n ty info details) upd_info
\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.
......@@ -1712,7 +1677,7 @@ delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
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
......@@ -1740,10 +1705,15 @@ lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-- 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}
......
......@@ -77,7 +77,6 @@ IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
......@@ -117,16 +116,13 @@ data IdInfo
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
......@@ -162,7 +158,7 @@ boringIdInfo (IdInfo UnknownArity
_ {- no f/b w/w -}
_ {- src_loc: no effect on interfaces-}
)
| null (mEnvToList specenv)
| isNullSpecEnv specenv
&& boring_strictness strictness
&& boring_unfolding unfolding
= True
......@@ -171,8 +167,8 @@ boringIdInfo (IdInfo UnknownArity
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
......@@ -185,7 +181,7 @@ nasty loop, friends...)
\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"
......@@ -253,7 +249,7 @@ ppIdInfo :: PprStyle
-> 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
......@@ -279,8 +275,8 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
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
......@@ -414,19 +410,16 @@ instance OptIdInfo DemandInfo where
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}
%************************************************************************
......@@ -737,25 +730,18 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
\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}
......@@ -764,14 +750,12 @@ pp_unfolding sty for_this_id inline_env uf_details
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
......
......@@ -8,14 +8,17 @@ import PreludeStdIO ( Maybe )
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 )
......@@ -32,6 +35,9 @@ import Usage ( GenUsage )
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
......@@ -62,20 +68,28 @@ instance Outputable (GenTyVar a)
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}
......@@ -3,7 +3,7 @@ interface IdLoop_1_3 1
__exports__
CoreSyn CoreExpr
CoreUnfold FormSummary (..)
CoreUnfold UnfoldingDetails (..)
CoreUnfold Unfolding (..)
CoreUnfold UnfoldingGuidance (..)
CoreUtils unTagBinders (..)
Id IdEnv
......@@ -19,5 +19,7 @@ MagicUFs MagicUnfoldingFun
MagicUFs mkMagicUnfoldingFun (..)
OccurAnal occurAnalyseGlobalExpr (..)
PprType pprParendGenType (..)
SpecEnv isNullSpecEnv (..)
SpecEnv nullSpecEnv (..)
WwLib mAX_WORKER_ARGS (..)
\end{code}
......@@ -12,9 +12,10 @@ IMP_Ubiq()
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,
......@@ -63,7 +64,7 @@ primOpId op
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))
......
......@@ -670,7 +670,7 @@ addBindsC new_bindings info_down (MkCgState absC binds usage)
\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@.
......
......@@ -18,9 +18,10 @@ module CoreSyn (
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,
......@@ -224,13 +225,8 @@ mkCoLetrecAny binds body = Let (Rec binds) body
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}
......@@ -384,24 +380,24 @@ collectBinders ::
([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
......@@ -409,6 +405,16 @@ collectBinders expr
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}
%************************************************************************
......@@ -498,6 +504,21 @@ collectArgs expr
= (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}
......
......@@ -6,22 +6,23 @@
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
......@@ -33,16 +34,17 @@ IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
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(..) )
......@@ -52,7 +54,7 @@ import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
addOneToUniqSet, unionUniqSets
)
import Usage ( SYN_IE(UVar) )
import Util ( isIn, panic )
import Util ( isIn, panic, assertPanic )
whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
......@@ -60,150 +62,144 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy
%************************************************************************
%* *
\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