%
% (c) The University of Glasgow 2006
% (c) The Univserity of Glasgow 1992-2004
%
Data structures which describe closures, and
operations over those data structures
Nothing monadic in here
Much of the rationale for these things is in the ``details'' part of
the STG paper.
\begin{code}
module ClosureInfo (
ClosureInfo(..), LambdaFormInfo(..),
StandardFormInfo(..),
SMRep,
ArgDescr(..), Liveness(..),
C_SRT(..), needsSRT,
mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
mkClosureInfo, mkConInfo, maybeIsLFCon,
closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
slopSize,
infoTableLabelFromCI,
closureLabelFromCI,
isLFThunk, closureUpdReqd,
closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
funTag, funTagLFInfo, tagForArity,
enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
nodeMustPointToIt,
CallMethod(..), getCallMethod,
blackHoleOnEntry,
staticClosureRequired,
getClosureType,
isToplevClosure,
closureValDescr, closureTypeDescr,
isStaticClosure,
cafBlackHoleClosureInfo,
staticClosureNeedsLink,
) where
#include "../includes/MachDeps.h"
#include "HsVersions.h"
import StgSyn
import SMRep
import CLabel
import Unique
import StaticFlags
import Var
import Id
import IdInfo
import DataCon
import Name
import Type
import TypeRep
import TcType
import TyCon
import BasicTypes
import FastString
import Outputable
import Constants
import DynFlags
\end{code}
%************************************************************************
%* *
\subsection[ClosureInfo-datatypes]{Data types for closure information}
%* *
%************************************************************************
Information about a closure, from the code generator's point of view.
A ClosureInfo decribes the info pointer of a closure. It has
enough information
a) to construct the info table itself
b) to allocate a closure containing that info pointer (i.e.
it knows the info table label)
We make a ClosureInfo for
- each let binding (both top level and not)
- each data constructor (for its shared static and
dynamic info tables)
\begin{code}
data ClosureInfo
= ClosureInfo {
closureName :: !Name,
closureLFInfo :: !LambdaFormInfo,
closureSMRep :: !SMRep,
closureSRT :: !C_SRT,
closureType :: !Type,
closureDescr :: !String
}
| ConInfo {
closureCon :: !DataCon,
closureSMRep :: !SMRep
}
data C_SRT = NoC_SRT
| C_SRT !CLabel !WordOff !StgHalfWord
deriving (Eq)
needsSRT :: C_SRT -> Bool
needsSRT NoC_SRT = False
needsSRT (C_SRT _ _ _) = True
instance Outputable C_SRT where
ppr (NoC_SRT) = ptext (sLit "_no_srt_")
ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
\end{code}
%************************************************************************
%* *
\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
%* *
%************************************************************************
Information about an identifier, from the code generator's point of
view. Every identifier is bound to a LambdaFormInfo in the
environment, which gives the code generator enough info to be able to
tail call or return that identifier.
Note that a closure is usually bound to an identifier, so a
ClosureInfo contains a LambdaFormInfo.
\begin{code}
data LambdaFormInfo
= LFReEntrant
TopLevelFlag
!Int
!Bool
ArgDescr
| LFCon
DataCon
| LFThunk
TopLevelFlag
!Bool
!Bool
StandardFormInfo
!Bool
| LFUnknown
!Bool
| LFLetNoEscape
!Int
| LFBlackHole
CLabel
data ArgDescr
= ArgSpec
!StgHalfWord
| ArgGen
Liveness
data Liveness
= SmallLiveness
StgWord
| BigLiveness
CLabel
data StandardFormInfo
= NonStandardThunk
| SelectorThunk
WordOff
| ApThunk
Int
\end{code}
%************************************************************************
%* *
\subsection[ClosureInfo-construction]{Functions which build LFInfos}
%* *
%************************************************************************
\begin{code}
mkLFReEntrant :: TopLevelFlag
-> [Id]
-> [Id]
-> ArgDescr
-> LambdaFormInfo
mkLFReEntrant top fvs args arg_descr
= LFReEntrant top (length args) (null fvs) arg_descr
mkLFThunk :: Type -> TopLevelFlag -> [Var] -> UpdateFlag -> LambdaFormInfo
mkLFThunk thunk_ty top fvs upd_flag
= ASSERT2( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty), ppr thunk_ty $$ ppr fvs )
LFThunk top (null fvs)
(isUpdatable upd_flag)
NonStandardThunk
(might_be_a_function thunk_ty)
might_be_a_function :: Type -> Bool
might_be_a_function ty
= case splitTyConApp_maybe (repType ty) of
Just (tc, _) -> not (isDataTyCon tc)
Nothing -> True
\end{code}
@mkConLFInfo@ is similar, for constructors.
\begin{code}
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con = LFCon con
maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
maybeIsLFCon (LFCon con) = Just con
maybeIsLFCon _ = Nothing
mkSelectorLFInfo :: Id -> WordOff -> Bool -> LambdaFormInfo
mkSelectorLFInfo id offset updatable
= LFThunk NotTopLevel False updatable (SelectorThunk offset)
(might_be_a_function (idType id))
mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo
mkApLFInfo id upd_flag arity
= LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
(might_be_a_function (idType id))
\end{code}
Miscellaneous LF-infos.
\begin{code}
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id = LFUnknown (might_be_a_function (idType id))
mkLFLetNoEscape :: Int -> LambdaFormInfo
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
= case idArity id of
n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr")
_ -> mkLFArgument id
\end{code}
\begin{code}
isLFThunk :: LambdaFormInfo -> Bool
isLFThunk (LFThunk _ _ _ _ _) = True
isLFThunk (LFBlackHole _) = True
isLFThunk _ = False
\end{code}
%************************************************************************
%* *
Building ClosureInfos
%* *
%************************************************************************
\begin{code}
mkClosureInfo :: Bool
-> Id
-> LambdaFormInfo
-> Int -> Int
-> C_SRT
-> String
-> ClosureInfo
mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
= ClosureInfo { closureName = name,
closureLFInfo = lf_info,
closureSMRep = sm_rep,
closureSRT = srt_info,
closureType = idType id,
closureDescr = descr }
where
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
mkConInfo :: Bool
-> DataCon
-> Int -> Int
-> ClosureInfo
mkConInfo is_static data_con tot_wds ptr_wds
= ConInfo { closureSMRep = sm_rep,
closureCon = data_con }
where
sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
%************************************************************************
%* *
\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
%* *
%************************************************************************
\begin{code}
closureSize :: ClosureInfo -> WordOff
closureSize cl_info = hdr_size + closureNonHdrSize cl_info
where hdr_size | closureIsThunk cl_info = thunkHdrSize
| otherwise = fixedHdrSize
closureNonHdrSize :: ClosureInfo -> WordOff
closureNonHdrSize cl_info
= tot_wds + computeSlopSize tot_wds cl_info
where
tot_wds = closureGoodStuffSize cl_info
closureGoodStuffSize :: ClosureInfo -> WordOff
closureGoodStuffSize cl_info
= let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs + nonptrs
closurePtrsSize :: ClosureInfo -> WordOff
closurePtrsSize cl_info
= let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs
sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs)
sizes_from_SMRep BlackHoleRep = (0, 0)
\end{code}
Computing slop size. WARNING: this looks dodgy --- it has deep
knowledge of what the storage manager does with the various
representations...
Slop Requirements: every thunk gets an extra padding word in the
header, which takes the the updated value.
\begin{code}
slopSize :: ClosureInfo -> WordOff
slopSize cl_info = computeSlopSize payload_size cl_info
where payload_size = closureGoodStuffSize cl_info
computeSlopSize :: WordOff -> ClosureInfo -> WordOff
computeSlopSize payload_size cl_info
= max 0 (minPayloadSize smrep updatable payload_size)
where
smrep = closureSMRep cl_info
updatable = closureNeedsUpdSpace cl_info
closureNeedsUpdSpace :: ClosureInfo -> Bool
closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
LFThunk TopLevel _ _ _ _ }) = True
closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
minPayloadSize :: SMRep -> Bool -> WordOff
minPayloadSize smrep updatable
= case smrep of
BlackHoleRep -> min_upd_size
GenericRep _ _ _ _ | updatable -> min_upd_size
GenericRep True _ _ _ -> 0
GenericRep False _ _ _ -> mIN_PAYLOAD_SIZE
where
min_upd_size =
ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader)
0
\end{code}
%************************************************************************
%* *
\subsection[SMreps]{Choosing SM reps}
%* *
%************************************************************************
\begin{code}
chooseSMRep
:: Bool
-> LambdaFormInfo
-> WordOff -> WordOff
-> SMRep
chooseSMRep is_static lf_info tot_wds ptr_wds
= let
nonptr_wds = tot_wds ptr_wds
closure_type = getClosureType is_static ptr_wds lf_info
in
GenericRep is_static ptr_wds nonptr_wds closure_type
getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
getClosureType is_static ptr_wds lf_info
= case lf_info of
LFCon _ | is_static && ptr_wds == 0 -> ConstrNoCaf
| otherwise -> Constr
LFReEntrant _ _ _ _ -> Fun
LFThunk _ _ _ (SelectorThunk _) _ -> ThunkSelector
LFThunk _ _ _ _ _ -> Thunk
_ -> panic "getClosureType"
\end{code}
%************************************************************************
%* *
\subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
%* *
%************************************************************************
Be sure to see the stg-details notes about these...
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> Bool
nodeMustPointToIt (LFReEntrant top _ no_fvs _)
= not no_fvs ||
isNotTopLevel top
nodeMustPointToIt (LFCon _) = True
nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
= updatable || not no_fvs || opt_SccProfilingOn
nodeMustPointToIt (LFThunk _ _ _ _ _)
= True
nodeMustPointToIt (LFUnknown _) = True
nodeMustPointToIt (LFBlackHole _) = True
nodeMustPointToIt (LFLetNoEscape _) = False
\end{code}
The entry conventions depend on the type of closure being entered,
whether or not it has free variables, and whether we're running
sequentially or in parallel.
\begin{tabular}{lllll}
Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\
Unknown & no & yes & stack & node \\
Known fun ($\ge$ 1 arg), no fvs & no & no & registers & fast entry (enough args) \\
\ & \ & \ & \ & slow entry (otherwise) \\
Known fun ($\ge$ 1 arg), fvs & no & yes & registers & fast entry (enough args) \\
0 arg, no fvs @\r,\s@ & no & no & n/a & direct entry \\
0 arg, no fvs @\u@ & no & yes & n/a & node \\
0 arg, fvs @\r,\s@ & no & yes & n/a & direct entry \\
0 arg, fvs @\u@ & no & yes & n/a & node \\
Unknown & yes & yes & stack & node \\
Known fun ($\ge$ 1 arg), no fvs & yes & no & registers & fast entry (enough args) \\
\ & \ & \ & \ & slow entry (otherwise) \\
Known fun ($\ge$ 1 arg), fvs & yes & yes & registers & node \\
0 arg, no fvs @\r,\s@ & yes & no & n/a & direct entry \\
0 arg, no fvs @\u@ & yes & yes & n/a & node \\
0 arg, fvs @\r,\s@ & yes & yes & n/a & node \\
0 arg, fvs @\u@ & yes & yes & n/a & node\\
\end{tabular}
When black-holing, single-entry closures could also be entered via node
(rather than directly) to catch double-entry.
\begin{code}
data CallMethod
= EnterIt
| JumpToIt CLabel
| ReturnIt
| ReturnCon DataCon
| SlowCall
| DirectEntry
CLabel
Int
getCallMethod :: DynFlags
-> Name
-> CafInfo
-> LambdaFormInfo
-> Int
-> CallMethod
getCallMethod _ _ _ lf_info _
| nodeMustPointToIt lf_info && opt_Parallel
=
EnterIt
getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt
| n_args < arity = SlowCall
| otherwise = DirectEntry (enterIdLabel name caf) arity
getCallMethod _ _ _ (LFCon con) n_args
| opt_SccProfilingOn
= EnterIt
| otherwise
= ASSERT( n_args == 0 )
ReturnCon con
getCallMethod _dflags _name _caf (LFThunk _ _ _updatable _std_form_info is_fun) _n_args
| is_fun
= SlowCall
| otherwise
= EnterIt
getCallMethod _ _ _ (LFUnknown True) _
= SlowCall
getCallMethod _ name _ (LFUnknown False) n_args
| n_args > 0
= WARN( True, ppr name <+> ppr n_args )
SlowCall
| otherwise
= EnterIt
getCallMethod _ _ _ (LFBlackHole _) _
= SlowCall
getCallMethod _ name _ (LFLetNoEscape 0) _
= JumpToIt (enterReturnPtLabel (nameUnique name))
getCallMethod _ name _ (LFLetNoEscape arity) n_args
| n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
| otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
blackHoleOnEntry _ ConInfo{} = False
blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
| isStaticRep rep
= False
| otherwise
= case lf_info of
LFReEntrant _ _ _ _ -> False
LFLetNoEscape _ -> False
LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
else doingTickyProfiling dflags || not no_fvs
_ -> panic "blackHoleOnEntry"
isStandardFormThunk :: LambdaFormInfo -> Bool
isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
isStandardFormThunk _ = False
isKnownFun :: LambdaFormInfo -> Bool
isKnownFun (LFReEntrant _ _ _ _) = True
isKnownFun (LFLetNoEscape _) = True
isKnownFun _ = False
\end{code}
Note [Unsafe coerce complications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In some (badly-optimised) DPH code we see this
Module X: rr :: Int = error Int "Urk"
Module Y: ...((X.rr |> g) True) ...
where g is an (unsafe) coercion of kind (Int ~ Bool->Bool), say
It's badly optimised, because knowing that 'X.rr' is bottom, we should
have dumped the application to True. But it should still work. These
strange unsafe coercions arise from the case-of-error transformation:
(case (error Int "foo") of { ... }) True
---> (error Int "foo" |> g) True
Anyway, the net effect is that in STG-land, when casts are discarded,
we *can* see a value of type Int applied to an argument. This only happens
if (a) the programmer made a mistake, or (b) the value of type Int is
actually bottom.
So it's wrong to trigger an ASSERT failure in this circumstance. Instead
we now emit a WARN -- mainly to draw attention to a probably-badly-optimised
program fragment -- and do the conservative thing which is SlowCall.
-----------------------------------------------------------------------------
SRT-related stuff
\begin{code}
staticClosureNeedsLink :: ClosureInfo -> Bool
staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
= needsSRT srt
staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
= not (isNullaryRepDataCon con) && not_nocaf_constr
where
not_nocaf_constr =
case sm_rep of
GenericRep _ _ _ ConstrNoCaf -> False
_other -> True
\end{code}
Note [Entering error thunks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
fail :: Int
fail = error Int "Urk"
foo :: Bool -> Bool
foo True y = (fail `cast` Bool -> Bool) y
foo False y = False
This looks silly, but it can arise from case-of-error. Even if it
does, we'd usually see that 'fail' is a bottoming function and would
discard the extra argument 'y'. But even if that does not occur,
this program is still OK. We will enter 'fail', which never returns.
The WARN is just to alert me to the fact that we aren't spotting that
'fail' is bottoming.
(We are careful never to make a funtion value look like a data type,
because we can't enter a function closure -- but that is not the
problem here.)
Avoiding generating entries and info tables
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At present, for every function we generate all of the following,
just in case. But they aren't always all needed, as noted below:
[NB1: all of this applies only to *functions*. Thunks always
have closure, info table, and entry code.]
[NB2: All are needed if the function is *exported*, just to play safe.]
* Fast-entry code ALWAYS NEEDED
* Slow-entry code
Needed iff (a) we have any un-saturated calls to the function
OR (b) the function is passed as an arg
OR (c) we're in the parallel world and the function has free vars
[Reason: in parallel world, we always enter functions
with free vars via the closure.]
* The function closure
Needed iff (a) we have any un-saturated calls to the function
OR (b) the function is passed as an arg
OR (c) if the function has free vars (ie not top level)
Why case (a) here? Because if the arg-satis check fails,
UpdatePAP stuffs a pointer to the function closure in the PAP.
[Could be changed; UpdatePAP could stuff in a code ptr instead,
but doesn't seem worth it.]
[NB: these conditions imply that we might need the closure
without the slow-entry code. Here's how.
f x y = let g w = ...x..y..w...
in
...(g t)...
Here we need a closure for g which contains x and y,
but since the calls are all saturated we just jump to the
fast entry point for g, with R1 pointing to the closure for g.]
* Standard info table
Needed iff (a) we have any un-saturated calls to the function
OR (b) the function is passed as an arg
OR (c) the function has free vars (ie not top level)
NB. In the sequential world, (c) is only required so that the function closure has
an info table to point to, to keep the storage manager happy.
If (c) alone is true we could fake up an info table by choosing
one of a standard family of info tables, whose entry code just
bombs out.
[NB In the parallel world (c) is needed regardless because
we enter functions with free vars via the closure.]
If (c) is retained, then we'll sometimes generate an info table
(for storage mgr purposes) without slow-entry code. Then we need
to use an error label in the info table to substitute for the absent
slow entry code.
\begin{code}
staticClosureRequired
:: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
staticClosureRequired _ bndr_info
(LFReEntrant top_level _ _ _)
= ASSERT( isTopLevel top_level )
not (satCallsOnly bndr_info)
staticClosureRequired _ _ _ = True
\end{code}
%************************************************************************
%* *
\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
%* *
%************************************************************************
\begin{code}
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
closureUpdReqd ConInfo{} = False
lfUpdatable :: LambdaFormInfo -> Bool
lfUpdatable (LFThunk _ _ upd _ _) = upd
lfUpdatable (LFBlackHole _) = True
lfUpdatable _ = False
closureIsThunk :: ClosureInfo -> Bool
closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
closureIsThunk ConInfo{} = False
closureSingleEntry :: ClosureInfo -> Bool
closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
closureSingleEntry _ = False
closureReEntrant :: ClosureInfo -> Bool
closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant _ = False
isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
isConstrClosure_maybe _ = Nothing
closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
closureFunInfo _ = Nothing
lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
funTag :: ClosureInfo -> Int
funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info
funTag _ = 0
funTagLFInfo :: LambdaFormInfo -> Int
funTagLFInfo lf
| Just (arity,_) <- lfFunInfo lf,
Just tag <- tagForArity arity
= tag
| otherwise
= 0
tagForArity :: Int -> Maybe Int
tagForArity i | i <= mAX_PTR_TAG = Just i
| otherwise = Nothing
\end{code}
\begin{code}
isToplevClosure :: ClosureInfo -> Bool
isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
= case lf_info of
LFReEntrant TopLevel _ _ _ -> True
LFThunk TopLevel _ _ _ _ -> True
_ -> False
isToplevClosure _ = False
\end{code}
Label generation.
\begin{code}
infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel
infoTableLabelFromCI (ClosureInfo { closureName = name,
closureLFInfo = lf_info }) caf
= case lf_info of
LFBlackHole info -> info
LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
mkSelectorInfoLabel upd_flag offset
LFThunk _ _ upd_flag (ApThunk arity) _ ->
mkApInfoTableLabel upd_flag arity
LFThunk{} -> mkLocalInfoTableLabel name caf
LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf
_ -> panic "infoTableLabelFromCI"
infoTableLabelFromCI (ConInfo { closureCon = con,
closureSMRep = rep }) caf
| isStaticRep rep = mkStaticInfoTableLabel name caf
| otherwise = mkConInfoTableLabel name caf
where
name = dataConName con
closureLabelFromCI :: ClosureInfo -> CafInfo -> CLabel
closureLabelFromCI (ClosureInfo { closureName = nm }) caf = mkLocalClosureLabel nm caf
closureLabelFromCI _ _ = panic "closureLabelFromCI"
enterIdLabel :: Name -> CafInfo -> CLabel
enterIdLabel id
| tablesNextToCode = mkInfoTableLabel id
| otherwise = mkEntryLabel id
enterLocalIdLabel :: Name -> CafInfo -> CLabel
enterLocalIdLabel id
| tablesNextToCode = mkLocalInfoTableLabel id
| otherwise = mkLocalEntryLabel id
enterReturnPtLabel :: Unique -> CLabel
enterReturnPtLabel name
| tablesNextToCode = mkReturnInfoLabel name
| otherwise = mkReturnPtLabel name
\end{code}
We need a black-hole closure info to pass to @allocDynClosure@ when we
want to allocate the black hole on entry to a CAF. These are the only
ways to build an LFBlackHole, maintaining the invariant that it really
is a black hole and not something else.
\begin{code}
cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
closureType = ty })
= ClosureInfo { closureName = nm,
closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
closureSMRep = BlackHoleRep,
closureSRT = NoC_SRT,
closureType = ty,
closureDescr = "" }
cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
\end{code}
%************************************************************************
%* *
\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
%* *
%************************************************************************
Profiling requires two pieces of information to be determined for
each closure's info table --- description and type.
The description is stored directly in the @CClosureInfoTable@ when the
info table is built.
The type is determined from the type information stored with the @Id@
in the closure info using @closureTypeDescr@.
\begin{code}
closureValDescr, closureTypeDescr :: ClosureInfo -> String
closureValDescr (ClosureInfo {closureDescr = descr})
= descr
closureValDescr (ConInfo {closureCon = con})
= occNameString (getOccName con)
closureTypeDescr (ClosureInfo { closureType = ty })
= getTyDescription ty
closureTypeDescr (ConInfo { closureCon = data_con })
= occNameString (getOccName (dataConTyCon data_con))
getTyDescription :: Type -> String
getTyDescription ty
= case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
case tau_ty of
TyVarTy _ -> "*"
AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
PredTy sty -> getPredTyDescription sty
ForAllTy _ ty -> getTyDescription ty
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getPredTyDescription :: PredType -> String
getPredTyDescription (ClassP cl _) = getOccString cl
getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
getPredTyDescription (EqPred _ _) = panic "getPredTyDescription EqPred"
\end{code}