%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The Univserity of Glasgow 1992-2004
%
-% $Id: ClosureInfo.lhs,v 1.49 2001/10/18 16:29:13 simonpj Exp $
-%
-\section[ClosureInfo]{Data structures which describe closures}
+
+ 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, SMRep, -- all abstract
- StandardFormInfo,
+ StandardFormInfo,
- EntryConvention(..),
+ ArgDescr(..), Liveness(..),
+ C_SRT(..), needsSRT,
- mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
+ mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
- UpdateFlag,
+
+ mkClosureInfo, mkConInfo,
closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
- slopSize,
+ slopSize,
+
+ closureName, infoTableLabelFromCI,
+ closureLabelFromCI, closureSRT,
+ closureLFInfo, closureSMRep, closureUpdReqd,
+ closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
+ closureFunInfo, isStandardFormThunk, isKnownFun,
- layOutDynClosure, layOutDynConstr, layOutStaticClosure,
- layOutStaticNoFVClosure, layOutStaticConstr,
- mkVirtHeapOffsets,
+ enterIdLabel, enterReturnPtLabel,
- nodeMustPointToIt, getEntryConvention,
- FCode, CgInfoDownwards, CgState,
+ nodeMustPointToIt,
+ CallMethod(..), getCallMethod,
blackHoleOnEntry,
staticClosureRequired,
- slowFunEntryCodeRequired, funInfoTableRequired,
-
- closureName, infoTableLabelFromCI, fastLabelFromCI,
- closureLabelFromCI, closureSRT,
- entryLabelFromCI,
- closureLFInfo, closureSMRep, closureUpdReqd,
- closureSingleEntry, closureReEntrant, closureSemiTag,
- isStandardFormThunk,
- GenStgArg,
+ getClosureType,
isToplevClosure,
- closureTypeDescr, -- profiling
+ closureValDescr, closureTypeDescr, -- profiling
isStaticClosure,
- allocProfilingMsg,
cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
- maybeSelectorInfo,
staticClosureNeedsLink,
) where
+#include "../includes/MachDeps.h"
#include "HsVersions.h"
-import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset, C_SRT(..), needsSRT )
import StgSyn
-import CgMonad
-
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
- mAX_SPEC_FUN_SIZE, mAX_SPEC_THUNK_SIZE, mAX_SPEC_CONSTR_SIZE )
-import CgRetConv ( assignRegs )
-import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
- mkInfoTableLabel,
- mkConInfoTableLabel,
- mkCAFBlackHoleInfoTableLabel,
- mkSECAFBlackHoleInfoTableLabel,
- mkStaticInfoTableLabel, mkStaticConEntryLabel,
- mkConEntryLabel, mkClosureLabel,
- mkSelectorInfoLabel, mkSelectorEntryLabel,
- mkApInfoTableLabel, mkApEntryLabel,
- mkReturnPtLabel
- )
+import SMRep -- all of it
+
+import CLabel
+
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
-import Id ( Id, idType, idArity )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isNullaryDataCon, dataConName
- )
-import TyCon ( isBoxedTupleTyCon )
-import Name ( Name, nameUnique, getOccName )
+import Id ( Id, idType, idArity, idName )
+import DataCon ( DataCon, dataConTyCon, isNullaryDataCon, dataConName )
+import Name ( Name, nameUnique, getOccName, getOccString )
import OccName ( occNameUserString )
-import PprType ( getTyDescription )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
-import SMRep -- all of it
-import Type ( isUnLiftedType, Type )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
-import Util ( mapAccumL )
+import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
+import TcType ( tcSplitSigmaTy )
+import TyCon ( isFunTyCon, isAbstractTyCon )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
+import FastString
import Outputable
+import Constants
+
+import TypeRep -- TEMP
\end{code}
+
%************************************************************************
%* *
\subsection[ClosureInfo-datatypes]{Data types for closure information}
%* *
%************************************************************************
-The ``wrapper'' data type 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
- = MkClosureInfo {
- closureName :: Name, -- The thing bound to this closure
- closureLFInfo :: LambdaFormInfo, -- Info derivable from the *source*
- closureSMRep :: SMRep, -- representation used by storage manager
- closureSRT :: C_SRT -- What SRT applies to this closure
+ = ClosureInfo {
+ closureName :: !Name, -- The thing bound to this closure
+ closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
+ closureSMRep :: !SMRep, -- representation used by storage mgr
+ closureSRT :: !C_SRT, -- What SRT applies to this closure
+ closureType :: !Type, -- Type of closure (ToDo: remove)
+ closureDescr :: !String -- closure description (for profiling)
+ }
+
+ -- Constructor closures don't have a unique info table label (they use
+ -- the constructor's info table), and they don't have an SRT.
+ | ConInfo {
+ closureCon :: !DataCon,
+ closureSMRep :: !SMRep
}
+
+-- C_SRT is what StgSyn.SRT gets translated to...
+-- we add a label for the table, and expect only the 'offset/length' form
+
+data C_SRT = NoC_SRT
+ | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
+
+needsSRT :: C_SRT -> Bool
+needsSRT NoC_SRT = False
+needsSRT (C_SRT _ _ _) = True
\end{code}
%************************************************************************
%* *
%************************************************************************
+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 -- Reentrant closure; used for PAPs too
- Type -- Type of closure (ToDo: remove)
+ = LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
- !Int -- Arity
+ !Int -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
+ ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
- | LFCon -- Constructor
+ | LFCon -- A saturated constructor application
DataCon -- The constructor
- Bool -- True <=> zero arity
-
- | LFTuple -- Tuples
- DataCon -- The tuple constructor
- Bool -- True <=> zero arity
| LFThunk -- Thunk (zero arity)
- Type -- Type of the thunk (ToDo: remove)
TopLevelFlag
!Bool -- True <=> no free vars
- Bool -- True <=> updatable (i.e., *not* single-entry)
+ !Bool -- True <=> updatable (i.e., *not* single-entry)
StandardFormInfo
+ !Bool -- True <=> *might* be a function type
- | LFArgument -- Used for function arguments. We know nothing about
- -- this closure. Treat like updatable "LFThunk"...
-
- | LFImported -- Used for imported things. We know nothing about this
- -- closure. Treat like updatable "LFThunk"...
+ | LFUnknown -- Used for function arguments and imported things.
+ -- We know nothing about this closure. Treat like
+ -- updatable "LFThunk"...
-- Imported things which we do know something about use
-- one of the other LF constructors (eg LFReEntrant for
-- known functions)
+ !Bool -- True <=> *might* be a function type
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
- Int -- arity;
+ !Int -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-- of a CAF. We want the target of the update frame to
CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
-data StandardFormInfo -- Tells whether this thunk has one of a small number
- -- of standard forms
+-------------------------
+-- An ArgDsecr describes the argument pattern of a function
- = NonStandardThunk -- No, it isn't
+data ArgDescr
+ = ArgSpec -- Fits one of the standard patterns
+ !Int -- RTS type identifier ARG_P, ARG_N, ...
- | SelectorThunk
- Int -- 0-origin offset of ak within the "goods" of
- -- constructor (Recall that the a1,...,an may be laid
- -- out in the heap in a non-obvious order.)
+ | ArgGen -- General case
+ Liveness -- Details about the arguments
-{- A SelectorThunk is of form
- case x of
- con a1,..,an -> ak
+-------------------------
+-- We represent liveness bitmaps as a Bitmap (whose internal
+-- representation really is a bitmap). These are pinned onto case return
+-- vectors to indicate the state of the stack for the garbage collector.
+--
+-- In the compiled program, liveness bitmaps that fit inside a single
+-- word (StgWord) are stored as a single word, while larger bitmaps are
+-- stored as a pointer to an array of words.
- and the constructor is from a single-constr type.
--}
+data Liveness
+ = SmallLiveness -- Liveness info that fits in one word
+ StgWord -- Here's the bitmap
- | ApThunk
- Int -- arity
+ | BigLiveness -- Liveness info witha a multi-word bitmap
+ CLabel -- Label for the bitmap
-{- An ApThunk is of form
- x1 ... xn
+-------------------------
+-- StandardFormInfo tells whether this thunk has one of
+-- a small number of standard forms
- The code for the thunk just pushes x2..xn on the stack and enters x1.
- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
- in the RTS to save space.
--}
+data StandardFormInfo
+ = NonStandardThunk
+ -- Not of of the standard forms
+ | SelectorThunk
+ -- A SelectorThunk is of form
+ -- case x of
+ -- con a1,..,an -> ak
+ -- and the constructor is from a single-constr type.
+ WordOff -- 0-origin offset of ak within the "goods" of
+ -- constructor (Recall that the a1,...,an may be laid
+ -- out in the heap in a non-obvious order.)
+
+ | ApThunk
+ -- An ApThunk is of form
+ -- x1 ... xn
+ -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+ -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+ -- in the RTS to save space.
+ Int -- Arity, n
\end{code}
%************************************************************************
%* *
%************************************************************************
-@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.
-
\begin{code}
-mkClosureLFInfo :: Id -- The binder
- -> TopLevelFlag -- True of top level
- -> [Id] -- Free vars
- -> UpdateFlag -- Update flag
- -> [Id] -- Args
- -> LambdaFormInfo
-
-mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
- = LFReEntrant (idType bndr) top (length args) (null fvs)
-
-mkClosureLFInfo bndr top fvs ReEntrant []
- = LFReEntrant (idType bndr) top 0 (null fvs)
-
-mkClosureLFInfo bndr top fvs upd_flag []
-#ifdef DEBUG
- | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty)
-#endif
- | otherwise
- = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk
- where
- ty = idType bndr
+mkLFReEntrant :: TopLevelFlag -- True of top level
+ -> [Id] -- Free vars
+ -> [Id] -- Args
+ -> ArgDescr -- Argument descriptor
+ -> LambdaFormInfo
+
+mkLFReEntrant top fvs args arg_descr
+ = LFReEntrant top (length args) (null fvs) arg_descr
+
+mkLFThunk thunk_ty top fvs upd_flag
+ = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
+ 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
+ | Just (tc,_) <- splitTyConApp_maybe (repType ty),
+ not (isFunTyCon tc) && not (isAbstractTyCon tc) = False
+ -- don't forget to check for abstract types, which might
+ -- be functions too.
+ | otherwise = True
\end{code}
@mkConLFInfo@ is similar, for constructors.
\begin{code}
mkConLFInfo :: DataCon -> LambdaFormInfo
+mkConLFInfo con = LFCon con
-mkConLFInfo con
- = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
- (if isBoxedTupleTyCon (dataConTyCon con) then LFTuple else LFCon)
- con (isNullaryDataCon con)
-
-mkSelectorLFInfo rhs_ty offset updatable
- = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
+mkSelectorLFInfo id offset updatable
+ = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+ (might_be_a_function (idType id))
-mkApLFInfo rhs_ty upd_flag arity
- = LFThunk rhs_ty NotTopLevel (arity == 0)
- (isUpdatable upd_flag) (ApThunk arity)
+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 = LFArgument
+mkLFArgument id = LFUnknown (might_be_a_function (idType id))
+
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
= case idArity id of
- n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0
- other -> LFImported -- Not sure of exact arity
+ n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0
+ other -> mkLFArgument id -- Not sure of exact arity
+\end{code}
+
+%************************************************************************
+%* *
+ Building ClosureInfos
+%* *
+%************************************************************************
+
+\begin{code}
+mkClosureInfo :: Bool -- Is static
+ -> Id
+ -> LambdaFormInfo
+ -> Int -> Int -- Total and pointer words
+ -> C_SRT
+ -> String -- String descriptor
+ -> 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 -- Is static
+ -> DataCon
+ -> Int -> Int -- Total and pointer words
+ -> 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}
%************************************************************************
%************************************************************************
\begin{code}
-closureSize :: ClosureInfo -> HeapOffset
+closureSize :: ClosureInfo -> WordOff
closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
-closureNonHdrSize :: ClosureInfo -> Int
+closureNonHdrSize :: ClosureInfo -> WordOff
closureNonHdrSize cl_info
= tot_wds + computeSlopSize tot_wds
(closureSMRep cl_info)
- (closureUpdReqd cl_info)
+ (closureNeedsUpdSpace cl_info)
where
tot_wds = closureGoodStuffSize cl_info
-slopSize :: ClosureInfo -> Int
+-- we leave space for an update if either (a) the closure is updatable
+-- or (b) it is a static thunk. This is because a static thunk needs
+-- a static link field in a predictable place (after the slop), regardless
+-- of whether it is updatable or not.
+closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
+ LFThunk TopLevel _ _ _ _ }) = True
+closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
+
+slopSize :: ClosureInfo -> WordOff
slopSize cl_info
= computeSlopSize (closureGoodStuffSize cl_info)
(closureSMRep cl_info)
- (closureUpdReqd cl_info)
+ (closureNeedsUpdSpace cl_info)
-closureGoodStuffSize :: ClosureInfo -> Int
+closureGoodStuffSize :: ClosureInfo -> WordOff
closureGoodStuffSize cl_info
= let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs + nonptrs
-closurePtrsSize :: ClosureInfo -> Int
+closurePtrsSize :: ClosureInfo -> WordOff
closurePtrsSize cl_info
= let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs
-- not exported:
-sizes_from_SMRep :: SMRep -> (Int,Int)
+sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs)
sizes_from_SMRep BlackHoleRep = (0, 0)
\end{code}
don't bother taking that into account here.
\begin{code}
-computeSlopSize :: Int -> SMRep -> Bool -> Int
+computeSlopSize :: WordOff -> SMRep -> Bool -> WordOff
computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
%************************************************************************
%* *
-\subsection[layOutDynClosure]{Lay out a dynamic closure}
-%* *
-%************************************************************************
-
-\begin{code}
-layOutDynClosure, layOutStaticClosure
- :: Name -- STG identifier of this closure
- -> (a -> PrimRep) -- how to get a PrimRep for the fields
- -> [a] -- the "things" being layed out
- -> LambdaFormInfo -- what sort of closure it is
- -> C_SRT
- -> (ClosureInfo, -- info about the closure
- [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
-
-layOutDynClosure name kind_fn things lf_info srt_info
- = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
- closureSMRep = sm_rep, closureSRT = srt_info },
- things_w_offsets)
- where
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets kind_fn things
- sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
-\end{code}
-
-Wrappers for when used with data constructors:
-
-\begin{code}
-layOutDynConstr, layOutStaticConstr
- :: Name -- Of the closure
- -> DataCon
- -> (a -> PrimRep) -> [a]
- -> (ClosureInfo, [(a,VirtualHeapOffset)])
-
-layOutDynConstr name data_con kind_fn args
- = layOutDynClosure name kind_fn args (mkConLFInfo data_con) NoC_SRT
-
-layOutStaticConstr name data_con kind_fn things
- = layOutStaticClosure name kind_fn things (mkConLFInfo data_con) NoC_SRT
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[layOutStaticClosure]{Lay out a static closure}
-%* *
-%************************************************************************
-
-layOutStaticClosure is only used for laying out static constructors at
-the moment.
-
-Static closures for functions are laid out using
-layOutStaticNoFVClosure.
-
-\begin{code}
-layOutStaticClosure name kind_fn things lf_info srt_info
- = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
- closureSMRep = rep, closureSRT = srt_info },
- things_w_offsets)
- where
- rep = GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type
-
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets kind_fn things
-
- -- constructors with no pointer fields will definitely be NOCAF things.
- -- this is a compromise until we can generate both kinds of constructor
- -- (a normal static kind and the NOCAF_STATIC kind).
- closure_type = getClosureType is_static tot_wds ptr_wds lf_info
- is_static = True
-
-layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> C_SRT -> ClosureInfo
-layOutStaticNoFVClosure name lf_info srt_info
- = MkClosureInfo { closureName = name, closureLFInfo = lf_info,
- closureSMRep = rep, closureSRT = srt_info }
- where
- rep = GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info)
- is_static = True
-\end{code}
-
-%************************************************************************
-%* *
\subsection[SMreps]{Choosing SM reps}
%* *
%************************************************************************
\begin{code}
-chooseDynSMRep
- :: LambdaFormInfo
- -> Int -> Int -- Tot wds, ptr wds
+chooseSMRep
+ :: Bool -- True <=> static closure
+ -> LambdaFormInfo
+ -> WordOff -> WordOff -- Tot wds, ptr wds
-> SMRep
-chooseDynSMRep lf_info tot_wds ptr_wds
+chooseSMRep is_static lf_info tot_wds ptr_wds
= let
- is_static = False
nonptr_wds = tot_wds - ptr_wds
- closure_type = getClosureType is_static tot_wds ptr_wds lf_info
+ closure_type = getClosureType is_static ptr_wds lf_info
in
GenericRep is_static ptr_wds nonptr_wds closure_type
--- we *do* get non-updatable top-level thunks sometimes. eg. f = g
+-- We *do* get non-updatable top-level thunks sometimes. eg. f = g
-- gets compiled to a jump to g (if g has non-zero arity), instead of
-- messing around with update frames and PAPs. We set the closure type
-- to FUN_STATIC in this case.
-getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType
-getClosureType is_static tot_wds ptr_wds lf_info
+getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
+getClosureType is_static ptr_wds lf_info
= case lf_info of
- LFCon con zero_arity
- | is_static && ptr_wds == 0 -> CONSTR_NOCAF
- | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n
- | otherwise -> CONSTR
-
- LFTuple _ zero_arity
- | is_static && ptr_wds == 0 -> CONSTR_NOCAF
- | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n
- | otherwise -> CONSTR
-
- LFReEntrant _ _ _ _
- | specialised_rep mAX_SPEC_FUN_SIZE -> FUN_p_n
- | otherwise -> FUN
-
- LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
-
- LFThunk _ _ _ _ _
- | specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n
- | otherwise -> THUNK
-
+ LFCon con | is_static && ptr_wds == 0 -> ConstrNoCaf
+ | otherwise -> Constr
+ LFReEntrant _ _ _ _ -> Fun
+ LFThunk _ _ _ (SelectorThunk _) _ -> ThunkSelector
+ LFThunk _ _ _ _ _ -> Thunk
_ -> panic "getClosureType"
- where
- specialised_rep max_size = not is_static
- && tot_wds > 0
- && tot_wds <= max_size
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
-%* *
-%************************************************************************
-
-@mkVirtHeapOffsets@ (the heap version) always returns boxed things with
-smaller offsets than the unboxed things, and furthermore, the offsets in
-the result list
-
-\begin{code}
-mkVirtHeapOffsets ::
- (a -> PrimRep) -- To be able to grab kinds;
- -- w/ a kind, we can find boxedness
- -> [a] -- Things to make offsets for
- -> (Int, -- *Total* number of words allocated
- Int, -- Number of words allocated for *pointers*
- [(a, VirtualHeapOffset)])
- -- Things with their offsets from start of
- -- object in order of increasing offset
-
--- First in list gets lowest offset, which is initial offset + 1.
-
-mkVirtHeapOffsets kind_fun things
- = let (ptrs, non_ptrs) = separateByPtrFollowness kind_fun things
- (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
- (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
- in
- (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
- where
- computeOffset wds_so_far thing
- = (wds_so_far + (getPrimRepSize . kind_fun) thing,
- (thing, fixedHdrSize + wds_so_far)
- )
\end{code}
%************************************************************************
Be sure to see the stg-details notes about these...
\begin{code}
-nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
-nodeMustPointToIt lf_info
-
- = case lf_info of
- LFReEntrant ty top arity no_fvs -> returnFC (
- not no_fvs || -- Certainly if it has fvs we need to point to it
- isNotTopLevel top
+nodeMustPointToIt :: LambdaFormInfo -> Bool
+nodeMustPointToIt (LFReEntrant top _ no_fvs _)
+ = not no_fvs || -- Certainly if it has fvs we need to point to it
+ isNotTopLevel top
-- If it is not top level we will point to it
-- We can have a \r closure with no_fvs which
-- is not top level as special case cgRhsClosure
-- For lex_profiling we also access the cost centre for a
-- non-inherited function i.e. not top level
-- the not top case above ensures this is ok.
- )
- LFCon _ zero_arity -> returnFC True
- LFTuple _ zero_arity -> returnFC True
+nodeMustPointToIt (LFCon _) = True
-- Strictly speaking, the above two don't need Node to point
-- to it if the arity = 0. But this is a *really* unlikely
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
- LFThunk _ _ no_fvs updatable NonStandardThunk
- -> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
-
+nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
+ = updatable || not no_fvs || opt_SccProfilingOn
-- For the non-updatable (single-entry case):
--
-- True if has fvs (in which case we need access to them, and we
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
- LFThunk _ _ no_fvs updatable some_standard_form_thunk
- -> returnFC True
- -- Node must point to any standard-form thunk.
-
- LFArgument -> returnFC True
- LFImported -> returnFC True
- LFBlackHole _ -> returnFC True
- -- BH entry may require Node to point
+nodeMustPointToIt (LFThunk _ no_fvs updatable some_standard_form_thunk _)
+ = True -- Node must point to any standard-form thunk
- LFLetNoEscape _ -> returnFC False
+nodeMustPointToIt (LFUnknown _) = True
+nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point
+nodeMustPointToIt (LFLetNoEscape _) = False
\end{code}
The entry conventions depend on the type of closure being entered,
(rather than directly) to catch double-entry.
\begin{code}
-data EntryConvention
- = ViaNode -- The "normal" convention
+data CallMethod
+ = EnterIt -- no args, not a function
+
+ | JumpToIt CLabel -- no args, not a function, but we
+ -- know what its entry code is
+
+ | ReturnIt -- it's a function, but we have
+ -- zero args to apply to it, so just
+ -- return it.
+
+ | ReturnCon DataCon -- It's a data constructor, just return it
- | StdEntry CLabel -- Jump to this code, with args on stack
+ | SlowCall -- Unknown fun, or known fun with
+ -- too few args.
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
- [MagicId] -- Its register assignments
- -- (possibly empty)
-
-getEntryConvention :: Name -- Function being applied
- -> LambdaFormInfo -- Its info
- -> [PrimRep] -- Available arguments
- -> FCode EntryConvention
-
-getEntryConvention name lf_info arg_kinds
- = nodeMustPointToIt lf_info `thenFC` \ node_points ->
- returnFC (
-
- -- if we're parallel, then we must always enter via node. The reason
- -- is that the closure may have been fetched since we allocated it.
-
- if (node_points && opt_Parallel) then ViaNode else
-
- -- Commented out by SDM after futher thoughts:
- -- - the only closure type that can be blackholed is a thunk
- -- - we already enter thunks via node (unless the closure is
- -- non-updatable, in which case why is it being re-entered...)
-
- case lf_info of
-
- LFReEntrant _ _ arity _ ->
- if arity == 0 || (length arg_kinds) < arity then
- StdEntry (mkStdEntryLabel name)
- else
- DirectEntry (mkFastEntryLabel name arity) arity arg_regs
- where
- (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
- live_regs = if node_points then [node] else []
-
- LFCon con True{-zero_arity-}
- -- a real constructor. Don't bother entering it, just jump
- -- to the constructor entry code directly.
- -> --false:ASSERT (null arg_kinds)
- -- Should have no args (meaning what?)
- StdEntry (mkStaticConEntryLabel (dataConName con))
-
- LFCon con False{-non-zero_arity-}
- -> --false:ASSERT (null arg_kinds)
- -- Should have no args (meaning what?)
- StdEntry (mkConEntryLabel (dataConName con))
-
- LFTuple tup zero_arity
- -> --false:ASSERT (null arg_kinds)
- -- Should have no args (meaning what?)
- StdEntry (mkConEntryLabel (dataConName tup))
-
- LFThunk _ _ _ updatable std_form_info
- -> if updatable || opt_DoTickyProfiling -- to catch double entry
- || opt_SMP -- always enter via node on SMP, since the
+
+getCallMethod :: Name -- Function being applied
+ -> LambdaFormInfo -- Its info
+ -> Int -- Number of available arguments
+ -> CallMethod
+
+getCallMethod name lf_info n_args
+ | nodeMustPointToIt lf_info && opt_Parallel
+ = -- If we're parallel, then we must always enter via node.
+ -- The reason is that the closure may have been
+ -- fetched since we allocated it.
+ EnterIt
+
+getCallMethod name (LFReEntrant _ arity _ _) n_args
+ | n_args == 0 = ASSERT( arity /= 0 )
+ ReturnIt -- No args at all
+ | n_args < arity = SlowCall -- Not enough args
+ | otherwise = DirectEntry (enterIdLabel name) arity
+
+getCallMethod name (LFCon con) n_args
+ = ASSERT( n_args == 0 )
+ ReturnCon con
+
+getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
+ | is_fun -- Must always "call" a function-typed
+ = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code
+ -- is the fast-entry code]
+
+ | updatable || opt_DoTickyProfiling -- to catch double entry
+ || opt_SMP -- Always enter via node on SMP, since the
-- thunk might have been blackholed in the
-- meantime.
- then ViaNode
- else StdEntry (thunkEntryLabel name std_form_info updatable)
-
- LFArgument -> ViaNode
- LFImported -> ViaNode
- LFBlackHole _ -> ViaNode -- Presumably the black hole has by now
- -- been updated, but we don't know with
- -- what, so we enter via Node
-
- LFLetNoEscape 0
- -> StdEntry (mkReturnPtLabel (nameUnique name))
-
- LFLetNoEscape arity
- -> if (arity /= length arg_kinds) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
- DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
- where
- (arg_regs, _) = assignRegs [] arg_kinds
- -- node never points to a LetNoEscape, see above --SDM
- --live_regs = if node_points then [node] else []
- )
+ = ASSERT( n_args == 0 ) EnterIt
-blackHoleOnEntry :: ClosureInfo -> Bool
+ | otherwise -- Jump direct to code for single-entry thunks
+ = ASSERT( n_args == 0 )
+ JumpToIt (thunkEntryLabel name std_form_info updatable)
+
+getCallMethod name (LFUnknown True) n_args
+ = SlowCall -- might be a function
+
+getCallMethod name (LFUnknown False) n_args
+ = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
+ EnterIt -- Not a function
+
+getCallMethod name (LFBlackHole _) n_args
+ = SlowCall -- Presumably the black hole has by now
+ -- been updated, but we don't know with
+ -- what, so we slow call it
+getCallMethod name (LFLetNoEscape 0) n_args
+ = 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 :: ClosureInfo -> Bool
-- Static closures are never themselves black-holed.
-- Updatable ones will be overwritten with a CAFList cell, which points to a
-- black hole;
-- Single-entry ones have no fvs to plug, and we trust they don't form part
-- of a loop.
-blackHoleOnEntry cl_info
- | isStaticRep (closureSMRep cl_info)
+blackHoleOnEntry ConInfo{} = False
+blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+ | isStaticRep rep
= False -- Never black-hole a static closure
| otherwise
- = case closureLFInfo cl_info of
+ = case lf_info of
LFReEntrant _ _ _ _ -> False
LFLetNoEscape _ -> False
- LFThunk _ _ no_fvs updatable _
+ LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
else opt_DoTickyProfiling || not no_fvs
other -> panic "blackHoleOnEntry" -- Should never happen
isStandardFormThunk :: LambdaFormInfo -> Bool
-
-isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True
-isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True
+isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
+isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
isStandardFormThunk other_lf_info = False
-maybeSelectorInfo (MkClosureInfo { closureLFInfo = LFThunk _ _ _ _ (SelectorThunk offset) })
- = Just offset
-maybeSelectorInfo _ = Nothing
+isKnownFun :: LambdaFormInfo -> Bool
+isKnownFun (LFReEntrant _ _ _ _) = True
+isKnownFun (LFLetNoEscape _) = True
+isKnownFun _ = False
\end{code}
-----------------------------------------------------------------------------
-- A static closure needs a link field to aid the GC when traversing
-- the static closure graph. But it only needs such a field if either
-- a) it has an SRT
--- b) it's a non-nullary constructor
+-- b) it's a constructor with one or more pointer fields
-- In case (b), the constructor's fields themselves play the role
-- of the SRT.
-staticClosureNeedsLink (MkClosureInfo { closureName = name, closureSRT = srt, closureLFInfo = info })
- = needsSRT srt || constructor_srt
+staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
+ = needsSRT srt
+staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
+ = not (isNullaryDataCon con) && not_nocaf_constr
where
- constructor_srt
- = case info of
- LFThunk _ _ _ _ _ -> False
- LFReEntrant _ _ _ _ -> False
- LFCon _ is_nullary -> not is_nullary
- LFTuple _ is_nullary -> not is_nullary
- other -> pprPanic "staticClosureNeedsLink" (ppr name)
+ not_nocaf_constr =
+ case sm_rep of
+ GenericRep _ _ _ ConstrNoCaf -> False
+ _other -> True
\end{code}
Avoiding generating entries and info tables
-> LambdaFormInfo
-> Bool
staticClosureRequired binder bndr_info
- (LFReEntrant _ top_level _ _) -- It's a function
+ (LFReEntrant top_level _ _ _) -- It's a function
= ASSERT( isTopLevel top_level )
-- Assumption: it's a top-level, no-free-var binding
not (satCallsOnly bndr_info)
staticClosureRequired binder other_binder_info other_lf_info = True
-
-slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk.
- :: Name
- -> StgBinderInfo
- -> EntryConvention
- -> Bool
-slowFunEntryCodeRequired binder bndr_info entry_conv
- = not (satCallsOnly bndr_info)
- || (case entry_conv of { DirectEntry _ _ _ -> False; other -> True })
- {- The last case deals with the parallel world; a function usually
- as a DirectEntry convention, but if it doesn't we must generate slow-entry code -}
-
-funInfoTableRequired
- :: Name
- -> StgBinderInfo
- -> LambdaFormInfo
- -> Bool
-funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _)
- = isNotTopLevel top_level
- || not (satCallsOnly bndr_info)
-
-funInfoTableRequired other_binder_info binder other_lf_info = True
\end{code}
%************************************************************************
isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = upd
-closureUpdReqd (MkClosureInfo { closureLFInfo = LFBlackHole _ }) = True
+closureUpdReqd (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ }) = upd
+closureUpdReqd (ClosureInfo { closureLFInfo = LFBlackHole _ }) = True
-- Black-hole closures are allocated to receive the results of an
-- alg case with a named default... so they need to be updated.
closureUpdReqd other_closure = False
closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
closureSingleEntry other_closure = False
closureReEntrant :: ClosureInfo -> Bool
-closureReEntrant (MkClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant other_closure = False
-\end{code}
-\begin{code}
-closureSemiTag :: ClosureInfo -> Maybe Int
-closureSemiTag (MkClosureInfo { closureLFInfo = lf_info })
- = case lf_info of
- LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
- LFTuple _ _ -> Just 0
- _ -> Nothing
+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 = LFReEntrant _ arity _ arg_desc})
+ = Just (arity, arg_desc)
+closureFunInfo _
+ = Nothing
\end{code}
\begin{code}
isToplevClosure :: ClosureInfo -> Bool
-
-isToplevClosure (MkClosureInfo { closureLFInfo = lf_info })
+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
= case lf_info of
- LFReEntrant _ TopLevel _ _ -> True
- LFThunk _ TopLevel _ _ _ -> True
+ LFReEntrant TopLevel _ _ _ -> True
+ LFThunk TopLevel _ _ _ _ -> True
other -> False
+isToplevClosure _ = False
\end{code}
Label generation.
\begin{code}
-fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ _ arity _ })
- = mkFastEntryLabel name arity
-
-fastLabelFromCI cl_info
- = pprPanic "fastLabelFromCI" (ppr (closureName cl_info))
-
infoTableLabelFromCI :: ClosureInfo -> CLabel
-infoTableLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
+infoTableLabelFromCI (ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSMRep = rep })
= case lf_info of
- LFCon con _ -> mkConInfoPtr con rep
- LFTuple tup _ -> mkConInfoPtr tup rep
-
LFBlackHole info -> info
- LFThunk _ _ _ upd_flag (SelectorThunk offset) ->
+ LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
mkSelectorInfoLabel upd_flag offset
- LFThunk _ _ _ upd_flag (ApThunk arity) ->
+ LFThunk _ _ upd_flag (ApThunk arity) _ ->
mkApInfoTableLabel upd_flag arity
- other -> {-NO: if isStaticRep rep
- then mkStaticInfoTableLabel id
- else -} mkInfoTableLabel id
+ LFThunk{} -> mkInfoTableLabel name
+
+ LFReEntrant _ _ _ _ -> mkInfoTableLabel name
+
+ other -> panic "infoTableLabelFromCI"
+
+infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
+ = mkConInfoPtr con rep
+
mkConInfoPtr :: DataCon -> SMRep -> CLabel
mkConInfoPtr con rep
where
name = dataConName con
-mkConEntryPtr :: DataCon -> SMRep -> CLabel
-mkConEntryPtr con rep
- | isStaticRep rep = mkStaticConEntryLabel (dataConName con)
- | otherwise = mkConEntryLabel (dataConName con)
-
-closureLabelFromCI cl_info = mkClosureLabel (closureName cl_info)
-
-entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
- = case lf_info of
- LFThunk _ _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
- LFCon con _ -> mkConEntryPtr con rep
- LFTuple tup _ -> mkConEntryPtr tup rep
- other -> mkStdEntryLabel id
+closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm
+closureLabelFromCI _ = panic "closureLabelFromCI"
-- thunkEntryLabel is a local help function, not exported. It's used from both
--- entryLabelFromCI and getEntryConvention.
+-- entryLabelFromCI and getCallMethod.
thunkEntryLabel thunk_id (ApThunk arity) is_updatable
- = mkApEntryLabel is_updatable arity
+ = enterApLabel is_updatable arity
thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
- = mkSelectorEntryLabel upd_flag offset
+ = enterSelectorLabel upd_flag offset
thunkEntryLabel thunk_id _ is_updatable
- = mkStdEntryLabel thunk_id
-\end{code}
+ = enterIdLabel thunk_id
-\begin{code}
-allocProfilingMsg :: ClosureInfo -> FAST_STRING
-
-allocProfilingMsg cl_info
- = case closureLFInfo cl_info of
- LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
- LFCon _ _ -> SLIT("TICK_ALLOC_CON")
- LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
- LFThunk _ _ _ True _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable
- LFThunk _ _ _ False _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable
- LFBlackHole _ -> SLIT("TICK_ALLOC_BH")
- LFImported -> panic "TICK_ALLOC_IMP"
+enterApLabel is_updatable arity
+ | tablesNextToCode = mkApInfoTableLabel is_updatable arity
+ | otherwise = mkApEntryLabel is_updatable arity
+
+enterSelectorLabel upd_flag offset
+ | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
+ | otherwise = mkSelectorEntryLabel upd_flag offset
+
+enterIdLabel id
+ | tablesNextToCode = mkInfoTableLabel id
+ | otherwise = mkEntryLabel id
+
+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 cl_info
- = MkClosureInfo { closureName = closureName cl_info,
- closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
- closureSMRep = BlackHoleRep,
- closureSRT = NoC_SRT }
-
-seCafBlackHoleClosureInfo cl_info
- = MkClosureInfo { closureName = closureName cl_info,
- closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
- closureSMRep = BlackHoleRep,
- closureSRT = NoC_SRT }
+cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
+ closureType = ty })
+ = ClosureInfo { closureName = nm,
+ closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT,
+ closureType = ty,
+ closureDescr = "" }
+cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
+
+seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
+ closureType = ty })
+ = ClosureInfo { closureName = nm,
+ closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT,
+ closureType = ty,
+ closureDescr = "" }
+seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
\end{code}
%************************************************************************
in the closure info using @closureTypeDescr@.
\begin{code}
-closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr cl_info
- = case closureLFInfo cl_info of
- LFThunk ty _ _ _ _ -> getTyDescription ty
- LFReEntrant ty _ _ _ -> getTyDescription ty
- LFCon data_con _ -> occNameUserString (getOccName (dataConTyCon data_con))
- other -> showSDoc (ppr (closureName cl_info))
+closureValDescr, closureTypeDescr :: ClosureInfo -> String
+closureValDescr (ClosureInfo {closureDescr = descr})
+ = descr
+closureValDescr (ConInfo {closureCon = con})
+ = occNameUserString (getOccName con)
+
+closureTypeDescr (ClosureInfo { closureType = ty })
+ = getTyDescription ty
+closureTypeDescr (ConInfo { closureCon = data_con })
+ = occNameUserString (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
+ NewTcApp tycon _ -> getOccString tycon
+ TyConApp tycon _ -> getOccString tycon
+ NoteTy (FTVNote _) ty -> getTyDescription ty
+ NoteTy (SynNote ty1) _ -> getTyDescription ty1
+ PredTy sty -> getPredTyDescription sty
+ ForAllTy _ ty -> getTyDescription ty
+ }
+ where
+ fun_result (FunTy _ res) = '>' : fun_result res
+ fun_result other = getTyDescription other
+
+getPredTyDescription (ClassP cl tys) = getOccString cl
+getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff