Crude allocation-counting extension to ticky-ticky profiling.
Allocations are counted against the closest lexically enclosing
function closure, so you need to map the output back to the STG code.
= flatAbsC code `thenFlt` \ (code_here, code_tops) ->
returnFlt (CCheck macro amodes code_here, code_tops)
+-- the TICKY_CTR macro always needs to be hoisted out to the top level.
+-- This is a HACK.
+flatAbsC stmt@(CCallProfCtrMacro str amodes)
+ | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
+ | otherwise = returnFlt (stmt, AbsCNop)
+
-- Some statements need no flattening at all:
flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CCallProfCtrMacro str amodes) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.27 1999/05/13 17:30:52 simonm Exp $
+% $Id: CLabel.lhs,v 1.28 1999/10/13 16:39:10 simonmar Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
mkErrorStdEntryLabel,
mkUpdInfoLabel,
+ mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel,
mkSECAFBlackHoleInfoTableLabel,
mkRtsPrimOpLabel,
| RtsPrimOp PrimOp
+ | RtsTopTickyCtr
+
deriving (Eq, Ord)
-- Label Type: for generating C declarations.
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
mkUpdInfoLabel = RtsLabel RtsUpdInfo
+mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("Upd_frame_info")
+pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
+
pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
pp_liveness :: Liveness -> SDoc
pp_liveness lv =
case lv of
- LvSmall mask -> int (intBS mask)
LvLarge lbl -> char '&' <> pprCLabel lbl
+ LvSmall mask
+ | bitmap_int == (minBound :: Int) -> int (bitmap_int+1) <> text "-1"
+ | otherwise -> int bitmap_int
+ where
+ bitmap_int = intBS mask
\end{code}
%************************************************************************
= MkCgState absC (modifyVarEnv mangle_fn binds name) usage
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _)
+lookupBindC name info_down@(MkCgInfoDown _ static_binds srt ticky _)
state@(MkCgState absC local_binds usage)
= (val, state)
where
-> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
-cgPanic doc info_down@(MkCgInfoDown _ static_binds srt _)
+cgPanic doc info_down@(MkCgInfoDown _ static_binds srt ticky _)
state@(MkCgState absC local_binds usage)
= pprPanic "cgPanic"
(vcat [doc,
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.34 1999/06/28 16:29:45 simonpj Exp $
+% $Id: CgCase.lhs,v 1.35 1999/10/13 16:39:14 simonmar Exp $
%
%********************************************************
%* *
tyConDataCons, tyConFamilySize )
import Type ( Type, typePrimRep, splitAlgTyConApp,
splitTyConApp_maybe, repType )
-import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
+import Unique ( Unique, Uniquable(..), mkPseudoUnique1 )
import Maybes ( maybeToBool )
import Util
import Outputable
alternatives (in which case we lookup the tag in the relevant closure
table to get the closure).
+Being a bit short of uniques for temporary variables here, we use
+mkPseudoUnique1 to generate a temporary for the tag. We can't use
+mkBuiltinUnique, because that occasionally clashes with some
+temporaries generated for _ccall_GC, amongst others (see CgExpr.lhs).
+
\begin{code}
cgCase (StgCon (PrimOp op) args res_ty)
live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
let tag_amode = case op of
TagToEnumOp -> only arg_amodes
- _ -> CTemp (mkBuiltinUnique 1) IntRep
+ _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep
closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
in
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.34 1999/07/14 14:40:28 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.35 1999/10/13 16:39:15 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
-- get the current virtual Sp (it might not be zero, eg. if we're
-- compiling a let-no-escape).
getVirtSp `thenFC` \vSp ->
+
let
-- Figure out what is needed and what isn't
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
fast_entry_code
- = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel name) PtrRep,
- mkCString (_PK_ (showSDoc (ppr name))),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit sp_stk_args, -- # passed on stk
- mkCString (_PK_ (map (showTypeCategory . idType) all_args))
- ] `thenC`
+ = profCtrC SLIT("TICK_CTR") [
+ CLbl ticky_ctr_label DataPtrRep,
+ mkCString (_PK_ (showSDocDebug (ppr name))),
+ mkIntCLit stg_arity, -- total # of args
+ mkIntCLit sp_stk_args, -- # passed on stk
+ mkCString (_PK_ (map (showTypeCategory . idType) all_args))
+ ] `thenC`
+
+ profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+ CLbl ticky_ctr_label DataPtrRep
+ ] `thenC`
-- Nuked for now; see comment at end of file
-- CString (_PK_ (show_wrapper_name wrapper_maybe)),
-- Do the business
funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
in
+
+ setTickyCtrLabel ticky_ctr_label (
+
-- Make a labelled code-block for the slow and fast entry code
- forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
+ forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
`thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
- moduleName `thenFC` \ mod_name ->
+ forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
+ moduleName `thenFC` \ mod_name ->
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
-- XXX probably need the info table and slow entry code in case of
-- a heap check failure.
- absC (
- if info_table_needed then
- CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+ absC (
+ if info_table_needed then
+ CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
(cl_descr mod_name)
- else
+ else
CCodeBlock fast_label fast_abs_c
+ )
)
where
+ ticky_ctr_label = mkRednCountsLabel name
+
stg_arity = length all_args
lf_info = closureLFInfo closure_info
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.18 1999/06/24 13:04:19 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.19 1999/10/13 16:39:15 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
let stk_words = spHw - sp in
initHeapUsage (\ hp_words ->
+ getTickyCtrLabel `thenFC` \ ticky_ctr ->
+
( if all_pointers then -- heap checks are quite easy
absC (checking_code stk_words hp_words tag_assts
- free_reg (length regs))
+ free_reg (length regs) ticky_ctr)
else -- they are complicated
absC (checking_code real_stk_words hp_words
(mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
adjust_sp])
- (CReg node) 0)
+ (CReg node) 0 ticky_ctr)
) `thenC`
where
- checking_code stk hp assts ret regs
- | node_points = do_checks_np stk hp assts (regs+1) -- ret not required
- | otherwise = do_checks stk hp assts ret regs
+ checking_code stk hp assts ret regs ctr
+ = mkAbstractCs
+ [ real_check,
+ if hp == 0 then AbsCNop
+ else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit hp, CLbl ctr DataPtrRep ]
+ ]
+
+ where real_check
+ | node_points = do_checks_np stk hp assts (regs+1)
+ | otherwise = do_checks stk hp assts ret regs
-- When node points to the closure for the function:
initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
where
do_heap_chk words_required tag_assts
- = absC (if words_required == 0
- then AbsCNop
- else checking_code tag_assts) `thenC`
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code tag_assts,
+ profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
setRealHp words_required
where
altHeapCheck is_fun regs [] AbsCNop Nothing code
= initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+
where
do_heap_chk :: HeapOffset -> Code
do_heap_chk words_required
- = absC (if words_required == 0
- then AbsCNop
- else checking_code) `thenC`
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code,
+ profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
setRealHp words_required
where
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.22 1999/06/09 14:28:38 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.23 1999/10/13 16:39:16 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
setEndOfBlockInfo, getEndOfBlockInfo,
setSRTLabel, getSRTLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
StackUsage, Slot(..), HeapUsage,
- profCtrC,
+ profCtrC, profCtrAbsC,
costCentresC, moduleName,
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
-import CLabel ( CLabel, mkUpdInfoLabel )
+import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
import Module ( Module )
import DataCon ( ConTag )
import Id ( Id )
CLabel -- label of the current SRT
+ CLabel -- current destination for ticky counts
+
EndOfBlockInfo -- Info for stuff to do at end of basic block:
cg_info
(error "initC: statics")
(error "initC: srt")
+ (mkTopTickyCtrLabel)
initEobInfo)
initialStateC) of
MkCgState abc _ _ -> abc
forkClosureBody :: Code -> Code
forkClosureBody code
- (MkCgInfoDown cg_info statics srt _)
+ (MkCgInfoDown cg_info statics srt ticky _)
(MkCgState absC_in binds un_usage)
= MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
where
fork_state = code body_info_down initialStateC
MkCgState absC_fork _ _ = fork_state
- body_info_down = MkCgInfoDown cg_info statics srt initEobInfo
+ body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
forkStatics :: FCode a -> FCode a
-forkStatics fcode (MkCgInfoDown cg_info _ srt _)
+forkStatics fcode (MkCgInfoDown cg_info _ srt ticky _)
(MkCgState absC_in statics un_usage)
= (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
where
(result, state) = fcode rhs_info_down initialStateC
MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
-- above or it becomes too strict!
- rhs_info_down = MkCgInfoDown cg_info statics srt initEobInfo
+ rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
forkAbsC :: Code -> FCode AbstractC
forkAbsC code info_down (MkCgState absC1 bs usage)
a) -- Result of the FCode
forkEvalHelp body_eob_info env_code body_code
- info_down@(MkCgInfoDown cg_info statics srt _) state
+ info_down@(MkCgInfoDown cg_info statics srt ticky _) state
= ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
where
- info_down_for_body = MkCgInfoDown cg_info statics srt body_eob_info
+ info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
(MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
-- These v and f things are now set up as the body code expects them
then state
else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
+profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
+
+profCtrAbsC macro args
+ = if not opt_DoTickyProfiling
+ then AbsCNop
+ else CCallProfCtrMacro macro args
+
{- Try to avoid adding too many special compilation strategies here.
It's better to modify the header files as necessary for particular
targets, so that we can get away with as few variants of .hc files
\begin{code}
moduleName :: FCode Module
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _) state
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
= (mod_name, state)
\end{code}
\begin{code}
setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt _) state
- = code (MkCgInfoDown c_info statics srt eob_info) state
+setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt ticky _) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo (MkCgInfoDown c_info statics _ eob_info) state
+getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
= (eob_info, state)
\end{code}
\begin{code}
getSRTLabel :: FCode CLabel
-getSRTLabel (MkCgInfoDown _ _ srt _) state
+getSRTLabel (MkCgInfoDown _ _ srt _ _) state
= (srt, state)
setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code (MkCgInfoDown c_info statics _ eob_info) state
- = code (MkCgInfoDown c_info statics srt eob_info) state
+setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
+\end{code}
+
+\begin{code}
+getTickyCtrLabel :: FCode CLabel
+getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
+ = (ticky, state)
+
+setTickyCtrLabel :: CLabel -> Code -> Code
+setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
\end{code}
printSDoc, printErrs, printDump,
printForC, printForAsm, printForIface,
pprCode, pprCols,
- showSDoc, showsPrecSDoc, pprFSAsString,
+ showSDoc, showSDocDebug, showsPrecSDoc, pprFSAsString,
-- error handling
showSDoc :: SDoc -> String
showSDoc d = show (d (mkUserStyle AllTheWay))
+showSDocDebug :: SDoc -> String
+showSDocDebug d = show (d PprDebug)
+
showsPrecSDoc :: Int -> SDoc -> ShowS
showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
$srtchk{$1} = $i;
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_ct$TPOSTLBL[@]?$/o ) {
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'data';
+ $chksymb[$i] = '';
+
} elsif ( /^$TUS[@]?ghc.*c_ID$TPOSTLBL/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'consist';
/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.12 1999/06/25 09:13:38 simonmar Exp $
+ * $Id: StgMacros.h,v 1.13 1999/10/13 16:39:21 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
tag_assts \
(r) = (P_)ret; \
JMP_(stg_chk_##layout); \
- } \
- TICK_ALLOC_HEAP(headroom);
+ }
#define HP_STK_CHK(stk_headroom,hp_headroom,ret,r,layout,tag_assts) \
if (Sp - stk_headroom < SpLim || (Hp += hp_headroom) > HpLim) { \
tag_assts \
(r) = (P_)ret; \
JMP_(stg_chk_##layout); \
- } \
- TICK_ALLOC_HEAP(hp_headroom);
+ }
/* -----------------------------------------------------------------------------
A Heap Check in a case alternative are much simpler: everything is
EXTFUN_RTS(stg_gc_enter_##ptrs); \
tag_assts \
JMP_(stg_gc_enter_##ptrs); \
- } \
- TICK_ALLOC_HEAP(headroom);
+ }
#define HP_CHK_SEQ_NP(headroom,ptrs,tag_assts) \
if ((Hp += (headroom)) > HpLim) { \
EXTFUN_RTS(stg_gc_seq_##ptrs); \
tag_assts \
JMP_(stg_gc_seq_##ptrs); \
- } \
- TICK_ALLOC_HEAP(headroom);
+ }
#define HP_STK_CHK_NP(stk_headroom, hp_headroom, ptrs, tag_assts) \
if ((Sp - (stk_headroom)) < SpLim || (Hp += (hp_headroom)) > HpLim) { \
EXTFUN_RTS(stg_gc_enter_##ptrs); \
tag_assts \
JMP_(stg_gc_enter_##ptrs); \
- } \
- TICK_ALLOC_HEAP(hp_headroom);
+ }
+
/* Heap checks for branches of a primitive case / unboxed tuple return */
EXTFUN_RTS(lbl); \
tag_assts \
JMP_(lbl); \
- } \
- TICK_ALLOC_HEAP(headroom);
+ }
#define HP_CHK_NOREGS(headroom,tag_assts) \
GEN_HP_CHK_ALT(headroom,stg_gc_noregs,tag_assts);
R9.w = (W_)LIVENESS_MASK(liveness); \
R10.w = (W_)reentry; \
JMP_(stg_gen_chk); \
- } \
- TICK_ALLOC_HEAP(headroom);
+ }
+
+#define HP_CHK_GEN_TICKY(headroom,liveness,reentry,tag_assts) \
+ HP_CHK_GEN(headroom,liveness,reentry,tag_assts); \
+ TICK_ALLOC_HEAP_NOCTR(headroom)
#define STK_CHK_GEN(headroom,liveness,reentry,tag_assts) \
if ((Sp - (headroom)) < SpLim) { \
/* ----------------------------------------------------------------------------
- * $Id: StgTicky.h,v 1.6 1999/09/14 12:16:39 simonmar Exp $
+ * $Id: StgTicky.h,v 1.7 1999/10/13 16:39:21 simonmar Exp $
*
* (c) The AQUA project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
* the allocations gives an indication of how many things we get per trip
* to the well:
*/
-#define TICK_ALLOC_HEAP(n) ALLOC_HEAP_ctr++; ALLOC_HEAP_tot += (n)
+#define TICK_ALLOC_HEAP(n, f_ct) \
+ { \
+ f_ct.allocs += (n); \
+ ALLOC_HEAP_ctr++; \
+ ALLOC_HEAP_tot += (n); \
+ }
+
+#define TICK_ALLOC_HEAP_NOCTR(n) \
+ { \
+ ALLOC_HEAP_ctr++; \
+ ALLOC_HEAP_tot += (n); \
+ }
/* We count things every time we allocate something in the dynamic heap.
* For each, we count the number of words of (1) ``admin'' (header),
#define TICK_ENT_THK() ENT_THK_ctr++ /* thunk */
#define TICK_ENT_FUN_STD() ENT_FUN_STD_ctr++ /* std entry pt */
-struct ent_counter {
+typedef struct _StgEntCounter {
unsigned registeredp:16, /* 0 == no, 1 == yes */
arity:16, /* arity (static info) */
stk_args:16; /* # of args off stack */
/* (rest of args are in registers) */
- StgChar *f_str; /* name of the thing */
- StgChar *f_arg_kinds; /* info about the args types */
+ StgChar *str; /* name of the thing */
+ StgChar *arg_kinds; /* info about the args types */
I_ ctr; /* the actual counter */
- struct ent_counter *link; /* link to chain them all together */
-};
+ I_ allocs; /* number of allocations by this fun */
+ struct _StgEntCounter *link;/* link to chain them all together */
+} StgEntCounter;
-#define TICK_ENT_FUN_DIRECT(f_ct, f_str, f_arity, f_args, f_arg_kinds) \
+#define TICK_CTR(f_ct, str, arity, args, arg_kinds) \
+ static StgEntCounter f_ct \
+ = { 0, arity, args, \
+ str, arg_kinds, \
+ 0, 0, NULL };
+
+#define TICK_ENT_FUN_DIRECT(f_ct) \
{ \
- static struct ent_counter f_ct \
- = { 0, \
- (f_arity), (f_args), (f_str), (f_arg_kinds), \
- 0, NULL }; \
- if ( ! f_ct.registeredp ) { \
+ if ( ! f_ct.registeredp ) { \
/* hook this one onto the front of the list */ \
f_ct.link = ticky_entry_ctrs; \
ticky_entry_ctrs = & (f_ct); \
- \
/* mark it as "registered" */ \
f_ct.registeredp = 1; \
- } \
- f_ct.ctr += 1; \
+ } \
+ f_ct.ctr += 1; \
} \
ENT_FUN_DIRECT_ctr++ /* the old boring one */
-extern struct ent_counter *ticky_entry_ctrs;
+extern StgEntCounter top_ct;
+extern StgEntCounter *ticky_entry_ctrs;
#define TICK_ENT_CON(n) ENT_CON_ctr++ /* enter constructor */
#define TICK_ENT_IND(n) ENT_IND_ctr++ /* enter indirection */
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.30 1999/09/15 13:45:18 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.31 1999/10/13 16:39:23 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* Args: R1.p = initialisation value */
FB_
- HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
CCS_ALLOC(CCCS,sizeofW(StgMutVar));
StgForeignObj *result;
FB_
- HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgHeader),
sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
StgWeak *w;
FB_
- HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field
sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
FB_
val = R1.i;
- HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
FB_
val = R1.w;
- HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
/* minimum is one word */
words_needed = 1;
}
- HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
} else {
words_needed = 1;
}
- HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
/* arguments: F1 = Float# */
arg = F1;
- HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
/* arguments: D1 = Double# */
arg = D1;
- HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
+ HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
FB_
/* args: none */
- HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
1, 0);
CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
StgStableName *sn_obj;
FB_
- HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgHeader),
sizeofW(StgStableName)-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.18 1999/09/15 13:45:20 simonmar Exp $
+ * $Id: Storage.c,v 1.19 1999/10/13 16:39:23 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
bdescr *bd;
StgPtr p;
- TICK_ALLOC_HEAP(n);
+ TICK_ALLOC_HEAP_NOCTR(n);
CCS_ALLOC(CCCS,n);
/* big allocation (>LARGE_OBJECT_THRESHOLD) */
/* -----------------------------------------------------------------------------
- * $Id: Ticky.c,v 1.9 1999/09/14 12:16:36 simonmar Exp $
+ * $Id: Ticky.c,v 1.10 1999/10/13 16:39:24 simonmar Exp $
*
* (c) The AQUA project, Glasgow University, 1992-1997
* (c) The GHC Team, 1998-1999
/* Data structure used in ``registering'' one of these counters. */
-struct ent_counter *ticky_entry_ctrs = NULL; /* root of list of them */
+StgEntCounter *ticky_entry_ctrs = NULL; /* root of list of them */
/* To print out all the registered-counter info: */
static void
printRegisteredCounterInfo (FILE *tf)
{
- struct ent_counter *p;
+ StgEntCounter *p;
if ( ticky_entry_ctrs != NULL ) {
- fprintf(tf,"\n**************************************************\n");
+ fprintf(tf,"\n**************************************************\n\n");
}
+ fprintf(tf, "%-30s %6s%6s %-16s%-11s%-11s\n",
+ "Function", "Arity", "Stack", "Kinds", "Entries",
+ "Allocs");
+ fprintf(tf, "--------------------------------------------------------------------------------\n");
for (p = ticky_entry_ctrs; p != NULL; p = p->link) {
- fprintf(tf, "%-40s%u\t%u\t%-16s%ld",
- p->f_str,
+ fprintf(tf, "%-30s%6u%6u %-11s%11ld%11ld",
+ p->str,
p->arity,
p->stk_args,
- p->f_arg_kinds,
- p->ctr);
+ p->arg_kinds,
+ p->ctr,
+ p->allocs);
fprintf(tf, "\n");
}
}
+/* Catch-all top-level counter struct. Allocations from CAFs will go
+ * here.
+ */
+StgEntCounter top_ct
+ = { 0, 0, 0,
+ "TOP", "",
+ 0, 0, NULL };
+
#endif /* TICKY_TICKY */
projects / ghc-hetmet.git / commitdiff