X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FProfHeap.c;h=40137b7234361fa9e9bfa263174fdfb0ea8c728d;hb=ea138284b7343bb1810cfbd0284a608dc57f7d46;hp=4deb31f14c43187946a17a5f71476606f9491fa5;hpb=9ac55e08e159d7a4647ab01e7872e69dd762f275;p=ghc-hetmet.git

diff --git a/ghc/rts/ProfHeap.c b/ghc/rts/ProfHeap.c
index 4deb31f..40137b7 100644
--- a/ghc/rts/ProfHeap.c
+++ b/ghc/rts/ProfHeap.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.19 2000/12/04 12:31:21 simonmar Exp $
+ * $Id: ProfHeap.c,v 1.23 2001/07/23 17:23:19 simonmar 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,64 @@ 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 */
+
+
+static double time_of_last_heapCensus = 0.0;
 
 void
 heapCensus(void)
@@ -443,7 +520,8 @@ heapCensus(void)
   StgDouble time;
   nat size;
   StgPtr p;
-  
+  nat elapsed;
+    
 #ifdef DEBUG_HEAP_PROF
   switch (RtsFlags.ProfFlags.doHeapProfile) {
   case HEAP_BY_INFOPTR:
@@ -461,6 +539,21 @@ heapCensus(void)
 #endif
 
 #ifdef PROFILING
+  /*
+   * We only continue iff we've waited long enough,
+   * otherwise, we just dont do the census.
+   */
+
+  time = mut_user_time_during_GC();  
+  elapsed = (time - time_of_last_heapCensus) * 1000;
+  if (elapsed < RtsFlags.ProfFlags.profileFrequency) {
+      return;
+    }
+  time_of_last_heapCensus = time;
+#endif
+
+
+#ifdef PROFILING
   switch (RtsFlags.ProfFlags.doHeapProfile) {
   case NO_HEAP_PROFILING:
       return;
@@ -480,9 +573,8 @@ heapCensus(void)
 
   /* Only do heap profiling in a two-space heap */
   ASSERT(RtsFlags.GcFlags.generations == 1);
-  bd = g0s0->to_space;
+  bd = g0s0->to_blocks;
 
-  time = mut_user_time_during_GC();
   fprintf(hp_file, "BEGIN_SAMPLE %0.2f\n", time);
   
   while (bd != NULL) {
@@ -491,9 +583,6 @@ heapCensus(void)
       info = get_itbl((StgClosure *)p);
 
       switch (info->type) {
-      case BCO:
-	size = bco_sizeW((StgBCO *)p);
-	break;
 	
       case CONSTR:
 	if (((StgClosure *)p)->header.info == &stg_DEAD_WEAK_info
@@ -503,6 +592,7 @@ heapCensus(void)
 	}
 	/* else, fall through... */
 
+      case BCO:
       case FUN:
       case THUNK:
       case IND_PERM:
@@ -574,27 +664,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;