[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.

5 files changed, 108 insertions, 48 deletions

diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 3481feadab..8cda07b537 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 f6771a6320..b7c092cf93 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 26c7e51e44..71a2c06f4b 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 16638460fd..a4f6bc238c 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 d649bc24ab..484cc48870 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}