[project @ 2001-03-14 11:18:18 by sewardj]

Add closure selection for heap profiling.  You can use
-hc{cc_names}, -hd{descrs}, -hy{types}, -hm{mods} to restrict profiled
closures to the specified sets.  Multiple restrictions are allowed.

diff --git a/ghc/rts/ProfHeap.c b/ghc/rts/ProfHeap.c
index acd7778..02b714e 100644 (file)
--- a/ghc/rts/ProfHeap.c
+++ b/ghc/rts/ProfHeap.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.20 2000/12/11 12:36:59 simonmar Exp $
+ * $Id: ProfHeap.c,v 1.21 2001/03/14 11:18:18 sewardj Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -172,7 +172,28 @@ initHeapProfiling(void)
         return 0;
     }
 
-    fprintf(hp_file, "JOB \"%s\"\n", prog_argv[0]);
+    fprintf(hp_file, "JOB \"%s", prog_argv[0]);
+
+#   ifdef PROFILING
+    switch (RtsFlags.ProfFlags.doHeapProfile) {
+       case HEAP_BY_CCS:   fprintf(hp_file, " -h%c", CCchar); break;
+       case HEAP_BY_MOD:   fprintf(hp_file, " -h%c", MODchar); break;
+       case HEAP_BY_DESCR: fprintf(hp_file, " -h%c", DESCRchar); break;
+       case HEAP_BY_TYPE:  fprintf(hp_file, " -h%c", TYPEchar); break;
+       default: /* nothing */
+    }
+    if (RtsFlags.ProfFlags.ccSelector)
+       fprintf(hp_file, " -hc{%s}", RtsFlags.ProfFlags.ccSelector);
+    if (RtsFlags.ProfFlags.modSelector)
+       fprintf(hp_file, " -hm{%s}", RtsFlags.ProfFlags.modSelector);
+    if (RtsFlags.ProfFlags.descrSelector)
+       fprintf(hp_file, " -hd{%s}", RtsFlags.ProfFlags.descrSelector);
+    if (RtsFlags.ProfFlags.typeSelector)
+       fprintf(hp_file, " -hy{%s}", RtsFlags.ProfFlags.typeSelector);
+#   endif /* PROFILING */
+
+    fprintf(hp_file, "\"\n" );
+
     fprintf(hp_file, "DATE \"%s\"\n", time_str());
 
     fprintf(hp_file, "SAMPLE_UNIT \"seconds\"\n");
@@ -285,9 +306,8 @@ static void
 fprint_data(FILE *fp)
 {
     nat i;
-    
     for (i = 0; i < SYMBOL_HASH_SIZE; i++) {
-       if (symbol_hash[i].data) {
+       if (symbol_hash[i].data > 0) {
            fprintf(fp, "   %s %d\n", symbol_hash[i].name, symbol_hash[i].data);
        }
     }
@@ -433,7 +453,62 @@ reportCCSResid(FILE *fp, CostCentreStack *ccs)
     }
   }
 }
