%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.32 1998/12/18 17:40:54 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.52 2002/04/29 14:03:43 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
closureGoodStuffSize, closurePtrsSize,
slopSize,
- layOutDynClosure, layOutDynCon, layOutStaticClosure,
- layOutStaticNoFVClosure,
- mkVirtHeapOffsets,
+ layOutDynClosure, layOutDynConstr, layOutStaticClosure,
+ layOutStaticNoFVClosure, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosure,
nodeMustPointToIt, getEntryConvention,
FCode, CgInfoDownwards, CgState,
slowFunEntryCodeRequired, funInfoTableRequired,
closureName, infoTableLabelFromCI, fastLabelFromCI,
- closureLabelFromCI,
+ closureLabelFromCI, closureSRT,
entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
- closureSingleEntry, closureSemiTag,
+ closureSingleEntry, closureReEntrant, closureSemiTag,
isStandardFormThunk,
GenStgArg,
isStaticClosure,
allocProfilingMsg,
- blackHoleClosureInfo,
+ cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
maybeSelectorInfo,
- needsSRT
+
+ staticClosureNeedsLink,
) where
#include "HsVersions.h"
-import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset )
+import AbsCSyn
import StgSyn
import CgMonad
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
+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, mkStaticClosureLabel,
- mkBlackHoleInfoTableLabel,
+ mkConInfoTableLabel,
+ mkCAFBlackHoleInfoTableLabel,
+ mkSECAFBlackHoleInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel,
mkSelectorInfoLabel, mkSelectorEntryLabel,
mkReturnPtLabel
)
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
- opt_Parallel )
-import Id ( Id, idType, getIdArity )
-import DataCon ( DataCon, dataConTag, fIRST_TAG,
- isNullaryDataCon, isTupleCon, dataConName
+ opt_Parallel, opt_DoTickyProfiling,
+ opt_SMP )
+import Id ( Id, idType, idArity )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
+ isNullaryDataCon, dataConName
)
-import IdInfo ( ArityInfo(..) )
-import Name ( Name, isExternallyVisibleName, nameUnique )
+import TyCon ( isBoxedTupleTyCon )
+import Name ( Name, nameUnique, getOccName )
+import OccName ( occNameUserString )
import PprType ( getTyDescription )
import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
import SMRep -- all of it
import Type ( isUnLiftedType, Type )
-import BasicTypes ( TopLevelFlag(..) )
-import Util ( mapAccumL )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
+import Util ( mapAccumL, listLengthCmp, lengthIs )
+import FastString
import Outputable
\end{code}
-The ``wrapper'' data type for closure information:
-
-\begin{code}
-data ClosureInfo
- = MkClosureInfo
- Name -- The thing bound to this closure
- LambdaFormInfo -- info derivable from the *source*
- SMRep -- representation used by storage manager
-\end{code}
-
%************************************************************************
%* *
\subsection[ClosureInfo-datatypes]{Data types for closure information}
%* *
%************************************************************************
+The ``wrapper'' data type for closure information:
+
+\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
+ }
+\end{code}
+
%************************************************************************
%* *
\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
Int -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-
-- of a CAF. We want the target of the update frame to
-- be in the heap, so we make a black hole to hold it.
+ CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
data StandardFormInfo -- Tells whether this thunk has one of a small number
-> [Id] -- Args
-> LambdaFormInfo
-mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
+mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
= LFReEntrant (idType bndr) top (length args) (null fvs)
mkClosureLFInfo bndr top fvs ReEntrant []
mkConLFInfo con
= -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
- (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon 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)
mkApLFInfo rhs_ty upd_flag arity
- = LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag)
- (ApThunk arity)
+ = LFThunk rhs_ty NotTopLevel (arity == 0)
+ (isUpdatable upd_flag) (ApThunk arity)
\end{code}
Miscellaneous LF-infos.
\begin{code}
mkLFArgument = LFArgument
-mkLFBlackHole = LFBlackHole
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
- = case getIdArity id of
- ArityExactly 0 -> LFThunk (idType id)
- TopLevel True{-no fvs-}
- True{-updatable-} NonStandardThunk
- ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0
- other -> LFImported -- Not sure of exact arity
+ = case idArity id of
+ n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0
+ other -> LFImported -- Not sure of exact arity
\end{code}
%************************************************************************
\begin{code}
closureSize :: ClosureInfo -> HeapOffset
-closureSize cl_info@(MkClosureInfo _ _ sm_rep)
- = fixedHdrSize + closureNonHdrSize cl_info
+closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
closureNonHdrSize :: ClosureInfo -> Int
-closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info)
- --ToDo: pass lf_info?
+closureNonHdrSize cl_info
+ = tot_wds + computeSlopSize tot_wds
+ (closureSMRep cl_info)
+ (closureUpdReqd cl_info)
where
tot_wds = closureGoodStuffSize cl_info
+slopSize :: ClosureInfo -> Int
+slopSize cl_info
+ = computeSlopSize (closureGoodStuffSize cl_info)
+ (closureSMRep cl_info)
+ (closureUpdReqd cl_info)
+
closureGoodStuffSize :: ClosureInfo -> Int
-closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
- = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
+closureGoodStuffSize cl_info
+ = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs + nonptrs
closurePtrsSize :: ClosureInfo -> Int
-closurePtrsSize (MkClosureInfo _ _ sm_rep)
- = let (ptrs, _) = sizes_from_SMRep sm_rep
+closurePtrsSize cl_info
+ = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs
-- not exported:
sizes_from_SMRep :: SMRep -> (Int,Int)
-sizes_from_SMRep (GenericRep ptrs nonptrs _) = (ptrs, nonptrs)
-sizes_from_SMRep (StaticRep ptrs nonptrs _) = (ptrs, nonptrs)
-sizes_from_SMRep ConstantRep = (0, 0)
-sizes_from_SMRep BlackHoleRep = (0, 0)
+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
don't bother taking that into account here.
\begin{code}
-slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = computeSlopSize (closureGoodStuffSize cl_info) sm_rep
- (closureUpdReqd cl_info)
-
computeSlopSize :: Int -> SMRep -> Bool -> Int
-computeSlopSize tot_wds (StaticRep _ _ _) True -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds (StaticRep _ _ _) False
- = 0 -- non updatable, non-heap object
-computeSlopSize tot_wds (GenericRep _ _ _) True -- Updatable
+computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds (GenericRep _ _ _) False
- = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)
-computeSlopSize tot_wds ConstantRep _
- = 0
+
+computeSlopSize tot_wds (GenericRep True _ _ _) False -- Non updatable
+ = 0 -- Static
+
+computeSlopSize tot_wds (GenericRep False _ _ _) False -- Non updatable
+ = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) -- Dynamic
+
computeSlopSize tot_wds BlackHoleRep _ -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
\end{code}
-> (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
- = (MkClosureInfo name lf_info sm_rep,
+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 sm_rep kind_fn things
+ things_w_offsets) = mkVirtHeapOffsets kind_fn things
sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
\end{code}
-A wrapper for when used with data constructors:
+Wrappers for when used with data constructors:
\begin{code}
-layOutDynCon :: DataCon
- -> (a -> PrimRep)
- -> [a]
- -> (ClosureInfo, [(a,VirtualHeapOffset)])
+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
-layOutDynCon con kind_fn args
- = layOutDynClosure (dataConName con) kind_fn args (mkConLFInfo con)
+layOutStaticConstr name data_con kind_fn things
+ = layOutStaticClosure name kind_fn things (mkConLFInfo data_con) NoC_SRT
\end{code}
%************************************************************************
layOutStaticNoFVClosure.
\begin{code}
-layOutStaticClosure name kind_fn things lf_info
- = (MkClosureInfo name lf_info
- (StaticRep ptr_wds (tot_wds - ptr_wds) closure_type),
+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 (StaticRep bot bot bot) kind_fn things
+ 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 = case lf_info of
- LFCon _ _ | ptr_wds == 0 -> CONSTR_NOCAF
- _ -> getClosureType lf_info
-
- bot = panic "layoutStaticClosure"
+ closure_type = getClosureType is_static tot_wds ptr_wds lf_info
+ is_static = True
-layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo
-layOutStaticNoFVClosure name lf_info
- = MkClosureInfo name lf_info (StaticRep 0 0 (getClosureType lf_info))
+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
+
+
+-- make a static closure, adding on any extra padding needed for CAFs,
+-- and adding a static link field if necessary.
+
+mkStaticClosure closure_info ccs fields cafrefs
+ | opt_SccProfilingOn =
+ CStaticClosure
+ closure_info
+ (mkCCostCentreStack ccs)
+ all_fields
+ | otherwise =
+ CStaticClosure
+ closure_info
+ (panic "absent cc")
+ all_fields
+
+ where
+ all_fields = fields ++ padding_wds ++ static_link_field
+
+ upd_reqd = closureUpdReqd closure_info
+
+ padding_wds
+ | not upd_reqd = []
+ | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
+ where n = max 0 (mIN_UPD_SIZE - length fields)
+
+ -- We always have a static link field for a thunk, it's used to
+ -- save the closure's info pointer when we're reverting CAFs
+ -- (see comment in Storage.c)
+ static_link_field
+ | upd_reqd || staticClosureNeedsLink closure_info = [static_link_value]
+ | otherwise = []
+
+ -- for a static constructor which has NoCafRefs, we set the
+ -- static link field to a non-zero value so the garbage
+ -- collector will ignore it.
+ static_link_value
+ | cafrefs = mkIntCLit 0
+ | otherwise = mkIntCLit 1
\end{code}
%************************************************************************
chooseDynSMRep lf_info tot_wds ptr_wds
= let
- nonptr_wds = tot_wds - ptr_wds
- closure_type = getClosureType lf_info
+ is_static = False
+ nonptr_wds = tot_wds - ptr_wds
+ closure_type = getClosureType is_static tot_wds ptr_wds lf_info
in
- case lf_info of
- LFTuple _ True -> ConstantRep
- LFCon _ True -> ConstantRep
- _ -> GenericRep ptr_wds nonptr_wds closure_type
+ GenericRep is_static ptr_wds nonptr_wds closure_type
+
+-- 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
+ = 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
-getClosureType :: LambdaFormInfo -> ClosureType
-getClosureType lf_info =
- case lf_info of
- LFCon con True -> CONSTR_NOCAF
- LFCon con False -> CONSTR
- LFReEntrant _ _ _ _ -> FUN
- LFTuple _ _ -> CONSTR
LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
- LFThunk _ _ _ _ _ -> THUNK
- _ -> panic "getClosureType"
- -- ToDo: could be anything else here?
+
+ LFThunk _ _ _ _ _
+ | specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n
+ | otherwise -> THUNK
+
+ _ -> panic "getClosureType"
+ where
+ specialised_rep max_size = not is_static
+ && tot_wds > 0
+ && tot_wds <= max_size
\end{code}
%************************************************************************
the result list
\begin{code}
-mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
- -> (a -> PrimRep) -- To be able to grab kinds;
+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
-- First in list gets lowest offset, which is initial offset + 1.
-mkVirtHeapOffsets sm_rep kind_fun things
+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
= 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
- case top of { TopLevel -> False; _ -> True }
+ 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
-> returnFC True
-- Node must point to any standard-form thunk.
- LFArgument -> returnFC True
- LFImported -> returnFC True
- LFBlackHole -> returnFC True
+ LFArgument -> returnFC True
+ LFImported -> returnFC True
+ LFBlackHole _ -> returnFC True
-- BH entry may require Node to point
LFLetNoEscape _ -> returnFC False
case lf_info of
LFReEntrant _ _ arity _ ->
- if arity == 0 || (length arg_kinds) < arity then
+ if arity == 0 || (listLengthCmp arg_kinds arity == LT) then
StdEntry (mkStdEntryLabel name)
else
DirectEntry (mkFastEntryLabel name arity) arity arg_regs
StdEntry (mkConEntryLabel (dataConName tup))
LFThunk _ _ _ updatable std_form_info
- -> if updatable
+ -> if 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)
+ 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
+ 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
- -> ASSERT(arity == length arg_kinds)
+ -> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
where
(arg_regs, _) = assignRegs [] arg_kinds
-- Single-entry ones have no fvs to plug, and we trust they don't form part
-- of a loop.
-blackHoleOnEntry (MkClosureInfo _ _ (StaticRep _ _ _)) = False
+blackHoleOnEntry cl_info
+ | isStaticRep (closureSMRep cl_info)
+ = False -- Never black-hole a static closure
-blackHoleOnEntry (MkClosureInfo _ lf_info _)
- = case lf_info of
+ | otherwise
+ = case closureLFInfo cl_info of
LFReEntrant _ _ _ _ -> False
LFLetNoEscape _ -> False
LFThunk _ _ no_fvs updatable _
-> if updatable
then not opt_OmitBlackHoling
- else not no_fvs
+ else opt_DoTickyProfiling || not no_fvs
+ -- the former to catch double entry,
+ -- and the latter to plug space-leaks. KSW/SDM 1999-04.
+
other -> panic "blackHoleOnEntry" -- Should never happen
isStandardFormThunk :: LambdaFormInfo -> Bool
isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True
-isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True
+isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True
isStandardFormThunk other_lf_info = False
-maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _
- (SelectorThunk offset)) _) = Just offset
+maybeSelectorInfo (MkClosureInfo { closureLFInfo = LFThunk _ _ _ _ (SelectorThunk offset) })
+ = Just offset
maybeSelectorInfo _ = Nothing
+\end{code}
--- Does this thunk's info table have an SRT?
+-----------------------------------------------------------------------------
+SRT-related stuff
-needsSRT :: ClosureInfo -> Bool
-needsSRT (MkClosureInfo _ info _) =
- case info of
- LFThunk _ _ _ _ (SelectorThunk _) -> False -- not for selectors
- LFThunk _ _ _ _ _ -> True
- LFReEntrant _ _ _ _ -> True
- _ -> False
+\begin{code}
+staticClosureNeedsLink :: ClosureInfo -> Bool
+-- 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 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 = lf_info,
+ closureSMRep = sm_rep })
+ = needsSRT srt || (constr_with_fields && not_nocaf_constr)
+ where
+ not_nocaf_constr =
+ case sm_rep of
+ GenericRep _ _ _ CONSTR_NOCAF -> False
+ _other -> True
+
+ constr_with_fields =
+ case lf_info of
+ LFThunk _ _ _ _ _ -> False
+ LFReEntrant _ _ _ _ -> False
+ LFCon _ is_nullary -> not is_nullary
+ LFTuple _ is_nullary -> not is_nullary
+ _other -> pprPanic "staticClosureNeedsLink" (ppr name)
\end{code}
Avoiding generating entries and info tables
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+staticClosureRequired binder bndr_info
(LFReEntrant _ top_level _ _) -- It's a function
- = ASSERT( case top_level of { TopLevel -> True; other -> False } )
+ = ASSERT( isTopLevel top_level )
-- Assumption: it's a top-level, no-free-var binding
- arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || isExternallyVisibleName binder
+ not (satCallsOnly bndr_info)
staticClosureRequired binder other_binder_info other_lf_info = True
-> StgBinderInfo
-> EntryConvention
-> Bool
-slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv
- = arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || isExternallyVisibleName binder
+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 -}
-slowFunEntryCodeRequired binder NoStgBinderInfo _ = True
-
funInfoTableRequired
:: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant _ top_level _ _)
- = (case top_level of { NotTopLevel -> True; TopLevel -> False })
- || arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || isExternallyVisibleName binder
+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}
\begin{code}
isStaticClosure :: ClosureInfo -> Bool
-isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
-
-closureName :: ClosureInfo -> Name
-closureName (MkClosureInfo name _ _) = name
-
-closureSMRep :: ClosureInfo -> SMRep
-closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
-
-closureLFInfo :: ClosureInfo -> LambdaFormInfo
-closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
-
-closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = upd
-closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True
+closureUpdReqd (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = upd
+closureUpdReqd (MkClosureInfo { 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
+closureUpdReqd other_closure = False
closureSingleEntry :: ClosureInfo -> Bool
+closureSingleEntry (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = not upd
+closureSingleEntry other_closure = False
-closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = not upd
-closureSingleEntry other_closure = False
+closureReEntrant :: ClosureInfo -> Bool
+closureReEntrant (MkClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+closureReEntrant other_closure = False
\end{code}
\begin{code}
closureSemiTag :: ClosureInfo -> Maybe Int
-
-closureSemiTag (MkClosureInfo _ lf_info _)
+closureSemiTag (MkClosureInfo { closureLFInfo = lf_info })
= case lf_info of
LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
LFTuple _ _ -> Just 0
\begin{code}
isToplevClosure :: ClosureInfo -> Bool
-isToplevClosure (MkClosureInfo _ lf_info _)
+isToplevClosure (MkClosureInfo { closureLFInfo = lf_info })
= case lf_info of
LFReEntrant _ TopLevel _ _ -> True
LFThunk _ TopLevel _ _ _ -> True
other -> False
\end{code}
-\begin{code}
-isLetNoEscape :: ClosureInfo -> Bool
-
-isLetNoEscape (MkClosureInfo _ (LFLetNoEscape _) _) = True
-isLetNoEscape _ = False
-\end{code}
-
Label generation.
\begin{code}
fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _)
+fastLabelFromCI (MkClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ _ arity _ })
= mkFastEntryLabel name arity
-fastLabelFromCI (MkClosureInfo name _ _)
- = pprPanic "fastLabelFromCI" (ppr name)
+fastLabelFromCI cl_info
+ = pprPanic "fastLabelFromCI" (ppr (closureName cl_info))
infoTableLabelFromCI :: ClosureInfo -> CLabel
-infoTableLabelFromCI (MkClosureInfo id lf_info rep)
+infoTableLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
= case lf_info of
- LFCon con _ -> mkConInfoPtr con rep
- LFTuple tup _ -> mkConInfoPtr tup rep
+ LFCon con _ -> mkConInfoPtr con rep
+ LFTuple tup _ -> mkConInfoPtr tup rep
- LFBlackHole -> mkBlackHoleInfoTableLabel
+ LFBlackHole info -> info
LFThunk _ _ _ upd_flag (SelectorThunk offset) ->
mkSelectorInfoLabel upd_flag offset
mkConInfoPtr :: DataCon -> SMRep -> CLabel
mkConInfoPtr con rep
- = case rep of
- StaticRep _ _ _ -> mkStaticInfoTableLabel name
- _ -> mkConInfoTableLabel name
+ | isStaticRep rep = mkStaticInfoTableLabel name
+ | otherwise = mkConInfoTableLabel name
where
name = dataConName con
mkConEntryPtr :: DataCon -> SMRep -> CLabel
mkConEntryPtr con rep
- = case rep of
- StaticRep _ _ _ -> mkStaticConEntryLabel (dataConName con)
- _ -> mkConEntryLabel (dataConName con)
- where
- name = dataConName con
-
-closureLabelFromCI (MkClosureInfo name _ rep)
- | isConstantRep rep
- = mkStaticClosureLabel name
- -- This case catches those pesky static closures for nullary constructors
+ | isStaticRep rep = mkStaticConEntryLabel (dataConName con)
+ | otherwise = mkConEntryLabel (dataConName con)
-closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
+closureLabelFromCI cl_info = mkClosureLabel (closureName cl_info)
entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (MkClosureInfo id lf_info rep)
+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
\end{code}
\begin{code}
-allocProfilingMsg :: ClosureInfo -> FAST_STRING
-
-allocProfilingMsg (MkClosureInfo _ lf_info _)
- = case lf_info of
- LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
- LFCon _ _ -> SLIT("TICK_ALLOC_CON")
- LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
- LFThunk _ _ _ _ _ -> SLIT("TICK_ALLOC_THK")
- LFBlackHole -> SLIT("TICK_ALLOC_BH")
- LFImported -> panic "TICK_ALLOC_IMP"
+allocProfilingMsg :: ClosureInfo -> FastString
+
+allocProfilingMsg cl_info
+ = case closureLFInfo cl_info of
+ LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN")
+ LFCon _ _ -> FSLIT("TICK_ALLOC_CON")
+ LFTuple _ _ -> FSLIT("TICK_ALLOC_CON")
+ LFThunk _ _ _ True _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable
+ LFThunk _ _ _ False _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable
+ LFBlackHole _ -> FSLIT("TICK_ALLOC_BH")
+ LFImported -> panic "TICK_ALLOC_IMP"
\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.
+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}
-blackHoleClosureInfo (MkClosureInfo name _ _)
- = MkClosureInfo name LFBlackHole BlackHoleRep
+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 }
\end{code}
%************************************************************************
\begin{code}
closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _) _)
- = getTyDescription ty
-closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _) _)
- = getTyDescription ty
-closureTypeDescr (MkClosureInfo name lf _)
- = showSDoc (ppr name)
+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))
\end{code}
-
projects / ghc-hetmet.git / blobdiff