X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=58408813308cc01d6777ac1ec393d34b593361fe;hb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;hp=9e99002671dedf2c618d6e58b5411fb12224d2be;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 9e99002..5840881 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (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} @@ -23,9 +23,9 @@ module ClosureInfo ( closureGoodStuffSize, closurePtrsSize, slopSize, - layOutDynClosure, layOutDynCon, layOutStaticClosure, - layOutStaticNoFVClosure, - mkVirtHeapOffsets, + layOutDynClosure, layOutDynConstr, layOutStaticClosure, + layOutStaticNoFVClosure, layOutStaticConstr, + mkVirtHeapOffsets, mkStaticClosure, nodeMustPointToIt, getEntryConvention, FCode, CgInfoDownwards, CgState, @@ -36,10 +36,10 @@ module ClosureInfo ( slowFunEntryCodeRequired, funInfoTableRequired, closureName, infoTableLabelFromCI, fastLabelFromCI, - closureLabelFromCI, + closureLabelFromCI, closureSRT, entryLabelFromCI, closureLFInfo, closureSMRep, closureUpdReqd, - closureSingleEntry, closureSemiTag, + closureSingleEntry, closureReEntrant, closureSemiTag, isStandardFormThunk, GenStgArg, @@ -48,23 +48,26 @@ module ClosureInfo ( 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, @@ -72,38 +75,43 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, 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} @@ -147,9 +155,9 @@ data LambdaFormInfo 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 @@ -200,7 +208,7 @@ mkClosureLFInfo :: Id -- The binder -> [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 [] @@ -223,31 +231,28 @@ mkConLFInfo :: DataCon -> LambdaFormInfo 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} %************************************************************************ @@ -258,32 +263,36 @@ mkLFImported id \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 @@ -315,22 +324,17 @@ Static closures have an extra ``static link field'' at the end, but we 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} @@ -347,29 +351,35 @@ layOutDynClosure, layOutStaticClosure -> (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} %************************************************************************ @@ -385,26 +395,70 @@ Static closures for functions are laid out using 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} %************************************************************************ @@ -421,25 +475,45 @@ chooseDynSMRep 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} %************************************************************************ @@ -453,8 +527,8 @@ smaller offsets than the unboxed things, and furthermore, the offsets in 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 @@ -465,7 +539,7 @@ mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager -- 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 @@ -493,7 +567,7 @@ 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 - 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 @@ -532,9 +606,9 @@ nodeMustPointToIt lf_info -> 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 @@ -602,7 +676,7 @@ getEntryConvention name lf_info arg_kinds 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 @@ -628,21 +702,24 @@ getEntryConvention name lf_info arg_kinds 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 @@ -658,37 +735,63 @@ blackHoleOnEntry :: ClosureInfo -> Bool -- 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 @@ -758,13 +861,11 @@ staticClosureRequired -> 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 @@ -773,27 +874,20 @@ slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk. -> 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} @@ -807,35 +901,27 @@ funInfoTableRequired other_binder_info binder other_lf_info = True \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 @@ -845,37 +931,30 @@ closureSemiTag (MkClosureInfo _ lf_info _) \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 @@ -889,29 +968,20 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep) 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 @@ -930,24 +1000,36 @@ thunkEntryLabel thunk_id _ is_updatable \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} %************************************************************************ @@ -967,11 +1049,10 @@ in the closure info using @closureTypeDescr@. \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} -