[project @ 2001-11-22 15:15:27 by simonmar]
[ghc-hetmet.git] / ghc / rts / Profiling.c
1 /* -----------------------------------------------------------------------------
2  * $Id: Profiling.c,v 1.25 2001/11/22 14:25:12 simonmar Exp $
3  *
4  * (c) The GHC Team, 1998-2000
5  *
6  * Support for profiling
7  *
8  * ---------------------------------------------------------------------------*/
9
10 #ifdef PROFILING
11
12 #include "PosixSource.h"
13 #include "Rts.h"
14 #include "RtsUtils.h"
15 #include "RtsFlags.h"
16 #include "Profiling.h"
17 #include "Storage.h"
18 #include "Proftimer.h"
19 #include "Itimer.h"
20 #include "ProfHeap.h"
21 #include "Arena.h"
22 #include "RetainerProfile.h"
23 #include "LdvProfile.h"
24
25 /*
26  * Profiling allocation arena.
27  */
28 Arena *prof_arena;
29
30 /*
31  * Global variables used to assign unique IDs to cc's, ccs's, and 
32  * closure_cats
33  */
34
35 unsigned int CC_ID;
36 unsigned int CCS_ID;
37 unsigned int HP_ID;
38
39 /* Table sizes from old profiling system.  Not sure if we'll need
40  * these.
41  */
42 nat time_intervals = 0;
43 nat earlier_ticks  = 0;
44 nat max_cc_no      = 0;
45 nat max_mod_no     = 0;
46 nat max_grp_no     = 0;
47 nat max_descr_no   = 0;
48 nat max_type_no    = 0;
49
50 /* Are we time-profiling?
51  */
52 rtsBool time_profiling = rtsFalse;
53
54 /* figures for the profiling report.
55  */
56 static lnat total_alloc, total_prof_ticks;
57
58 /* Globals for opening the profiling log file(s)
59  */
60 static char *prof_filename; /* prof report file name = <program>.prof */
61 FILE *prof_file;
62
63 static char *hp_filename;       /* heap profile (hp2ps style) log file */
64 FILE *hp_file;
65
66 /* The Current Cost Centre Stack (for attributing costs)
67  */
68 CostCentreStack *CCCS;
69
70 /* Linked lists to keep track of cc's and ccs's that haven't
71  * been declared in the log file yet
72  */
73 CostCentre *CC_LIST;
74 CostCentreStack *CCS_LIST;
75
76 /*
77  * Built-in cost centres and cost-centre stacks:
78  *
79  *    MAIN   is the root of the cost-centre stack tree.  If there are
80  *           no _scc_s in the program, all costs will be attributed
81  *           to MAIN.
82  *
83  *    SYSTEM is the RTS in general (scheduler, etc.).  All costs for
84  *           RTS operations apart from garbage collection are attributed
85  *           to SYSTEM.
86  *
87  *    GC     is the storage manager / garbage collector.
88  *
89  *    OVERHEAD gets all costs generated by the profiling system
90  *           itself.  These are costs that would not be incurred
91  *           during non-profiled execution of the program.
92  *
93  *    SUBSUMED is the one-and-only CCS placed on top-level functions. 
94  *           It indicates that all costs are to be attributed to the
95  *           enclosing cost centre stack.  SUBSUMED never accumulates
96  *           any costs.  The is_caf flag is set on the subsumed cost
97  *           centre.
98  *
99  *    DONT_CARE is a placeholder cost-centre we assign to static
100  *           constructors.  It should *never* accumulate any costs.
101  */
102
103 CC_DECLARE(CC_MAIN,      "MAIN",        "MAIN",      CC_IS_BORING, );
104 CC_DECLARE(CC_SYSTEM,    "SYSTEM",      "MAIN",      CC_IS_BORING, );
105 CC_DECLARE(CC_GC,        "GC",          "GC",        CC_IS_BORING, );
106 CC_DECLARE(CC_OVERHEAD,  "OVERHEAD_of", "PROFILING", CC_IS_CAF,    );
107 CC_DECLARE(CC_SUBSUMED,  "SUBSUMED",    "MAIN",      CC_IS_CAF,    );
108 CC_DECLARE(CC_DONT_CARE, "DONT_CARE",   "MAIN",      CC_IS_BORING, );
109
110 CCS_DECLARE(CCS_MAIN,       CC_MAIN,       );
111 CCS_DECLARE(CCS_SYSTEM,     CC_SYSTEM,     );
112 CCS_DECLARE(CCS_GC,         CC_GC,         );
113 CCS_DECLARE(CCS_OVERHEAD,   CC_OVERHEAD,   );
114 CCS_DECLARE(CCS_SUBSUMED,   CC_SUBSUMED,   );
115 CCS_DECLARE(CCS_DONT_CARE,  CC_DONT_CARE, );
116
117 /* 
118  * Uniques for the XML log-file format
119  */
120 #define CC_UQ         1
121 #define CCS_UQ        2
122 #define TC_UQ         3
123 #define HEAP_OBJ_UQ   4
124 #define TIME_UPD_UQ   5
125 #define HEAP_UPD_UQ   6
126
127 /* 
128  * Static Functions
129  */
130
131 static  CostCentreStack * ActualPush_     ( CostCentreStack *ccs, CostCentre *cc, 
132                                             CostCentreStack *new_ccs );
133 static  rtsBool           ccs_to_ignore   ( CostCentreStack *ccs );
134 static  void              count_ticks     ( CostCentreStack *ccs );
135 static  void              inherit_costs   ( CostCentreStack *ccs );
136 static  void              reportCCS       ( CostCentreStack *ccs, nat indent );
137 static  void              DecCCS          ( CostCentreStack *ccs );
138 static  void              DecBackEdge     ( CostCentreStack *ccs, 
139                                             CostCentreStack *oldccs );
140 static  CostCentreStack * CheckLoop       ( CostCentreStack *ccs, CostCentre *cc );
141 static  CostCentreStack * pruneCCSTree    ( CostCentreStack *ccs );
142 static  CostCentreStack * ActualPush      ( CostCentreStack *, CostCentre * );
143 static  CostCentreStack * IsInIndexTable  ( IndexTable *, CostCentre * );
144 static  IndexTable *      AddToIndexTable ( IndexTable *, CostCentreStack *, 
145                                             CostCentre *, unsigned int );
146
147
148
149 static    void initTimeProfiling   ( void );
150 static    void initProfilingLogFile( void );
151
152 static    void reportCCS_XML       ( CostCentreStack *ccs );
153
154 /* -----------------------------------------------------------------------------
155    Initialise the profiling environment
156    -------------------------------------------------------------------------- */
157
158 void
159 initProfiling1 (void)
160 {
161   // initialise our arena
162   prof_arena = newArena();
163
164   /* for the benefit of allocate()... */
165   CCCS = CCS_SYSTEM;
166   
167   /* Initialize counters for IDs */
168   CC_ID  = 1;
169   CCS_ID = 1;
170   HP_ID  = 1;
171   
172   /* Initialize Declaration lists to NULL */
173   CC_LIST  = NULL;
174   CCS_LIST = NULL;
175
176   /* Register all the cost centres / stacks in the program 
177    * CC_MAIN gets link = 0, all others have non-zero link.
178    */
179   REGISTER_CC(CC_MAIN);
180   REGISTER_CC(CC_SYSTEM);
181   REGISTER_CC(CC_GC);
182   REGISTER_CC(CC_OVERHEAD);
183   REGISTER_CC(CC_SUBSUMED);
184   REGISTER_CC(CC_DONT_CARE);
185   REGISTER_CCS(CCS_MAIN);
186   REGISTER_CCS(CCS_SYSTEM);
187   REGISTER_CCS(CCS_GC);
188   REGISTER_CCS(CCS_OVERHEAD);
189   REGISTER_CCS(CCS_SUBSUMED);
190   REGISTER_CCS(CCS_DONT_CARE);
191
192   CCCS = CCS_OVERHEAD;
193
194   /* cost centres are registered by the per-module 
195    * initialisation code now... 
196    */
197
198   switch (RtsFlags.ProfFlags.doHeapProfile) {
199   case HEAP_BY_RETAINER:
200       initRetainerProfiling();
201       break;
202   case HEAP_BY_LDV:
203       initLdvProfiling();
204       break;
205   }
206 }
207
208 void
209 initProfiling2 (void)
210 {
211   CostCentreStack *ccs, *next;
212
213   CCCS = CCS_SYSTEM;
214
215   /* Set up the log file, and dump the header and cost centre
216    * information into it.  */
217   initProfilingLogFile();
218
219   /* find all the "special" cost centre stacks, and make them children
220    * of CCS_MAIN.
221    */
222   ASSERT(CCS_MAIN->prevStack == 0);
223   CCS_MAIN->root = CC_MAIN;
224   DecCCS(CCS_MAIN);
225   for (ccs = CCS_LIST; ccs != CCS_MAIN; ) {
226     next = ccs->prevStack;
227     ccs->prevStack = 0;
228     ActualPush_(CCS_MAIN,ccs->cc,ccs);
229     ccs->root = ccs->cc;
230     ccs = next;
231   }
232   
233   if (RtsFlags.CcFlags.doCostCentres) {
234     initTimeProfiling();
235   }
236
237   if (RtsFlags.ProfFlags.doHeapProfile) {
238     initHeapProfiling();
239   }
240 }
241   
242 static void
243 initProfilingLogFile(void)
244 {
245     /* Initialise the log file name */
246     prof_filename = arenaAlloc(prof_arena, strlen(prog_argv[0]) + 6);
247     sprintf(prof_filename, "%s.prof", prog_argv[0]);
248
249     /* open the log file */
250     if ((prof_file = fopen(prof_filename, "w")) == NULL) {
251         fprintf(stderr, "Can't open profiling report file %s\n", prof_filename);
252         RtsFlags.CcFlags.doCostCentres = 0;
253         // @retainer profiling
254         // @LDV profiling
255         // The following line was added by Sung; retainer/LDV profiling may need
256         // two output files, i.e., <program>.prof/hp.
257         if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER ||
258             RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV)
259             RtsFlags.ProfFlags.doHeapProfile = 0;
260         return;
261     }
262
263     if (RtsFlags.CcFlags.doCostCentres == COST_CENTRES_XML) {
264         /* dump the time, and the profiling interval */
265         fprintf(prof_file, "\"%s\"\n", time_str());
266         fprintf(prof_file, "\"%d ms\"\n", TICK_MILLISECS);
267         
268         /* declare all the cost centres */
269         {
270             CostCentre *cc;
271             for (cc = CC_LIST; cc != NULL; cc = cc->link) {
272                 fprintf(prof_file, "%d %d \"%s\" \"%s\"\n",
273                         CC_UQ, cc->ccID, cc->label, cc->module);
274             }
275         }
276     }
277     
278     if (RtsFlags.ProfFlags.doHeapProfile) {
279         /* Initialise the log file name */
280         hp_filename = arenaAlloc(prof_arena, strlen(prog_argv[0]) + 6);
281         sprintf(hp_filename, "%s.hp", prog_argv[0]);
282         
283         /* open the log file */
284         if ((hp_file = fopen(hp_filename, "w")) == NULL) {
285             fprintf(stderr, "Can't open profiling report file %s\n", 
286                     hp_filename);
287             RtsFlags.ProfFlags.doHeapProfile = 0;
288             return;
289         }
290     }
291 }
292
293 void
294 initTimeProfiling(void)
295 {
296   time_profiling = rtsTrue;
297
298   /* Start ticking */
299   startProfTimer();
300 };
301
302 void 
303 endProfiling ( void )
304 {
305   if (RtsFlags.CcFlags.doCostCentres) {
306     stopProfTimer();
307   }
308   if (RtsFlags.ProfFlags.doHeapProfile) {
309     endHeapProfiling();
310   }
311 }
312
313 /* -----------------------------------------------------------------------------
314    Set cost centre stack when entering a function.
315    -------------------------------------------------------------------------- */
316 rtsBool entering_PAP;
317
318 CostCentreStack *
319 EnterFunCCS ( CostCentreStack *cccs, CostCentreStack *ccsfn )
320 {
321   /* PAP_entry has already set CCCS for us */
322   if (entering_PAP) {
323     entering_PAP = rtsFalse;
324     return CCCS;
325   }
326
327   if (ccsfn->root->is_caf == CC_IS_CAF) {
328     return AppendCCS(cccs,ccsfn);
329   } else {
330     return ccsfn;
331   }
332 }
333
334 /* -----------------------------------------------------------------------------
335    Cost-centre stack manipulation
336    -------------------------------------------------------------------------- */
337
338 #ifdef DEBUG
339 CostCentreStack * _PushCostCentre ( CostCentreStack *ccs, CostCentre *cc );
340 CostCentreStack *
341 PushCostCentre ( CostCentreStack *ccs, CostCentre *cc )
342 #define PushCostCentre _PushCostCentre
343 {
344   IF_DEBUG(prof, 
345            fprintf(stderr,"Pushing %s on ", cc->label);
346            fprintCCS(stderr,ccs);
347            fprintf(stderr,"\n"));
348   return PushCostCentre(ccs,cc);
349 }
350 #endif
351
352 CostCentreStack *
353 PushCostCentre ( CostCentreStack *ccs, CostCentre *cc )
354 {
355   CostCentreStack *temp_ccs;
356   
357   if (ccs == EMPTY_STACK)
358     return ActualPush(ccs,cc);
359   else {
360     if (ccs->cc == cc)
361       return ccs;
362     else {
363       /* check if we've already memoized this stack */
364       temp_ccs = IsInIndexTable(ccs->indexTable,cc);
365       
366       if (temp_ccs != EMPTY_STACK)
367         return temp_ccs;
368       else {
369         temp_ccs = CheckLoop(ccs,cc);
370         if (temp_ccs != NULL) {
371           /* we have recursed to an older CCS.  Mark this in
372            * the index table, and emit a "back edge" into the
373            * log file.
374            */
375           ccs->indexTable = AddToIndexTable(ccs->indexTable,temp_ccs,cc,1);
376           DecBackEdge(temp_ccs,ccs);
377           return temp_ccs;
378         } else {
379           return ActualPush(ccs,cc);
380         }
381       }
382     }
383   }
384 }
385
386 static CostCentreStack *
387 CheckLoop ( CostCentreStack *ccs, CostCentre *cc )
388 {
389   while (ccs != EMPTY_STACK) {
390     if (ccs->cc == cc)
391       return ccs;
392     ccs = ccs->prevStack;
393   }
394   return NULL;
395 }
396
397 /* Append ccs1 to ccs2 (ignoring any CAF cost centre at the root of ccs1 */
398
399 #ifdef DEBUG
400 CostCentreStack *_AppendCCS ( CostCentreStack *ccs1, CostCentreStack *ccs2 );
401 CostCentreStack *
402 AppendCCS ( CostCentreStack *ccs1, CostCentreStack *ccs2 )
403 #define AppendCCS _AppendCCS
404 {
405   IF_DEBUG(prof, 
406            if (ccs1 != ccs2) {
407              fprintf(stderr,"Appending ");
408              fprintCCS(stderr,ccs1);
409              fprintf(stderr," to ");
410              fprintCCS(stderr,ccs2);
411              fprintf(stderr,"\n");});
412   return AppendCCS(ccs1,ccs2);
413 }
414 #endif
415
416 CostCentreStack *
417 AppendCCS ( CostCentreStack *ccs1, CostCentreStack *ccs2 )
418 {
419   CostCentreStack *ccs = NULL;
420
421   if (ccs1 == ccs2) {
422     return ccs1;
423   }
424
425   if (ccs2->cc->is_caf == CC_IS_CAF) {
426     return ccs1;
427   }
428   
429   if (ccs2->prevStack != NULL) {
430     ccs = AppendCCS(ccs1, ccs2->prevStack);
431   }
432
433   return PushCostCentre(ccs,ccs2->cc);
434 }
435
436 static CostCentreStack *
437 ActualPush ( CostCentreStack *ccs, CostCentre *cc )
438 {
439   CostCentreStack *new_ccs;
440   
441   /* allocate space for a new CostCentreStack */
442   new_ccs = (CostCentreStack *) arenaAlloc(prof_arena, sizeof(CostCentreStack));
443   
444   return ActualPush_(ccs, cc, new_ccs);
445 }
446
447 static CostCentreStack *
448 ActualPush_ ( CostCentreStack *ccs, CostCentre *cc, CostCentreStack *new_ccs )
449 {
450   /* assign values to each member of the structure */
451   ASSIGN_CCS_ID(new_ccs->ccsID);
452   
453   new_ccs->cc = cc;
454   new_ccs->prevStack = ccs;
455   
456   new_ccs->indexTable = EMPTY_TABLE;
457   
458   /* Initialise the various _scc_ counters to zero
459    */
460   new_ccs->scc_count        = 0;
461   
462   /* Initialize all other stats here.  There should be a quick way
463    * that's easily used elsewhere too 
464    */
465   new_ccs->time_ticks = 0;
466   new_ccs->mem_alloc = 0;
467   new_ccs->inherited_ticks = 0;
468   new_ccs->inherited_alloc = 0;
469   
470   new_ccs->root = ccs->root;
471
472   /* update the memoization table for the parent stack */
473   if (ccs != EMPTY_STACK)
474     ccs->indexTable = AddToIndexTable(ccs->indexTable, new_ccs, cc, 
475                                       0/*not a back edge*/);
476   
477   /* make sure this CC is declared at the next heap/time sample */
478   DecCCS(new_ccs);
479   
480   /* return a pointer to the new stack */
481   return new_ccs;
482 }
483
484
485 static CostCentreStack *
486 IsInIndexTable(IndexTable *it, CostCentre *cc)
487 {
488   while (it!=EMPTY_TABLE)
489     {
490       if (it->cc==cc)
491         return it->ccs;
492       else
493         it = it->next;
494     }
495   
496   /* otherwise we never found it so return EMPTY_TABLE */
497   return EMPTY_TABLE;
498 }
499
500
501 static IndexTable *
502 AddToIndexTable(IndexTable *it, CostCentreStack *new_ccs, 
503                 CostCentre *cc, unsigned int back_edge)
504 {
505   IndexTable *new_it;
506   
507   new_it = arenaAlloc(prof_arena, sizeof(IndexTable));
508   
509   new_it->cc = cc;
510   new_it->ccs = new_ccs;
511   new_it->next = it;
512   new_it->back_edge = back_edge;
513   return new_it;
514 }
515
516
517 static void
518 DecCCS(CostCentreStack *ccs)
519 {
520   if (prof_file && RtsFlags.CcFlags.doCostCentres == COST_CENTRES_XML) {
521     if (ccs->prevStack == EMPTY_STACK)
522       fprintf(prof_file, "%d %d 1 %d\n", CCS_UQ, 
523               ccs->ccsID, ccs->cc->ccID);
524     else
525       fprintf(prof_file, "%d %d 2 %d %d\n", CCS_UQ, 
526               ccs->ccsID, ccs->cc->ccID, ccs->prevStack->ccsID);
527   }
528 }
529
530 static void
531 DecBackEdge( CostCentreStack *ccs, CostCentreStack *oldccs )
532 {
533   if (prof_file && RtsFlags.CcFlags.doCostCentres == COST_CENTRES_XML) {
534     if (ccs->prevStack == EMPTY_STACK)
535       fprintf(prof_file, "%d %d 1 %d\n", CCS_UQ, 
536               ccs->ccsID, ccs->cc->ccID);
537     else
538       fprintf(prof_file, "%d %d 2 %d %d\n", CCS_UQ, 
539               ccs->ccsID, ccs->cc->ccID, oldccs->ccsID);
540   }
541 }
542
543 /* -----------------------------------------------------------------------------
544    Generating a time & allocation profiling report.
545    -------------------------------------------------------------------------- */
546
547 /* -----------------------------------------------------------------------------
548    Generating the aggregated per-cost-centre time/alloc report.
549    -------------------------------------------------------------------------- */
550
551 static CostCentre *sorted_cc_list;
552
553 static void
554 aggregate_cc_costs( CostCentreStack *ccs )
555 {
556   IndexTable *i;
557
558   ccs->cc->mem_alloc += ccs->mem_alloc;
559   ccs->cc->time_ticks += ccs->time_ticks;
560
561   for (i = ccs->indexTable; i != 0; i = i->next) {
562     if (!i->back_edge) {
563       aggregate_cc_costs(i->ccs);
564     }
565   }
566 }
567
568 static void
569 insert_cc_in_sorted_list( CostCentre *new_cc )
570 {
571   CostCentre **prev, *cc;
572
573   prev = &sorted_cc_list;
574   for (cc = sorted_cc_list; cc != NULL; cc = cc->link) {
575     if (new_cc->time_ticks > cc->time_ticks) {
576       new_cc->link = cc;
577       *prev = new_cc;
578       return;
579     } else {
580       prev = &(cc->link);
581     }
582   }
583   new_cc->link = NULL;
584   *prev = new_cc;
585 }
586
587 static void
588 report_per_cc_costs( void )
589 {
590   CostCentre *cc, *next;
591
592   aggregate_cc_costs(CCS_MAIN);
593   sorted_cc_list = NULL;
594
595   for (cc = CC_LIST; cc != NULL; cc = next) {
596     next = cc->link;
597     if (cc->time_ticks > total_prof_ticks/100
598         || cc->mem_alloc > total_alloc/100
599         || RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL) {
600       insert_cc_in_sorted_list(cc);
601     }
602   }
603   
604   fprintf(prof_file, "%-20s %-10s", "COST CENTRE", "MODULE");  
605   fprintf(prof_file, "%6s %6s", "%time", "%alloc");
606   if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
607     fprintf(prof_file, "  %5s %9s", "ticks", "bytes");
608   }
609   fprintf(prof_file, "\n\n");
610
611   for (cc = sorted_cc_list; cc != NULL; cc = cc->link) {
612     fprintf(prof_file, "%-20s %-10s", cc->label, cc->module);
613     fprintf(prof_file, "%6.1f %6.1f",
614             total_prof_ticks == 0 ? 0.0 : (cc->time_ticks / (StgFloat) total_prof_ticks * 100),
615             total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat)
616                                       total_alloc * 100)
617             );
618
619     if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
620       fprintf(prof_file, "  %5ld %9lld", cc->time_ticks, cc->mem_alloc);
621     }
622     fprintf(prof_file, "\n");
623   }
624
625   fprintf(prof_file,"\n\n");
626 }
627
628 /* -----------------------------------------------------------------------------
629    Generate the cost-centre-stack time/alloc report
630    -------------------------------------------------------------------------- */
631
632 static void 
633 fprint_header( void )
634 {
635   fprintf(prof_file, "%-24s %-10s           individual     inherited\n", "", "");
636
637   fprintf(prof_file, "%-24s %-10s", "COST CENTRE", "MODULE");  
638   fprintf(prof_file, "%8s  %5s %5s   %5s %5s", "entries", "%time", "%alloc", "%time", "%alloc");
639
640   if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
641     fprintf(prof_file, "  %5s %9s", "ticks", "bytes");
642 #if defined(PROFILING_DETAIL_COUNTS)
643     fprintf(prof_file, "  %8s %8s %8s %8s %8s %8s %8s",
644             "closures", "thunks", "funcs", "PAPs", "subfuns", "subcafs", "cafssub");
645 #endif
646   }
647
648   fprintf(prof_file, "\n\n");
649 }
650
651 void
652 report_ccs_profiling( void )
653 {
654     nat count;
655     char temp[128]; /* sigh: magic constant */
656
657     stopProfTimer();
658
659     total_prof_ticks = 0;
660     total_alloc = 0;
661     count_ticks(CCS_MAIN);
662     
663     switch (RtsFlags.CcFlags.doCostCentres) {
664     case 0:
665       return;
666     case COST_CENTRES_XML:
667       gen_XML_logfile();
668       return;
669     default:
670     }
671
672     fprintf(prof_file, "\t%s Time and Allocation Profiling Report  (%s)\n", 
673             time_str(), "Final");
674
675     fprintf(prof_file, "\n\t  ");
676     fprintf(prof_file, " %s", prog_argv[0]);
677     fprintf(prof_file, " +RTS");
678     for (count = 0; rts_argv[count]; count++)
679         fprintf(prof_file, " %s", rts_argv[count]);
680     fprintf(prof_file, " -RTS");
681     for (count = 1; prog_argv[count]; count++)
682         fprintf(prof_file, " %s", prog_argv[count]);
683     fprintf(prof_file, "\n\n");
684
685     fprintf(prof_file, "\ttotal time  = %11.2f secs   (%lu ticks @ %d ms)\n",
686             total_prof_ticks / (StgFloat) TICK_FREQUENCY, 
687             total_prof_ticks, TICK_MILLISECS);
688
689     fprintf(prof_file, "\ttotal alloc = %11s bytes",
690             ullong_format_string((ullong) total_alloc * sizeof(W_),
691                                  temp, rtsTrue/*commas*/));
692     /* ToDo: 64-bit error! */
693
694 #if defined(PROFILING_DETAIL_COUNTS)
695     fprintf(prof_file, "  (%lu closures)", total_allocs);
696 #endif
697     fprintf(prof_file, "  (excludes profiling overheads)\n\n");
698
699     report_per_cc_costs();
700
701     inherit_costs(CCS_MAIN);
702
703     fprint_header();
704     reportCCS(pruneCCSTree(CCS_MAIN), 0);
705
706     // @retainer profiling
707     // @LDV profiling
708     // Now, prof_file is closed in shutdownHaskell() because this file
709     // is also used for retainer/LDV profiling. See shutdownHaskell().
710     // fclose(prof_file);
711 }
712
713 static void 
714 reportCCS(CostCentreStack *ccs, nat indent)
715 {
716   CostCentre *cc;
717   IndexTable *i;
718
719   cc = ccs->cc;
720   
721   /* Only print cost centres with non 0 data ! */
722   
723   if ( RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL ||
724        ! ccs_to_ignore(ccs))
725         /* force printing of *all* cost centres if -P -P */ 
726     {
727
728     fprintf(prof_file, "%-*s%-*s %-10s", 
729             indent, "", 24-indent, cc->label, cc->module);
730
731     fprintf(prof_file, "%8lld  %5.1f %5.1f    %5.1f %5.1f",
732             ccs->scc_count, 
733             total_prof_ticks == 0 ? 0.0 : (ccs->time_ticks / (StgFloat) total_prof_ticks * 100),
734             total_alloc == 0 ? 0.0 : (ccs->mem_alloc / (StgFloat) total_alloc * 100),
735             total_prof_ticks == 0 ? 0.0 : (ccs->inherited_ticks / (StgFloat) total_prof_ticks * 100),
736             total_alloc == 0 ? 0.0 : (ccs->inherited_alloc / (StgFloat) total_alloc * 100)
737             );
738
739     if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
740       fprintf(prof_file, "  %5ld %9lld", ccs->time_ticks, ccs->mem_alloc*sizeof(W_));
741 #if defined(PROFILING_DETAIL_COUNTS)
742       fprintf(prof_file, "  %8ld %8ld %8ld %8ld %8ld %8ld %8ld",
743               ccs->mem_allocs, ccs->thunk_count,
744               ccs->function_count, ccs->pap_count,
745               ccs->subsumed_fun_count,  ccs->subsumed_caf_count,
746               ccs->caffun_subsumed);
747 #endif
748     }
749     fprintf(prof_file, "\n");
750   }
751
752   for (i = ccs->indexTable; i != 0; i = i->next) {
753     if (!i->back_edge) {
754       reportCCS(i->ccs, indent+1);
755     }
756   }
757 }
758
759
760 /* Traverse the cost centre stack tree and accumulate
761  * ticks/allocations.
762  */
763 static void
764 count_ticks(CostCentreStack *ccs)
765 {
766   IndexTable *i;
767   
768   if (!ccs_to_ignore(ccs)) {
769     total_alloc += ccs->mem_alloc;
770     total_prof_ticks += ccs->time_ticks;
771   }
772   for (i = ccs->indexTable; i != NULL; i = i->next)
773     if (!i->back_edge) {
774       count_ticks(i->ccs);
775     }
776 }
777
778 /* Traverse the cost centre stack tree and inherit ticks & allocs.
779  */
780 static void
781 inherit_costs(CostCentreStack *ccs)
782 {
783   IndexTable *i;
784
785   if (ccs_to_ignore(ccs)) { return; }
786
787   ccs->inherited_ticks += ccs->time_ticks;
788   ccs->inherited_alloc += ccs->mem_alloc;
789
790   for (i = ccs->indexTable; i != NULL; i = i->next)
791       if (!i->back_edge) {
792           inherit_costs(i->ccs);
793           ccs->inherited_ticks += i->ccs->inherited_ticks;
794           ccs->inherited_alloc += i->ccs->inherited_alloc;
795       }
796   
797   return;
798 }
799
800 /* return rtsTrue if it is one of the ones that
801  * should not be reported normally (because it confuses
802  * the users)
803  */
804 static rtsBool
805 ccs_to_ignore (CostCentreStack *ccs)
806 {
807     if (    ccs == CCS_OVERHEAD 
808          || ccs == CCS_DONT_CARE
809          || ccs == CCS_GC 
810          || ccs == CCS_SYSTEM) {
811         return rtsTrue;
812     } else {
813         return rtsFalse;
814     }
815 }
816
817 static CostCentreStack *
818 pruneCCSTree( CostCentreStack *ccs )
819 {
820   CostCentreStack *ccs1;
821   IndexTable *i, **prev;
822   
823   prev = &ccs->indexTable;
824   for (i = ccs->indexTable; i != 0; i = i->next) {
825     if (i->back_edge) { continue; }
826
827     ccs1 = pruneCCSTree(i->ccs);
828     if (ccs1 == NULL) {
829       *prev = i->next;
830     } else {
831       prev = &(i->next);
832     }
833   }
834
835   if ( (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL
836         /* force printing of *all* cost centres if -P -P */ )
837        
838        || ( ccs->indexTable != 0 )
839        || ( ccs->scc_count || ccs->time_ticks || ccs->mem_alloc )
840       ) {
841       return ccs;
842   } else {
843       return NULL;
844   }
845 }
846
847 /* -----------------------------------------------------------------------------
848    Generate the XML time/allocation profile
849    -------------------------------------------------------------------------- */
850
851 void
852 gen_XML_logfile( void )
853 {
854   fprintf(prof_file, "%d %lu", TIME_UPD_UQ, total_prof_ticks);
855
856   reportCCS_XML(pruneCCSTree(CCS_MAIN));
857
858   fprintf(prof_file, " 0\n");
859
860   fclose(prof_file);
861 }
862
863 static void 
864 reportCCS_XML(CostCentreStack *ccs)
865 {
866   CostCentre *cc;
867   IndexTable *i;
868
869   if (ccs_to_ignore(ccs)) { return; }
870
871   cc = ccs->cc;
872   
873   fprintf(prof_file, " 1 %d %llu %lu %llu", 
874           ccs->ccsID, ccs->scc_count, ccs->time_ticks, ccs->mem_alloc);
875
876   for (i = ccs->indexTable; i != 0; i = i->next) {
877     if (!i->back_edge) {
878       reportCCS_XML(i->ccs);
879     }
880   }
881 }
882
883 void
884 fprintCCS( FILE *f, CostCentreStack *ccs )
885 {
886   fprintf(f,"<");
887   for (; ccs && ccs != CCS_MAIN; ccs = ccs->prevStack ) {
888       fprintf(f,"%s.%s", ccs->cc->module, ccs->cc->label);
889       if (ccs->prevStack && ccs->prevStack != CCS_MAIN) {
890           fprintf(f,",");
891       }
892   }
893   fprintf(f,">");
894 }
895
896 #endif /* PROFILING */