- = if not opt_SccProfilingOn then
- returnFC (Nothing, AbsCNop)
- else
- allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
- dataStackSlots [slot] `thenC`
- getSpRelOffset slot `thenFC` \ sp_rel ->
- returnFC (Just slot,
- CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-
-restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
-restoreCurrentCostCentre Nothing = returnFC AbsCNop
-restoreCurrentCostCentre (Just slot)
- = getSpRelOffset slot `thenFC` \ sp_rel ->
- freeStackSlots [slot] `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
- -- we use the RESTORE_CCCS macro, rather than just
- -- assigning into CurCostCentre, in case RESTORE_CCCS
- -- has some sanity-checking in it.
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-return-vec]{Building a return vector}
-%* *
-%************************************************************************
-
-Build a return vector, and return a suitable label addressing
-mode for it.
-
-\begin{code}
-mkReturnVector :: Unique
- -> [(ConTag, AbstractC)] -- Branch codes
- -> AbstractC -- Default case
- -> SRT -- continuation's SRT
- -> Liveness -- stack liveness
- -> CtrlReturnConvention
- -> FCode CAddrMode
-
-mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
- = getSRTLabel `thenFC` \srt_label ->
- let
- (return_vec_amode, vtbl_body) = case ret_conv of {
-
- -- might be a polymorphic case...
- UnvectoredReturn 0 ->
- ASSERT(null tagged_alt_absCs)
- (CLbl ret_label RetRep,
- absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
-
- UnvectoredReturn n ->
- -- find the tag explicitly rather than using tag_reg for now.
- -- on architectures with lots of regs the tag will be loaded
- -- into tag_reg by the code doing the returning.
- let
- tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
- in
- (CLbl ret_label RetRep,
- absC (CRetDirect uniq
- (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
- (srt_label, srt)
- liveness));
-
- VectoredReturn table_size ->
- let
- (vector_table, alts_absC) =
- unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
-
- ret_vector = CRetVector vtbl_label
- vector_table
- (srt_label, srt) liveness
- in
- (CLbl vtbl_label DataPtrRep,
- -- alts come first, because we don't want to declare all the symbols
- absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
- )
-
- } in
- vtbl_body `thenC`
- returnFC return_vec_amode
- -- )
- where
-
- vtbl_label = mkVecTblLabel uniq
- ret_label = mkReturnInfoLabel uniq
-
- deflt_lbl =
- case nonemptyAbsC deflt_absC of
- -- the simplifier might have eliminated a case
- Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
- Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
-
- mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
- mk_vector_entry tag
- = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> (deflt_lbl, AbsCNop)
- [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
- _ -> panic "mkReturnVector: too many"
+ | not opt_SccProfilingOn
+ = returnFC (Nothing, noStmts)
+ | otherwise
+ = do { slot <- allocPrimStack PtrArg
+ ; sp_rel <- getSpRelOffset slot
+ ; returnFC (Just slot,
+ oneStmt (CmmStore sp_rel curCCS)) }
+
+-- Sometimes we don't free the slot containing the cost centre after restoring it
+-- (see CgLetNoEscape.cgLetNoEscapeBody).
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
+restoreCurrentCostCentre Nothing _freeit = nopC
+restoreCurrentCostCentre (Just slot) freeit
+ = do { sp_rel <- getSpRelOffset slot
+ ; whenC freeit (freeStackSlots [slot])
+ ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) }