-#endif
+
+static
+rtsBool str_matches_selector ( char* str, char* sel )
+{
+   char* p;
+   /* fprintf(stderr, "str_matches_selector %s %s\n", str, sel); */
+   while (1) {
+      /* Compare str against wherever we've got to in sel. */
+      p = str;
+      while (*p != '\0' && *sel != ',' && *sel != '\0' && *p == *sel) {
+         p++; sel++;
+      }
+      /* Match if all of str used and have reached the end of a sel
+         fragment. */
+      if (*p == '\0' && (*sel == ',' || *sel == '\0'))
+         return rtsTrue;
+
+      /* No match.  Advance sel to the start of the next elem. */
+      while (*sel != ',' && *sel != '\0') sel++;
+      if (*sel == ',') sel++;
+
+      /* Run out of sel ?? */
+      if (*sel == '\0') return rtsFalse;
+   }
+}
+
+/* Figure out whether a closure should be counted in this census, by
+   testing against all the specified constraints. */
+static
+rtsBool satisfies_constraints ( StgClosure* p )
+{
+   rtsBool b;
+   if (RtsFlags.ProfFlags.modSelector) {
+      b = str_matches_selector( ((StgClosure *)p)->header.prof.ccs->cc->module,
+                                RtsFlags.ProfFlags.modSelector );
+      if (!b) return rtsFalse;
+   }
+   if (RtsFlags.ProfFlags.descrSelector) {
+      b = str_matches_selector( (get_itbl((StgClosure *)p))->prof.closure_desc,
+                                RtsFlags.ProfFlags.descrSelector );
+      if (!b) return rtsFalse;
+   }
+   if (RtsFlags.ProfFlags.typeSelector) {
+      b = str_matches_selector( (get_itbl((StgClosure *)p))->prof.closure_type,
+                                RtsFlags.ProfFlags.typeSelector );
+      if (!b) return rtsFalse;
+   }
+   if (RtsFlags.ProfFlags.ccSelector) {
+      b = str_matches_selector( ((StgClosure *)p)->header.prof.ccs->cc->label,
+                                RtsFlags.ProfFlags.ccSelector );
+      if (!b) return rtsFalse;
+   }
+   return rtsTrue;
+}
+#endif /* PROFILING */
+
 
 void
 heapCensus(void)
@@ -572,27 +647,30 @@ heapCensus(void)
       }
 #endif
 
-#ifdef PROFILING      
-      switch (RtsFlags.ProfFlags.doHeapProfile) {
-      case HEAP_BY_CCS:
-         ((StgClosure *)p)->header.prof.ccs->mem_resid += size;
-         break;
-      case HEAP_BY_MOD:
-         strToCtr(((StgClosure *)p)->header.prof.ccs->cc->module)
-             ->mem_resid += size;
-         break;
-      case HEAP_BY_DESCR:
-         strToCtr(get_itbl(((StgClosure *)p))->prof.closure_desc)->mem_resid 
-             += size;
-         break;
-      case HEAP_BY_TYPE:
-         strToCtr(get_itbl(((StgClosure *)p))->prof.closure_type)->mem_resid
-             += size;
-         break;
-      default:
-         barf("heapCensus; doHeapProfile");
-  }
-#endif
+#     ifdef PROFILING
+      if (satisfies_constraints((StgClosure*)p)) {
+         switch (RtsFlags.ProfFlags.doHeapProfile) {
+            case HEAP_BY_CCS:
+              ((StgClosure *)p)->header.prof.ccs->mem_resid += size;
+               break;
+            case HEAP_BY_MOD:
+               strToCtr(((StgClosure *)p)->header.prof.ccs->cc->module)
+                  ->mem_resid += size;
+               break;
+            case HEAP_BY_DESCR:
+               strToCtr(get_itbl(((StgClosure *)p))->prof.closure_desc)->mem_resid 
+                  += size;
+               break;
+            case HEAP_BY_TYPE:
+               strToCtr(get_itbl(((StgClosure *)p))->prof.closure_type)->mem_resid
+                  += size;
+               break;
+            default:
+               barf("heapCensus; doHeapProfile");
+         }
+      }
+#     endif
+
       p += size;
     }
     bd = bd->link;

diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c
index f8b8e99..b6d210f 100644 (file)
--- a/ghc/rts/RtsFlags.c
+++ b/ghc/rts/RtsFlags.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.36 2001/01/24 15:41:30 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.37 2001/03/14 11:18:18 sewardj Exp $
  *
  * (c) The AQUA Project, Glasgow University, 1994-1997
  * (c) The GHC Team, 1998-1999
@@ -238,10 +238,14 @@ void initRtsFlagsDefaults(void)
 #endif /* PROFILING or PAR */
 
 #ifdef PROFILING
-    RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
+    RtsFlags.ProfFlags.doHeapProfile      = rtsFalse;
     RtsFlags.ProfFlags.showCCSOnException = rtsFalse;
+    RtsFlags.ProfFlags.modSelector        = NULL;
+    RtsFlags.ProfFlags.descrSelector      = NULL;
+    RtsFlags.ProfFlags.typeSelector       = NULL;
+    RtsFlags.ProfFlags.ccSelector         = NULL;
 #elif defined(DEBUG)
