From 5c67176de89fee19a02056216a7c58579e765148 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 13 Oct 1999 16:39:24 +0000 Subject: [PATCH] [project @ 1999-10-13 16:39:10 by simonmar] 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. --- ghc/compiler/absCSyn/AbsCUtils.lhs | 7 ++++- ghc/compiler/absCSyn/CLabel.lhs | 8 +++++- ghc/compiler/absCSyn/PprAbsC.lhs | 6 +++- ghc/compiler/codeGen/CgBindery.lhs | 4 +-- ghc/compiler/codeGen/CgCase.lhs | 11 ++++++-- ghc/compiler/codeGen/CgClosure.lhs | 41 ++++++++++++++++++---------- ghc/compiler/codeGen/CgHeapery.lhs | 47 ++++++++++++++++++++++++-------- ghc/compiler/codeGen/CgMonad.lhs | 53 +++++++++++++++++++++++++----------- ghc/compiler/utils/Outputable.lhs | 5 +++- ghc/driver/ghc-asm.lprl | 5 ++++ ghc/includes/StgMacros.h | 28 +++++++++---------- ghc/includes/StgTicky.h | 48 ++++++++++++++++++++------------ ghc/rts/PrimOps.hc | 24 ++++++++-------- ghc/rts/Storage.c | 4 +-- ghc/rts/Ticky.c | 29 ++++++++++++++------ 15 files changed, 214 insertions(+), 106 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 6f6772c..c6ccb50 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -344,9 +344,14 @@ flatAbsC stmt@(CCheck macro amodes 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) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index ac0c3d2..636a2f3 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (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} @@ -36,6 +36,7 @@ module CLabel ( mkErrorStdEntryLabel, mkUpdInfoLabel, + mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, mkSECAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, @@ -166,6 +167,8 @@ data RtsLabelInfo | RtsPrimOp PrimOp + | RtsTopTickyCtr + deriving (Eq, Ord) -- Label Type: for generating C declarations. @@ -211,6 +214,7 @@ mkAsmTempLabel = AsmTempLabel 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")) @@ -405,6 +409,8 @@ pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry") 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)) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index c5c91f1..dc29be7 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1205,8 +1205,12 @@ cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") 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} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 3481fea..8cda07b 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -193,7 +193,7 @@ modifyBindC name mangle_fn info_down (MkCgState absC binds usage) = 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 @@ -208,7 +208,7 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _) -> 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, diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index f6771a6..b7c092c 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -63,7 +63,7 @@ import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, 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 @@ -144,6 +144,11 @@ which generates no code for the primop, unless x is used in the 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) @@ -152,7 +157,7 @@ cgCase (StgCon (PrimOp op) args res_ty) 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 diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 26c7e51..71a2c06 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.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} @@ -297,6 +297,7 @@ closureCodeBody binder_info closure_info cc all_args body -- 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 @@ -371,13 +372,17 @@ closureCodeBody binder_info closure_info cc all_args body -- 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)), @@ -399,24 +404,30 @@ closureCodeBody binder_info closure_info cc all_args body -- 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 diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 1663846..a4f6bc2 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (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} @@ -75,9 +75,11 @@ fastEntryChecks regs tags ret node_points code 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 @@ -101,7 +103,7 @@ fastEntryChecks regs tags ret node_points code 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` @@ -110,9 +112,17 @@ fastEntryChecks regs tags ret node_points code 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: @@ -241,9 +251,15 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code 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 @@ -291,12 +307,19 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code 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 diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index d649bc2..484cc48 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (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} @@ -24,10 +24,11 @@ module CgMonad ( setEndOfBlockInfo, getEndOfBlockInfo, setSRTLabel, getSRTLabel, + setTickyCtrLabel, getTickyCtrLabel, StackUsage, Slot(..), HeapUsage, - profCtrC, + profCtrC, profCtrAbsC, costCentresC, moduleName, @@ -47,7 +48,7 @@ import {-# SOURCE #-} CgUsages ( getSpRelOffset ) 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 ) @@ -80,6 +81,8 @@ data CgInfoDownwards -- information only passed *downwards* by the monad CLabel -- label of the current SRT + CLabel -- current destination for ticky counts + EndOfBlockInfo -- Info for stuff to do at end of basic block: @@ -268,6 +271,7 @@ initC cg_info code cg_info (error "initC: statics") (error "initC: srt") + (mkTopTickyCtrLabel) initEobInfo) initialStateC) of MkCgState abc _ _ -> abc @@ -367,24 +371,24 @@ bindings and usage information is otherwise unchanged. 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) @@ -453,10 +457,10 @@ forkEvalHelp :: EndOfBlockInfo -- For the body 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 @@ -518,6 +522,13 @@ profCtrC macro args _ state@(MkCgState absC binds usage) 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 @@ -544,27 +555,37 @@ getAbsC code info_down (MkCgState absC binds usage) \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} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index f44fd2a..c79b577 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -37,7 +37,7 @@ module Outputable ( printSDoc, printErrs, printDump, printForC, printForAsm, printForIface, pprCode, pprCols, - showSDoc, showsPrecSDoc, pprFSAsString, + showSDoc, showSDocDebug, showsPrecSDoc, pprFSAsString, -- error handling @@ -186,6 +186,9 @@ pprCode cs d = withPprStyle (PprCode cs) d 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)) diff --git a/ghc/driver/ghc-asm.lprl b/ghc/driver/ghc-asm.lprl index 5850074..a09a1db 100644 --- a/ghc/driver/ghc-asm.lprl +++ b/ghc/driver/ghc-asm.lprl @@ -478,6 +478,11 @@ sub mangle_asm { $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'; diff --git a/ghc/includes/StgMacros.h b/ghc/includes/StgMacros.h index c4b1e52..3dec751 100644 --- a/ghc/includes/StgMacros.h +++ b/ghc/includes/StgMacros.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -179,8 +179,7 @@ static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; } 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) { \ @@ -188,8 +187,7 @@ static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; } 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 @@ -218,24 +216,22 @@ static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; } 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 */ @@ -244,8 +240,7 @@ static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; } 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); @@ -329,8 +324,11 @@ static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; } 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) { \ diff --git a/ghc/includes/StgTicky.h b/ghc/includes/StgTicky.h index cf68671..6220774 100644 --- a/ghc/includes/StgTicky.h +++ b/ghc/includes/StgTicky.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 @@ -21,7 +21,18 @@ * 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), @@ -127,36 +138,39 @@ #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 */ diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 936b908..0a18aaf 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -257,7 +257,7 @@ FN_(newMutVarzh_fast) /* 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)); @@ -283,7 +283,7 @@ FN_(makeForeignObjzh_fast) 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 */ @@ -326,7 +326,7 @@ FN_(mkWeakzh_fast) 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 */ @@ -395,7 +395,7 @@ FN_(int2Integerzh_fast) 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 */ @@ -432,7 +432,7 @@ FN_(word2Integerzh_fast) 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 */ @@ -505,7 +505,7 @@ FN_(int64ToIntegerzh_fast) /* 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 */ @@ -556,7 +556,7 @@ FN_(word64ToIntegerzh_fast) } 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 */ @@ -682,7 +682,7 @@ FN_(decodeFloatzh_fast) /* 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 */ @@ -715,7 +715,7 @@ FN_(decodeDoublezh_fast) /* 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 */ @@ -807,7 +807,7 @@ FN_(newMVarzh_fast) 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 */ @@ -900,7 +900,7 @@ FN_(makeStableNamezh_fast) 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 */ diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c index 820a934..fc3c409 100644 --- a/ghc/rts/Storage.c +++ b/ghc/rts/Storage.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -289,7 +289,7 @@ allocate(nat n) bdescr *bd; StgPtr p; - TICK_ALLOC_HEAP(n); + TICK_ALLOC_HEAP_NOCTR(n); CCS_ALLOC(CCCS,n); /* big allocation (>LARGE_OBJECT_THRESHOLD) */ diff --git a/ghc/rts/Ticky.c b/ghc/rts/Ticky.c index 81bad57..dbbdcdb 100644 --- a/ghc/rts/Ticky.c +++ b/ghc/rts/Ticky.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 @@ -538,31 +538,44 @@ PrintTickyInfo(void) /* 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 */ -- 1.7.10.4