diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index fbd57ad999d5b73aa3ed80bb499d48f222e4eff0..56a4aebccb7a3c537486ae33cc7ee29ae8944c23 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.25 1999/03/11 11:32:25 simonm Exp $ +% $Id: CgClosure.lhs,v 1.26 1999/03/22 16:58:19 simonm Exp $ % \section[CgClosure]{Code generation for closures} @@ -457,14 +457,16 @@ enterCostCentreCode closure_info ccs is_thunk costCentresC SLIT("ENTER_CCS_FSUB") [] else if isCurrentCCS ccs then - -- get CCC out of the closure, where we put it when we alloc'd - case is_thunk of - IsThunk -> costCentresC SLIT("ENTER_CCS_TCL") [CReg node] - IsFunction -> costCentresC SLIT("ENTER_CCS_FCL") [CReg node] + if re_entrant + then costCentresC SLIT("ENTER_CCS_FCL") [CReg node] + else costCentresC SLIT("ENTER_CCS_TCL") [CReg node] else if isCafCCS ccs && isToplevClosure closure_info then ASSERT(is_thunk == IsThunk) - costCentresC SLIT("ENTER_CCS_CAF") c_ccs + -- might be a PAP, in which case we want to subsume costs + if re_entrant + then costCentresC SLIT("ENTER_CCS_FSUB") [] + else costCentresC SLIT("ENTER_CCS_CAF") c_ccs else -- we've got a "real" cost centre right here in our hands... case is_thunk of @@ -474,6 +476,7 @@ enterCostCentreCode closure_info ccs is_thunk else costCentresC SLIT("ENTER_CCS_FLOAD") c_ccs where c_ccs = [mkCCostCentreStack ccs] + re_entrant = closureReEntrant closure_info \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 7a6ff6f074ca6f8cec5a0b35b169514a233618e4..c81bafbb1a0d4f52470238749aaa8c6b5bb02c5c 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.35 1999/03/11 11:32:27 simonm Exp $ +% $Id: ClosureInfo.lhs,v 1.36 1999/03/22 16:58:20 simonm Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -39,7 +39,7 @@ module ClosureInfo ( closureLabelFromCI, entryLabelFromCI, closureLFInfo, closureSMRep, closureUpdReqd, - closureSingleEntry, closureSemiTag, + closureSingleEntry, closureReEntrant, closureSemiTag, isStandardFormThunk, GenStgArg, @@ -891,7 +891,6 @@ closureLFInfo :: ClosureInfo -> LambdaFormInfo closureLFInfo (MkClosureInfo _ lf_info _) = lf_info closureUpdReqd :: ClosureInfo -> Bool - closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True -- Black-hole closures are allocated to receive the results of an @@ -899,14 +898,16 @@ closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True closureUpdReqd other_closure = False closureSingleEntry :: ClosureInfo -> Bool - closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd closureSingleEntry other_closure = False + +closureReEntrant :: ClosureInfo -> Bool +closureReEntrant (MkClosureInfo _ (LFReEntrant _ _ _ _ _ _) _) = True +closureReEntrant other_closure = False \end{code} \begin{code} closureSemiTag :: ClosureInfo -> Maybe Int - closureSemiTag (MkClosureInfo _ lf_info _) = case lf_info of LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)