-    RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
+    RtsFlags.ProfFlags.doHeapProfile      = rtsFalse;
 #endif
 
     RtsFlags.ConcFlags.ctxtSwitchTime  = CS_MIN_MILLISECS;  /* In milliseconds */
@@ -383,13 +387,19 @@ usage_text[] = {
 "  -px      Time/allocation profile (XML)  (output file <program>.prof)",
 "  -p<sort> Time/allocation profile        (output file <program>.prof)",
 "             sort: T = time (default), A = alloc, C = cost centre label",
-"  -P<sort> More detailed Time/Allocation profile"
+"  -P<sort> More detailed Time/Allocation profile",
+
 # if defined(PROFILING)
 "",
 "  -hx            Heap residency profile (XML)  (output file <program>.prof)",
 "  -h<break-down> Heap residency profile (text) (output file <program>.prof)",
 "     break-down: C = cost centre stack (default), M = module",
 "                 D = closure description, Y = type description",
+"  A subset of closures may be selected thusly:",
+"    -hc{cc, cc ...} specific cost centre(s) (NOT STACKS!)",
+"    -hm{mod,mod...} all cost centres from the specified modules(s)",
+"    -hd{des,des...} closures with specified closure descriptions",
+"    -hy{typ,typ...} closures with specified type descriptions",
 "",
 "  -xc      Show current cost centre stack on raising an exception",
 # endif
@@ -747,11 +757,44 @@ error = rtsTrue;
                  case TYPEchar:
                    RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_TYPE;
                    break;
+                  case 'c': /* cost centre label select */
+                  case 'm': /* cost centre module select */
+                  case 'd': /* closure descr select */
+                  case 'y': /* closure type select */
+                    {char *left  = strchr(rts_argv[arg], '{');
+                     char *right = strrchr(rts_argv[arg], '}');
+                     if (! left || ! right ||
+                          strrchr(rts_argv[arg], '{') != left ||
+                           strchr(rts_argv[arg], '}') != right) {
+                        prog_belch(
+                           "Invalid heap profiling selection bracketing\n   %s\n", 
+                           rts_argv[arg]);
+                        error = rtsTrue;
+                     } else {
+                        *right = '\0';
+                        switch (rts_argv[arg][2]) {
+                          case 'c': /* cost centre label select */
+                            RtsFlags.ProfFlags.ccSelector = left + 1;
+                            break;
+                          case 'm': /* cost centre module select */
+                            RtsFlags.ProfFlags.modSelector = left + 1;
+                            break;
+                          case 'd': /* closure descr select */
+                            RtsFlags.ProfFlags.descrSelector = left + 1;
+                            break;
+                          case 'y': /* closure type select */
+                            RtsFlags.ProfFlags.typeSelector = left + 1;
+                            break;
+                        }
+                     }
+                    }
+                    break;
                  default:
                    prog_belch("invalid heap profile option: %s",rts_argv[arg]);
                    error = rtsTrue;
                }
                ) 
+
 #endif
                break;
 

diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h
index 62ad3bd..1642247 100644 (file)
--- a/ghc/rts/RtsFlags.h
+++ b/ghc/rts/RtsFlags.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.30 2000/12/19 12:50:37 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.31 2001/03/14 11:18:18 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -92,7 +92,6 @@ struct PROFILING_FLAGS {
 # define HEAP_BY_MOD           2
 # define HEAP_BY_DESCR         4
 # define HEAP_BY_TYPE          5
-# define HEAP_BY_TIME          6
 
     rtsBool            showCCSOnException;
   
@@ -100,7 +99,12 @@ struct PROFILING_FLAGS {
 # define MODchar   'M'
 # define DESCRchar 'D'
 # define TYPEchar  'Y'
-# define TIMEchar  'T'
+
+    char*               modSelector;
+    char*               descrSelector;
+    char*               typeSelector;
+    char*               ccSelector;
+
 };
 #elif defined(DEBUG)
 # define NO_HEAP_PROFILING     0