diff options
Diffstat (limited to 'ghc/compiler/codeGen')
| -rw-r--r-- | ghc/compiler/codeGen/CgClosure.lhs | 85 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/ClosureInfo.lhs | 61 |
2 files changed, 88 insertions, 58 deletions
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 0348f8f282..86f90af8ca 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.28 1999/04/23 09:51:24 simonm Exp $ +% $Id: CgClosure.lhs,v 1.29 1999/05/11 16:44:02 keithw Exp $ % \section[CgClosure]{Code generation for closures} @@ -44,7 +44,7 @@ import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel, mkRednCountsLabel, mkStdEntryLabel ) import ClosureInfo -- lots and lots of stuff -import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn ) +import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) import CostCentre import Id ( Id, idName, idType, idPrimRep ) import Name ( Name ) @@ -56,6 +56,9 @@ import Util ( isIn ) import CmdLineOpts ( opt_SccProfilingOn ) import Outputable +import Name ( nameOccName ) +import OccName ( occNameFS ) + getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -600,7 +603,8 @@ funWrapper closure_info arg_regs stk_tags slow_label fun_body \begin{code} -blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for thunks +blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args + blackHoleIt closure_info node_points = if blackHoleOnEntry closure_info && node_points then @@ -613,42 +617,59 @@ blackHoleIt closure_info node_points \end{code} \begin{code} -setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks +setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args -- Nota Bene: this function does not change Node (even if it's a CAF), -- so that the cost centre in the original closure can still be -- extracted by a subsequent ENTER_CC_TCL +-- I've tidied up the code for this function, but it should still do the same as +-- it did before (modulo ticky stuff). KSW 1999-04. setupUpdate closure_info code - = if (closureUpdReqd closure_info) then - link_caf_if_needed `thenFC` \ update_closure -> - pushUpdateFrame update_closure code + = if closureReEntrant closure_info + then + code else - profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` - code + case (closureUpdReqd closure_info, isStaticClosure closure_info) of + (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + code + (False,True ) -> (if opt_DoTickyProfiling + then + -- blackhole the SE CAF + link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC + else + nopC) `thenC` + profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [CString cl_name] `thenC` + profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC` + code + (True ,False) -> pushUpdateFrame (CReg node) code + (True ,True ) -> -- blackhole the (updatable) CAF: + link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure -> + profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [CString cl_name] `thenC` + pushUpdateFrame update_closure code where - link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated - link_caf_if_needed - = if not (isStaticClosure closure_info) then - returnFC (CReg node) - else - - -- First we must allocate a black hole, and link the - -- CAF onto the CAF list - - -- Alloc black hole specifying CC_HDR(Node) as the cost centre - -- Hack Warning: Using a CLitLit to get CAddrMode ! - let - use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep - blame_cc = use_cc - in - allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc [] - `thenFC` \ heap_offset -> - getHpRelOffset heap_offset `thenFC` \ hp_rel -> - let amode = CAddr hp_rel - in - absC (CMacroStmt UPD_CAF [CReg node, amode]) - `thenC` - returnFC amode + cl_name :: FAST_STRING + cl_name = (occNameFS . nameOccName . closureName) closure_info + + link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info + -> FCode CAddrMode -- Returns amode for closure to be updated + link_caf bhCI + = -- To update a CAF we must allocate a black hole, link the CAF onto the + -- CAF list, then update the CAF to point to the fresh black hole. + -- This function returns the address of the black hole, so it can be + -- updated with the new value when available. + + -- Alloc black hole specifying CC_HDR(Node) as the cost centre + -- Hack Warning: Using a CLitLit to get CAddrMode ! + let + use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep + blame_cc = use_cc + in + allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset -> + getHpRelOffset heap_offset `thenFC` \ hp_rel -> + let amode = CAddr hp_rel + in + absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC` + returnFC amode \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index c81bafbb1a..986bfd29ee 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.36 1999/03/22 16:58:20 simonm Exp $ +% $Id: ClosureInfo.lhs,v 1.37 1999/05/11 16:44:02 keithw Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -48,7 +48,7 @@ module ClosureInfo ( isStaticClosure, allocProfilingMsg, - blackHoleClosureInfo, + cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, maybeSelectorInfo, infoTblNeedsSRT, @@ -68,7 +68,8 @@ import CgRetConv ( assignRegs ) import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkInfoTableLabel, mkConInfoTableLabel, mkStaticClosureLabel, - mkBlackHoleInfoTableLabel, + mkCAFBlackHoleInfoTableLabel, + mkSECAFBlackHoleInfoTableLabel, mkStaticInfoTableLabel, mkStaticConEntryLabel, mkConEntryLabel, mkClosureLabel, mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -76,7 +77,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkReturnPtLabel ) import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, - opt_Parallel ) + opt_Parallel, opt_DoTickyProfiling ) import Id ( Id, idType, getIdArity ) import DataCon ( DataCon, dataConTag, fIRST_TAG, isNullaryDataCon, isTupleCon, dataConName @@ -155,9 +156,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 @@ -252,7 +253,6 @@ Miscellaneous LF-infos. \begin{code} mkLFArgument = LFArgument -mkLFBlackHole = LFBlackHole mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo @@ -582,9 +582,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 @@ -678,15 +678,15 @@ 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 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)) @@ -717,7 +717,10 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _) 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 @@ -892,7 +895,7 @@ closureLFInfo (MkClosureInfo _ lf_info _) = lf_info closureUpdReqd :: ClosureInfo -> Bool closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd -closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True +closureUpdReqd (MkClosureInfo _ (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 @@ -945,10 +948,10 @@ fastLabelFromCI (MkClosureInfo name _ _) infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI (MkClosureInfo id lf_info 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 @@ -1010,17 +1013,23 @@ allocProfilingMsg (MkClosureInfo _ lf_info _) 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") + 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" \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 (MkClosureInfo name _ _) + = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep + +seCafBlackHoleClosureInfo (MkClosureInfo name _ _) + = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep \end{code} %************************************************************************ |