rts_stop_on_exception is a C int, not a W_
[ghc-hetmet.git] / rts / RetainerSet.c
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 2001
4  * Author: Sungwoo Park
5  *
6  * Retainer set implementation for retainer profiling (see RetainerProfile.c)
7  *
8  * ---------------------------------------------------------------------------*/
9
10 #ifdef PROFILING
11
12 #include "Rts.h"
13 #include "RtsFlags.h"
14 #include "Stats.h"
15 #include "RtsUtils.h"
16 #include "RetainerSet.h"
17 #include "Arena.h"
18 #include "Profiling.h"
19
20 #include <stdlib.h>
21 #include <string.h>
22
23 #define HASH_TABLE_SIZE 255
24 #define hash(hk)  (hk % HASH_TABLE_SIZE)
25 static RetainerSet *hashTable[HASH_TABLE_SIZE];
26
27 static Arena *arena;            // arena in which we store retainer sets
28
29 static int nextId;              // id of next retainer set       
30
31 /* -----------------------------------------------------------------------------
32  * rs_MANY is a distinguished retainer set, such that
33  *
34  *        isMember(e, rs_MANY)   = True
35  *
36  *        addElement(e, rs)      = rs_MANY,   if rs->num >= maxRetainerSetSize
37  *        addElement(e, rs_MANY) = rs_MANY
38  *
39  * The point of rs_MANY is to keep the total number of retainer sets
40  * from growing too large.
41  * -------------------------------------------------------------------------- */
42 RetainerSet rs_MANY = {
43     num : 0,
44     hashKey : 0,
45     link : NULL,
46     id : 1,
47     element : {}
48 };
49
50 /* -----------------------------------------------------------------------------
51  * calculate the size of a RetainerSet structure
52  * -------------------------------------------------------------------------- */
53 STATIC_INLINE size_t
54 sizeofRetainerSet( int elems )
55 {
56     return (sizeof(RetainerSet) + elems * sizeof(retainer));
57 }
58
59 /* -----------------------------------------------------------------------------
60  * Creates the first pool and initializes hashTable[].
61  * Frees all pools if any.
62  * -------------------------------------------------------------------------- */
63 void
64 initializeAllRetainerSet(void)
65 {
66     int i;
67
68     arena = newArena();
69
70     for (i = 0; i < HASH_TABLE_SIZE; i++)
71         hashTable[i] = NULL;
72     nextId = 2;   // Initial value must be positive, 2 is MANY.
73 }
74
75 /* -----------------------------------------------------------------------------
76  * Refreshes all pools for reuse and initializes hashTable[].
77  * -------------------------------------------------------------------------- */
78 void
79 refreshAllRetainerSet(void)
80 {
81 #ifdef FIRST_APPROACH
82     int i;
83
84     // first approach: completely refresh
85     arenaFree(arena);
86     arena = newArena();
87
88     for (i = 0; i < HASH_TABLE_SIZE; i++)
89         hashTable[i] = NULL;
90     nextId = 2;
91 #endif /* FIRST_APPROACH */
92 }
93
94 /* -----------------------------------------------------------------------------
95  * Frees all pools.
96  * -------------------------------------------------------------------------- */
97 void
98 closeAllRetainerSet(void)
99 {
100     arenaFree(arena);
101 }
102
103 /* -----------------------------------------------------------------------------
104  *  Finds or creates if needed a singleton retainer set.
105  * -------------------------------------------------------------------------- */
106 RetainerSet *
107 singleton(retainer r)
108 {
109     RetainerSet *rs;
110     StgWord hk;
111
112     hk = hashKeySingleton(r);
113     for (rs = hashTable[hash(hk)]; rs != NULL; rs = rs->link)
114         if (rs->num == 1 &&  rs->element[0] == r) return rs;    // found it
115
116     // create it
117     rs = arenaAlloc( arena, sizeofRetainerSet(1) );
118     rs->num = 1;
119     rs->hashKey = hk;
120     rs->link = hashTable[hash(hk)];
121     rs->id = nextId++;
122     rs->element[0] = r;
123
124     // The new retainer set is placed at the head of the linked list.
125     hashTable[hash(hk)] = rs;
126
127     return rs;
128 }
129
130 /* -----------------------------------------------------------------------------
131  *   Finds or creates a retainer set *rs augmented with r.
132  *   Invariants:
133  *     r is not a member of rs, i.e., isMember(r, rs) returns rtsFalse.
134  *     rs is not NULL.
135  *   Note:
136  *     We could check if rs is NULL, in which case this function call
137  *     reverts to singleton(). We do not choose this strategy because
138  *     in most cases addElement() is invoked with non-NULL rs.
139  * -------------------------------------------------------------------------- */
140 RetainerSet *
141 addElement(retainer r, RetainerSet *rs)
142 {
143     nat i;
144     nat nl;             // Number of retainers in *rs Less than r
145     RetainerSet *nrs;   // New Retainer Set
146     StgWord hk;         // Hash Key
147
148 #ifdef DEBUG_RETAINER
149     // debugBelch("addElement(%p, %p) = ", r, rs);
150 #endif
151
152     ASSERT(rs != NULL);
153     ASSERT(rs->num <= RtsFlags.ProfFlags.maxRetainerSetSize);
154
155     if (rs == &rs_MANY || rs->num == RtsFlags.ProfFlags.maxRetainerSetSize) {
156         return &rs_MANY;
157     }
158
159     ASSERT(!isMember(r, rs));
160
161     for (nl = 0; nl < rs->num; nl++)
162         if (r < rs->element[nl]) break;
163     // Now nl is the index for r into the new set.
164     // Also it denotes the number of retainers less than r in *rs.
165     // Thus, compare the first nl retainers, then r itself, and finally the
166     // remaining (rs->num - nl) retainers.
167
168     hk = hashKeyAddElement(r, rs);
169     for (nrs = hashTable[hash(hk)]; nrs != NULL; nrs = nrs->link) {
170         // test *rs and *nrs for equality
171
172         // check their size
173         if (rs->num + 1 != nrs->num) continue;
174
175         // compare the first nl retainers and find the first non-matching one.
176         for (i = 0; i < nl; i++)
177             if (rs->element[i] != nrs->element[i]) break;
178         if (i < nl) continue;
179
180         // compare r itself
181         if (r != nrs->element[i]) continue;       // i == nl
182
183         // compare the remaining retainers
184         for (; i < rs->num; i++)
185             if (rs->element[i] != nrs->element[i + 1]) break;
186         if (i < rs->num) continue;
187
188 #ifdef DEBUG_RETAINER
189         // debugBelch("%p\n", nrs);
190 #endif
191         // The set we are seeking already exists!
192         return nrs;
193     }
194
195     // create a new retainer set
196     nrs = arenaAlloc( arena, sizeofRetainerSet(rs->num + 1) );
197     nrs->num = rs->num + 1;
198     nrs->hashKey = hk;
199     nrs->link = hashTable[hash(hk)];
200     nrs->id = nextId++;
201     for (i = 0; i < nl; i++) {              // copy the first nl retainers
202         nrs->element[i] = rs->element[i];
203     }
204     nrs->element[i] = r;                    // copy r
205     for (; i < rs->num; i++) {              // copy the remaining retainers
206         nrs->element[i + 1] = rs->element[i];
207     }
208
209     hashTable[hash(hk)] = nrs;
210
211 #ifdef DEBUG_RETAINER
212     // debugBelch("%p\n", nrs);
213 #endif
214     return nrs;
215 }
216
217 /* -----------------------------------------------------------------------------
218  *  Call f() for each retainer set.
219  * -------------------------------------------------------------------------- */
220 void
221 traverseAllRetainerSet(void (*f)(RetainerSet *))
222 {
223     int i;
224     RetainerSet *rs;
225
226     (*f)(&rs_MANY);
227     for (i = 0; i < HASH_TABLE_SIZE; i++)
228         for (rs = hashTable[i]; rs != NULL; rs = rs->link)
229             (*f)(rs);
230 }
231
232
233 /* -----------------------------------------------------------------------------
234  *  printRetainer() prints the full information on a given retainer,
235  *  not a retainer set.
236  * -------------------------------------------------------------------------- */
237 #if defined(RETAINER_SCHEME_INFO)
238 // Retainer scheme 1: retainer = info table
239 void
240 printRetainer(FILE *f, retainer itbl)
241 {
242     fprintf(f, "%s[%s]", GET_PROF_DESC(itbl), itbl->prof.closure_type);
243 }
244 #elif defined(RETAINER_SCHEME_CCS)
245 // Retainer scheme 2: retainer = cost centre stack
246 void
247 printRetainer(FILE *f, retainer ccs)
248 {
249     fprintCCS(f, ccs);
250 }
251 #elif defined(RETAINER_SCHEME_CC)
252 // Retainer scheme 3: retainer = cost centre
253 void
254 printRetainer(FILE *f, retainer cc)
255 {
256     fprintf(f,"%s.%s", cc->module, cc->label);
257 }
258 #endif
259
260 /* -----------------------------------------------------------------------------
261  *  printRetainerSetShort() should always display the same output for
262  *  a given retainer set regardless of the time of invocation.
263  * -------------------------------------------------------------------------- */
264 #ifdef SECOND_APPROACH
265 #if defined(RETAINER_SCHEME_INFO)
266 // Retainer scheme 1: retainer = info table
267 void
268 printRetainerSetShort(FILE *f, RetainerSet *rs)
269 {
270 #define MAX_RETAINER_SET_SPACE  24
271     char tmp[MAX_RETAINER_SET_SPACE + 1];
272     int size;
273     nat j;
274
275     ASSERT(rs->id < 0);
276
277     tmp[MAX_RETAINER_SET_SPACE] = '\0';
278
279     // No blank characters are allowed.
280     sprintf(tmp + 0, "(%d)", -(rs->id));
281     size = strlen(tmp);
282     ASSERT(size < MAX_RETAINER_SET_SPACE);
283
284     for (j = 0; j < rs->num; j++) {
285         if (j < rs->num - 1) {
286             strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
287             size = strlen(tmp);
288             if (size == MAX_RETAINER_SET_SPACE)
289                 break;
290             strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
291             size = strlen(tmp);
292             if (size == MAX_RETAINER_SET_SPACE)
293                 break;
294         }
295         else {
296             strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
297             // size = strlen(tmp);
298         }
299     }
300     fprintf(f, tmp);
301 }
302 #elif defined(RETAINER_SCHEME_CC)
303 // Retainer scheme 3: retainer = cost centre
304 void
305 printRetainerSetShort(FILE *f, RetainerSet *rs)
306 {
307 #define MAX_RETAINER_SET_SPACE  24
308     char tmp[MAX_RETAINER_SET_SPACE + 1];
309     int size;
310     nat j;
311
312 }
313 #elif defined(RETAINER_SCHEME_CCS)
314 // Retainer scheme 2: retainer = cost centre stack
315 void
316 printRetainerSetShort(FILE *f, RetainerSet *rs)
317 {
318 #define MAX_RETAINER_SET_SPACE  24
319     char tmp[MAX_RETAINER_SET_SPACE + 1];
320     int size;
321     nat j;
322
323     ASSERT(rs->id < 0);
324
325     tmp[MAX_RETAINER_SET_SPACE] = '\0';
326
327     // No blank characters are allowed.
328     sprintf(tmp + 0, "(%d)", -(rs->id));
329     size = strlen(tmp);
330     ASSERT(size < MAX_RETAINER_SET_SPACE);
331
332     for (j = 0; j < rs->num; j++) {
333         if (j < rs->num - 1) {
334             strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
335             size = strlen(tmp);
336             if (size == MAX_RETAINER_SET_SPACE)
337                 break;
338             strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
339             size = strlen(tmp);
340             if (size == MAX_RETAINER_SET_SPACE)
341                 break;
342         }
343         else {
344             strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
345             // size = strlen(tmp);
346         }
347     }
348     fputs(tmp, f);
349 }
350 #elif defined(RETAINER_SCHEME_CC)
351 // Retainer scheme 3: retainer = cost centre
352 static void
353 printRetainerSetShort(FILE *f, retainerSet *rs)
354 {
355 #define MAX_RETAINER_SET_SPACE  24
356     char tmp[MAX_RETAINER_SET_SPACE + 1];
357     int size;
358     nat j;
359
360     ASSERT(rs->id < 0);
361
362     tmp[MAX_RETAINER_SET_SPACE] = '\0';
363
364     // No blank characters are allowed.
365     sprintf(tmp + 0, "(%d)", -(rs->id));
366     size = strlen(tmp);
367     ASSERT(size < MAX_RETAINER_SET_SPACE);
368
369     for (j = 0; j < rs->num; j++) {
370         if (j < rs->num - 1) {
371             strncpy(tmp + size, rs->element[j]->label,
372                     MAX_RETAINER_SET_SPACE - size);
373             size = strlen(tmp);
374             if (size == MAX_RETAINER_SET_SPACE)
375                 break;
376             strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
377             size = strlen(tmp);
378             if (size == MAX_RETAINER_SET_SPACE)
379                 break;
380         }
381         else {
382             strncpy(tmp + size, rs->element[j]->label,
383                     MAX_RETAINER_SET_SPACE - size);
384             // size = strlen(tmp);
385         }
386     }
387     fprintf(f, tmp);
388 /*
389   #define MAX_RETAINER_SET_SPACE  24
390   #define DOT_NUMBER              3
391   // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0')
392   // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for
393   //    printing one natural number (plus '(' and ')').
394   char tmp[32];
395   int size, ts;
396   nat j;
397
398   ASSERT(rs->id < 0);
399
400   // No blank characters are allowed.
401   sprintf(tmp + 0, "(%d)", -(rs->id));
402   size = strlen(tmp);
403   ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER);
404
405   for (j = 0; j < rs->num; j++) {
406     ts = strlen(rs->element[j]->label);
407     if (j < rs->num - 1) {
408       if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
409         sprintf(tmp + size, "...");
410         break;
411       }
412       sprintf(tmp + size, "%s,", rs->element[j]->label);
413       size += ts + 1;
414     }
415     else {
416       if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
417         sprintf(tmp + size, "...");
418         break;
419       }
420       sprintf(tmp + size, "%s", rs->element[j]->label);
421       size += ts;
422     }
423   }
424   fprintf(f, tmp);
425 */
426 }
427 #endif /* RETAINER_SCHEME_CC */
428 #endif /* SECOND_APPROACH */
429
430 /* -----------------------------------------------------------------------------
431  * Dump the contents of each retainer set into the log file at the end
432  * of the run, so the user can find out for a given retainer set ID
433  * the full contents of that set.
434  * --------------------------------------------------------------------------- */
435 #ifdef SECOND_APPROACH
436 void
437 outputAllRetainerSet(FILE *prof_file)
438 {
439     nat i, j;
440     nat numSet;
441     RetainerSet *rs, **rsArray, *tmp;
442
443     // find out the number of retainer sets which have had a non-zero cost at
444     // least once during retainer profiling
445     numSet = 0;
446     for (i = 0; i < HASH_TABLE_SIZE; i++)
447         for (rs = hashTable[i]; rs != NULL; rs = rs->link) {
448             if (rs->id < 0)
449                 numSet++;
450         }
451
452     if (numSet == 0)      // retainer profiling was not done at all.
453         return;
454
455     // allocate memory
456     rsArray = stgMallocBytes(numSet * sizeof(RetainerSet *),
457                              "outputAllRetainerSet()");
458
459     // prepare for sorting
460     j = 0;
461     for (i = 0; i < HASH_TABLE_SIZE; i++)
462         for (rs = hashTable[i]; rs != NULL; rs = rs->link) {
463             if (rs->id < 0) {
464                 rsArray[j] = rs;
465                 j++;
466             }
467         }
468
469     ASSERT(j == numSet);
470
471     // sort rsArray[] according to the id of each retainer set
472     for (i = numSet - 1; i > 0; i--) {
473         for (j = 0; j <= i - 1; j++) {
474             // if (-(rsArray[j]->id) < -(rsArray[j + 1]->id))
475             if (rsArray[j]->id < rsArray[j + 1]->id) {
476                 tmp = rsArray[j];
477                 rsArray[j] = rsArray[j + 1];
478                 rsArray[j + 1] = tmp;
479             }
480         }
481     }
482
483     fprintf(prof_file, "\nRetainer sets created during profiling:\n");
484     for (i = 0;i < numSet; i++) {
485         fprintf(prof_file, "SET %u = {", -(rsArray[i]->id));
486         for (j = 0; j < rsArray[i]->num - 1; j++) {
487             printRetainer(prof_file, rsArray[i]->element[j]);
488             fprintf(prof_file, ", ");
489         }
490         printRetainer(prof_file, rsArray[i]->element[j]);
491         fprintf(prof_file, "}\n");
492     }
493
494     stgFree(rsArray);
495 }
496 #endif /* SECOND_APPROACH */
497
498 #endif /* PROFILING */