- = let
- doing_profiling = opt_SccProfilingOn
- in
- if not doing_profiling then
- returnFC (Nothing, AbsCNop)
- else
- allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (Just b_slot,
- CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
-
-restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
-
-restoreCurrentCostCentre Nothing
- = returnFC AbsCNop
-restoreCurrentCostCentre (Just b_slot)
- = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- freeBStkSlot b_slot `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
- -- we use the RESTORE_CCC macro, rather than just
- -- assigning into CurCostCentre, in case RESTORE_CCC
- -- 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
- -> Type
- -> [(ConTag, AbstractC)] -- Branch codes
- -> AbstractC -- Default case
- -> FCode CAddrMode
-
-mkReturnVector uniq ty tagged_alt_absCs deflt_absC
- = let
- (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
-
- UnvectoredReturn _ ->
- (CUnVecLbl ret_label vtbl_label,
- absC (CRetUnVector vtbl_label
- (CLabelledCode ret_label
- (mkAlgAltsCSwitch (CReg TagReg)
- tagged_alt_absCs
- deflt_absC))));
- VectoredReturn table_size ->
- (CLbl vtbl_label DataPtrRep,
- absC (CRetVector vtbl_label
- -- must restore cc before each alt, if required
- (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
- deflt_absC))
-
--- Leave nops and comments in for now; they are eliminated
--- lazily as it's printed.
--- (case (nonemptyAbsC deflt_absC) of
--- Nothing -> AbsCNop
--- Just def -> def)
-
- } in
- vtbl_body `thenC`
- returnFC return_vec_amode
- -- )
- where
-
- (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
- Just xx -> xx
- Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty)
-
- vtbl_label = mkVecTblLabel uniq
- ret_label = mkReturnPtLabel uniq
-
- mk_vector_entry :: ConTag -> Maybe CAddrMode
- mk_vector_entry tag
- = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> Nothing
- [absC] -> Just (CCode absC)
- _ -> panic "mkReturnVector: too many"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-utils]{Utilities for handling case expressions}
-%* *
-%************************************************************************
-
-@possibleHeapCheck@ tests a flag passed in to decide whether to
-do a heap check or not.
-
-\begin{code}
-possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
-
-possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
-possibleHeapCheck NoGC _ _ code = code
+ | 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)) }