--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001
+ * Author: Sungwoo Park
+ *
+ * Retainer set implementation for retainer profiling (see RetainerProfile.c)
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef PROFILING
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "Stats.h"
+#include "RtsUtils.h"
+#include "RetainerSet.h"
+#include "Arena.h"
+#include "Profiling.h"
+
+#include <stdlib.h>
+#include <string.h>
+
+#define HASH_TABLE_SIZE 255
+#define hash(hk) (hk % HASH_TABLE_SIZE)
+static RetainerSet *hashTable[HASH_TABLE_SIZE];
+
+static Arena *arena; // arena in which we store retainer sets
+
+static int nextId; // id of next retainer set
+
+/* -----------------------------------------------------------------------------
+ * rs_MANY is a distinguished retainer set, such that
+ *
+ * isMember(e, rs_MANY) = True
+ *
+ * addElement(e, rs) = rs_MANY, if rs->num >= maxRetainerSetSize
+ * addElement(e, rs_MANY) = rs_MANY
+ *
+ * The point of rs_MANY is to keep the total number of retainer sets
+ * from growing too large.
+ * -------------------------------------------------------------------------- */
+RetainerSet rs_MANY = {
+ num : 0,
+ hashKey : 0,
+ link : NULL,
+ id : 1,
+ element : {}
+};
+
+/* -----------------------------------------------------------------------------
+ * calculate the size of a RetainerSet structure
+ * -------------------------------------------------------------------------- */
+STATIC_INLINE size_t
+sizeofRetainerSet( int elems )
+{
+ return (sizeof(RetainerSet) + elems * sizeof(retainer));
+}
+
+/* -----------------------------------------------------------------------------
+ * Creates the first pool and initializes hashTable[].
+ * Frees all pools if any.
+ * -------------------------------------------------------------------------- */
+void
+initializeAllRetainerSet(void)
+{
+ int i;
+
+ arena = newArena();
+
+ for (i = 0; i < HASH_TABLE_SIZE; i++)
+ hashTable[i] = NULL;
+ nextId = 2; // Initial value must be positive, 2 is MANY.
+}
+
+/* -----------------------------------------------------------------------------
+ * Refreshes all pools for reuse and initializes hashTable[].
+ * -------------------------------------------------------------------------- */
+void
+refreshAllRetainerSet(void)
+{
+#ifdef FIRST_APPROACH
+ int i;
+
+ // first approach: completely refresh
+ arenaFree(arena);
+ arena = newArena();
+
+ for (i = 0; i < HASH_TABLE_SIZE; i++)
+ hashTable[i] = NULL;
+ nextId = 2;
+#endif /* FIRST_APPROACH */
+}
+
+/* -----------------------------------------------------------------------------
+ * Frees all pools.
+ * -------------------------------------------------------------------------- */
+void
+closeAllRetainerSet(void)
+{
+ arenaFree(arena);
+}
+
+/* -----------------------------------------------------------------------------
+ * Finds or creates if needed a singleton retainer set.
+ * -------------------------------------------------------------------------- */
+RetainerSet *
+singleton(retainer r)
+{
+ RetainerSet *rs;
+ StgWord hk;
+
+ hk = hashKeySingleton(r);
+ for (rs = hashTable[hash(hk)]; rs != NULL; rs = rs->link)
+ if (rs->num == 1 && rs->element[0] == r) return rs; // found it
+
+ // create it
+ rs = arenaAlloc( arena, sizeofRetainerSet(1) );
+ rs->num = 1;
+ rs->hashKey = hk;
+ rs->link = hashTable[hash(hk)];
+ rs->id = nextId++;
+ rs->element[0] = r;
+
+ // The new retainer set is placed at the head of the linked list.
+ hashTable[hash(hk)] = rs;
+
+ return rs;
+}
+
+/* -----------------------------------------------------------------------------
+ * Finds or creates a retainer set *rs augmented with r.
+ * Invariants:
+ * r is not a member of rs, i.e., isMember(r, rs) returns rtsFalse.
+ * rs is not NULL.
+ * Note:
+ * We could check if rs is NULL, in which case this function call
+ * reverts to singleton(). We do not choose this strategy because
+ * in most cases addElement() is invoked with non-NULL rs.
+ * -------------------------------------------------------------------------- */
+RetainerSet *
+addElement(retainer r, RetainerSet *rs)
+{
+ nat i;
+ nat nl; // Number of retainers in *rs Less than r
+ RetainerSet *nrs; // New Retainer Set
+ StgWord hk; // Hash Key
+
+#ifdef DEBUG_RETAINER
+ // debugBelch("addElement(%p, %p) = ", r, rs);
+#endif
+
+ ASSERT(rs != NULL);
+ ASSERT(rs->num <= RtsFlags.ProfFlags.maxRetainerSetSize);
+
+ if (rs == &rs_MANY || rs->num == RtsFlags.ProfFlags.maxRetainerSetSize) {
+ return &rs_MANY;
+ }
+
+ ASSERT(!isMember(r, rs));
+
+ for (nl = 0; nl < rs->num; nl++)
+ if (r < rs->element[nl]) break;
+ // Now nl is the index for r into the new set.
+ // Also it denotes the number of retainers less than r in *rs.
+ // Thus, compare the first nl retainers, then r itself, and finally the
+ // remaining (rs->num - nl) retainers.
+
+ hk = hashKeyAddElement(r, rs);
+ for (nrs = hashTable[hash(hk)]; nrs != NULL; nrs = nrs->link) {
+ // test *rs and *nrs for equality
+
+ // check their size
+ if (rs->num + 1 != nrs->num) continue;
+
+ // compare the first nl retainers and find the first non-matching one.
+ for (i = 0; i < nl; i++)
+ if (rs->element[i] != nrs->element[i]) break;
+ if (i < nl) continue;
+
+ // compare r itself
+ if (r != nrs->element[i]) continue; // i == nl
+
+ // compare the remaining retainers
+ for (; i < rs->num; i++)
+ if (rs->element[i] != nrs->element[i + 1]) break;
+ if (i < rs->num) continue;
+
+#ifdef DEBUG_RETAINER
+ // debugBelch("%p\n", nrs);
+#endif
+ // The set we are seeking already exists!
+ return nrs;
+ }
+
+ // create a new retainer set
+ nrs = arenaAlloc( arena, sizeofRetainerSet(rs->num + 1) );
+ nrs->num = rs->num + 1;
+ nrs->hashKey = hk;
+ nrs->link = hashTable[hash(hk)];
+ nrs->id = nextId++;
+ for (i = 0; i < nl; i++) { // copy the first nl retainers
+ nrs->element[i] = rs->element[i];
+ }
+ nrs->element[i] = r; // copy r
+ for (; i < rs->num; i++) { // copy the remaining retainers
+ nrs->element[i + 1] = rs->element[i];
+ }
+
+ hashTable[hash(hk)] = nrs;
+
+#ifdef DEBUG_RETAINER
+ // debugBelch("%p\n", nrs);
+#endif
+ return nrs;
+}
+
+/* -----------------------------------------------------------------------------
+ * Call f() for each retainer set.
+ * -------------------------------------------------------------------------- */
+void
+traverseAllRetainerSet(void (*f)(RetainerSet *))
+{
+ int i;
+ RetainerSet *rs;
+
+ (*f)(&rs_MANY);
+ for (i = 0; i < HASH_TABLE_SIZE; i++)
+ for (rs = hashTable[i]; rs != NULL; rs = rs->link)
+ (*f)(rs);
+}
+
+
+/* -----------------------------------------------------------------------------
+ * printRetainer() prints the full information on a given retainer,
+ * not a retainer set.
+ * -------------------------------------------------------------------------- */
+#if defined(RETAINER_SCHEME_INFO)
+// Retainer scheme 1: retainer = info table
+void
+printRetainer(FILE *f, retainer itbl)
+{
+ fprintf(f, "%s[%s]", itbl->prof.closure_desc, itbl->prof.closure_type);
+}
+#elif defined(RETAINER_SCHEME_CCS)
+// Retainer scheme 2: retainer = cost centre stack
+void
+printRetainer(FILE *f, retainer ccs)
+{
+ fprintCCS(f, ccs);
+}
+#elif defined(RETAINER_SCHEME_CC)
+// Retainer scheme 3: retainer = cost centre
+void
+printRetainer(FILE *f, retainer cc)
+{
+ fprintf(f,"%s.%s", cc->module, cc->label);
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ * printRetainerSetShort() should always display the same output for
+ * a given retainer set regardless of the time of invocation.
+ * -------------------------------------------------------------------------- */
+#ifdef SECOND_APPROACH
+#if defined(RETAINER_SCHEME_INFO)
+// Retainer scheme 1: retainer = info table
+void
+printRetainerSetShort(FILE *f, RetainerSet *rs)
+{
+#define MAX_RETAINER_SET_SPACE 24
+ char tmp[MAX_RETAINER_SET_SPACE + 1];
+ int size;
+ nat j;
+
+ ASSERT(rs->id < 0);
+
+ tmp[MAX_RETAINER_SET_SPACE] = '\0';
+
+ // No blank characters are allowed.
+ sprintf(tmp + 0, "(%d)", -(rs->id));
+ size = strlen(tmp);
+ ASSERT(size < MAX_RETAINER_SET_SPACE);
+
+ for (j = 0; j < rs->num; j++) {
+ if (j < rs->num - 1) {
+ strncpy(tmp + size, rs->element[j]->prof.closure_desc, MAX_RETAINER_SET_SPACE - size);
+ size = strlen(tmp);
+ if (size == MAX_RETAINER_SET_SPACE)
+ break;
+ strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ size = strlen(tmp);
+ if (size == MAX_RETAINER_SET_SPACE)
+ break;
+ }
+ else {
+ strncpy(tmp + size, rs->element[j]->prof.closure_desc, MAX_RETAINER_SET_SPACE - size);
+ // size = strlen(tmp);
+ }
+ }
+ fprintf(f, tmp);
+}
+#elif defined(RETAINER_SCHEME_CC)
+// Retainer scheme 3: retainer = cost centre
+void
+printRetainerSetShort(FILE *f, RetainerSet *rs)
+{
+#define MAX_RETAINER_SET_SPACE 24
+ char tmp[MAX_RETAINER_SET_SPACE + 1];
+ int size;
+ nat j;
+
+}
+#elif defined(RETAINER_SCHEME_CCS)
+// Retainer scheme 2: retainer = cost centre stack
+void
+printRetainerSetShort(FILE *f, RetainerSet *rs)
+{
+#define MAX_RETAINER_SET_SPACE 24
+ char tmp[MAX_RETAINER_SET_SPACE + 1];
+ int size;
+ nat j;
+
+ ASSERT(rs->id < 0);
+
+ tmp[MAX_RETAINER_SET_SPACE] = '\0';
+
+ // No blank characters are allowed.
+ sprintf(tmp + 0, "(%d)", -(rs->id));
+ size = strlen(tmp);
+ ASSERT(size < MAX_RETAINER_SET_SPACE);
+
+ for (j = 0; j < rs->num; j++) {
+ if (j < rs->num - 1) {
+ strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+ size = strlen(tmp);
+ if (size == MAX_RETAINER_SET_SPACE)
+ break;
+ strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ size = strlen(tmp);
+ if (size == MAX_RETAINER_SET_SPACE)
+ break;
+ }
+ else {
+ strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+ // size = strlen(tmp);
+ }
+ }
+ fprintf(f, tmp);
+}
+#elif defined(RETAINER_SCHEME_CC)
+// Retainer scheme 3: retainer = cost centre
+static void
+printRetainerSetShort(FILE *f, retainerSet *rs)
+{
+#define MAX_RETAINER_SET_SPACE 24
+ char tmp[MAX_RETAINER_SET_SPACE + 1];
+ int size;
+ nat j;
+
+ ASSERT(rs->id < 0);
+
+ tmp[MAX_RETAINER_SET_SPACE] = '\0';
+
+ // No blank characters are allowed.
+ sprintf(tmp + 0, "(%d)", -(rs->id));
+ size = strlen(tmp);
+ ASSERT(size < MAX_RETAINER_SET_SPACE);
+
+ for (j = 0; j < rs->num; j++) {
+ if (j < rs->num - 1) {
+ strncpy(tmp + size, rs->element[j]->label,
+ MAX_RETAINER_SET_SPACE - size);
+ size = strlen(tmp);
+ if (size == MAX_RETAINER_SET_SPACE)
+ break;
+ strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ size = strlen(tmp);
+ if (size == MAX_RETAINER_SET_SPACE)
+ break;
+ }
+ else {
+ strncpy(tmp + size, rs->element[j]->label,
+ MAX_RETAINER_SET_SPACE - size);
+ // size = strlen(tmp);
+ }
+ }
+ fprintf(f, tmp);
+/*
+ #define MAX_RETAINER_SET_SPACE 24
+ #define DOT_NUMBER 3
+ // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0')
+ // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for
+ // printing one natural number (plus '(' and ')').
+ char tmp[32];
+ int size, ts;
+ nat j;
+
+ ASSERT(rs->id < 0);
+
+ // No blank characters are allowed.
+ sprintf(tmp + 0, "(%d)", -(rs->id));
+ size = strlen(tmp);
+ ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER);
+
+ for (j = 0; j < rs->num; j++) {
+ ts = strlen(rs->element[j]->label);
+ if (j < rs->num - 1) {
+ if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ sprintf(tmp + size, "...");
+ break;
+ }
+ sprintf(tmp + size, "%s,", rs->element[j]->label);
+ size += ts + 1;
+ }
+ else {
+ if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ sprintf(tmp + size, "...");
+ break;
+ }
+ sprintf(tmp + size, "%s", rs->element[j]->label);
+ size += ts;
+ }
+ }
+ fprintf(f, tmp);
+*/
+}
+#endif /* RETAINER_SCHEME_CC */
+#endif /* SECOND_APPROACH */
+
+/* -----------------------------------------------------------------------------
+ * Dump the contents of each retainer set into the log file at the end
+ * of the run, so the user can find out for a given retainer set ID
+ * the full contents of that set.
+ * --------------------------------------------------------------------------- */
+#ifdef SECOND_APPROACH
+void
+outputAllRetainerSet(FILE *prof_file)
+{
+ nat i, j;
+ nat numSet;
+ RetainerSet *rs, **rsArray, *tmp;
+
+ // find out the number of retainer sets which have had a non-zero cost at
+ // least once during retainer profiling
+ numSet = 0;
+ for (i = 0; i < HASH_TABLE_SIZE; i++)
+ for (rs = hashTable[i]; rs != NULL; rs = rs->link) {
+ if (rs->id < 0)
+ numSet++;
+ }
+
+ if (numSet == 0) // retainer profiling was not done at all.
+ return;
+
+ // allocate memory
+ rsArray = stgMallocBytes(numSet * sizeof(RetainerSet *),
+ "outputAllRetainerSet()");
+
+ // prepare for sorting
+ j = 0;
+ for (i = 0; i < HASH_TABLE_SIZE; i++)
+ for (rs = hashTable[i]; rs != NULL; rs = rs->link) {
+ if (rs->id < 0) {
+ rsArray[j] = rs;
+ j++;
+ }
+ }
+
+ ASSERT(j == numSet);
+
+ // sort rsArray[] according to the id of each retainer set
+ for (i = numSet - 1; i > 0; i--) {
+ for (j = 0; j <= i - 1; j++) {
+ // if (-(rsArray[j]->id) < -(rsArray[j + 1]->id))
+ if (rsArray[j]->id < rsArray[j + 1]->id) {
+ tmp = rsArray[j];
+ rsArray[j] = rsArray[j + 1];
+ rsArray[j + 1] = tmp;
+ }
+ }
+ }
+
+ fprintf(prof_file, "\nRetainer sets created during profiling:\n");
+ for (i = 0;i < numSet; i++) {
+ fprintf(prof_file, "SET %u = {", -(rsArray[i]->id));
+ for (j = 0; j < rsArray[i]->num - 1; j++) {
+ printRetainer(prof_file, rsArray[i]->element[j]);
+ fprintf(prof_file, ", ");
+ }
+ printRetainer(prof_file, rsArray[i]->element[j]);
+ fprintf(prof_file, "}\n");
+ }
+
+ stgFree(rsArray);
+}
+#endif /* SECOND_APPROACH */
+
+#endif /* PROFILING */
projects / ghc-hetmet.git / blobdiff