Hpc.c 9.8 KB
Newer Older
andy@galois.com's avatar
andy@galois.com committed
1
2
3
4
/*
 * (c)2006 Galois Connections, Inc.
 */ 

Simon Marlow's avatar
Simon Marlow committed
5
6
7
8
#include "PosixSource.h"
#include "Rts.h"

#include "Trace.h"
9
10
#include "Hash.h"
#include "RtsUtils.h"
Simon Marlow's avatar
Simon Marlow committed
11

andy@galois.com's avatar
andy@galois.com committed
12
13
14
15
#include <stdio.h>
#include <ctype.h>
#include <string.h>
#include <assert.h>
andy@galois.com's avatar
andy@galois.com committed
16

17
18
19
20
21
22
23
24
#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif

#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif

25
26
27
28
29
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif


andy@galois.com's avatar
andy@galois.com committed
30
31
32
33
34
/* This is the runtime support for the Haskell Program Coverage (hpc) toolkit,
 * inside GHC.
 *
 */

35
static int hpc_inited = 0;		// Have you started this component?
36
37
static pid_t hpc_pid = 0;		// pid of this process at hpc-boot time.
					// Only this pid will read or write .tix file(s).
38
39
static FILE *tixFile;			// file being read/written
static int tix_ch;			// current char
andy@galois.com's avatar
andy@galois.com committed
40

41
42
static HashTable * moduleHash = NULL;   // module name -> HpcModuleInfo

43
HpcModuleInfo *modules = 0;
andy@galois.com's avatar
andy@galois.com committed
44

45
static char *tixFilename = NULL;
andy@galois.com's avatar
andy@galois.com committed
46

Simon Marlow's avatar
Simon Marlow committed
47
48
static void GNU_ATTRIBUTE(__noreturn__)
failure(char *msg) {
49
  debugTrace(DEBUG_hpc,"hpc failure: %s\n",msg);
50
  fprintf(stderr,"Hpc failure: %s\n",msg);
51
52
53
54
55
  if (tixFilename) {
    fprintf(stderr,"(perhaps remove %s file?)\n",tixFilename);
  } else {
    fprintf(stderr,"(perhaps remove .tix file?)\n");
  }
56
  stg_exit(1);
andy@galois.com's avatar
andy@galois.com committed
57
58
}

59
60
static int init_open(FILE *file) {
  tixFile = file;
andy@galois.com's avatar
andy@galois.com committed
61
62
63
64
65
66
67
68
69
 if (tixFile == 0) {
    return 0;
  }
  tix_ch = getc(tixFile);
  return 1;
}

static void expect(char c) {
  if (tix_ch != c) {
70
    fprintf(stderr,"('%c' '%c')\n",tix_ch,c);
71
    failure("parse error when reading .tix file");
andy@galois.com's avatar
andy@galois.com committed
72
73
74
75
76
77
78
79
80
81
82
  }
  tix_ch = getc(tixFile);
}

static void ws(void) {
  while (tix_ch == ' ') {
    tix_ch = getc(tixFile);
  }
}

static char *expectString(void) {
83
  char tmp[256], *res; // XXX
andy@galois.com's avatar
andy@galois.com committed
84
85
86
87
88
89
90
91
  int tmp_ix = 0;
  expect('"');
  while (tix_ch != '"') {
    tmp[tmp_ix++] = tix_ch;
    tix_ch = getc(tixFile);
  }
  tmp[tmp_ix++] = 0;
  expect('"');
92
  res = stgMallocBytes(tmp_ix,"Hpc.expectString");
andy@galois.com's avatar
andy@galois.com committed
93
94
95
96
97
98
99
100
101
102
103
104
105
  strcpy(res,tmp);
  return res;
}

static StgWord64 expectWord64(void) {
  StgWord64 tmp = 0;
  while (isdigit(tix_ch)) {
    tmp = tmp * 10 + (tix_ch -'0');
    tix_ch = getc(tixFile);
  }
  return tmp;
}

106
107
static void
readTix(void) {
108
  unsigned int i;
109
  HpcModuleInfo *tmpModule, *lookup;
andy@galois.com's avatar
andy@galois.com committed
110

111
112
113
114
115
116
117
118
119
  ws();
  expect('T');
  expect('i');
  expect('x');
  ws();
  expect('[');
  ws();
  
  while(tix_ch != ']') {
120
121
122
    tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo),
                                                "Hpc.readTix");
    tmpModule->from_file = rtsTrue;
andy@galois.com's avatar
andy@galois.com committed
123
124
125
    expect('T');
    expect('i');
    expect('x');
126
127
128
129
130
131
132
133
134
135
136
137
138
    expect('M');
    expect('o');
    expect('d');
    expect('u');
    expect('l');
    expect('e');
    ws();
    tmpModule -> modName = expectString();
    ws();
    tmpModule -> hashNo = (unsigned int)expectWord64();
    ws();
    tmpModule -> tickCount = (int)expectWord64();
    tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));
andy@galois.com's avatar
andy@galois.com committed
139
140
141
    ws();
    expect('[');
    ws();
142
143
    for(i = 0;i < tmpModule->tickCount;i++) {
      tmpModule->tixArr[i] = expectWord64();
144
      ws();
andy@galois.com's avatar
andy@galois.com committed
145
146
147
      if (tix_ch == ',') {
	expect(',');
	ws();
148
149
      }
    }
andy@galois.com's avatar
andy@galois.com committed
150
    expect(']');
151
152
    ws();
    
153
    lookup = lookupHashTable(moduleHash, (StgWord)tmpModule->modName);
154
    if (lookup == NULL) {
155
156
157
        debugTrace(DEBUG_hpc,"readTix: new HpcModuleInfo for %s",
                   tmpModule->modName);
        insertHashTable(moduleHash, (StgWord)tmpModule->modName, tmpModule);
158
    } else {
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
        ASSERT(lookup->tixArr != 0);
        ASSERT(!strcmp(tmpModule->modName, lookup->modName));
        debugTrace(DEBUG_hpc,"readTix: existing HpcModuleInfo for %s",
                   tmpModule->modName);
        if (tmpModule->hashNo != lookup->hashNo) {
            fprintf(stderr,"in module '%s'\n",tmpModule->modName);
            failure("module mismatch with .tix/.mix file hash number");
            if (tixFilename != NULL) {
                fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
            }
            stg_exit(EXIT_FAILURE);
        }
        for (i=0; i < tmpModule->tickCount; i++) {
            lookup->tixArr[i] = tmpModule->tixArr[i];
        }
        stgFree(tmpModule->tixArr);
        stgFree(tmpModule->modName);
        stgFree(tmpModule);
177
    }
178

179
180
181
182
183
184
185
186
187
    if (tix_ch == ',') {
      expect(',');
      ws();
    }
  }
  expect(']');
  fclose(tixFile);
}

188
189
190
void
startupHpc(void)
{
191
  char *hpc_tixdir;
192
  char *hpc_tixfile;
193
194
195
196
197
198
199

  if (moduleHash == NULL) {
      // no modules were registered with hs_hpc_module, so don't bother
      // creating the .tix file.
      return;
  }

200
201
202
203
  if (hpc_inited != 0) {
    return;
  }
  hpc_inited = 1;
204
  hpc_pid    = getpid();
205
  hpc_tixdir = getenv("HPCTIXDIR");
206
  hpc_tixfile = getenv("HPCTIXFILE");
207

208
209
  debugTrace(DEBUG_hpc,"startupHpc");

210
211
212
213
214
  /* XXX Check results of mallocs/strdups, and check we are requesting
         enough bytes */
  if (hpc_tixfile != NULL) {
    tixFilename = strdup(hpc_tixfile);
  } else if (hpc_tixdir != NULL) {
215
216
    /* Make sure the directory is present;
     * conditional code for mkdir lifted from lndir.c
217
     */
218
219
220
#ifdef WIN32
    mkdir(hpc_tixdir);
#else
221
    mkdir(hpc_tixdir,0777);
222
#endif
223
224
    /* Then, try open the file
     */
225
226
227
    tixFilename = (char *) stgMallocBytes(strlen(hpc_tixdir) +
                                          strlen(prog_name) + 12,
                                          "Hpc.startupHpc");
228
    sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid);
229
  } else {
230
231
    tixFilename = (char *) stgMallocBytes(strlen(prog_name) + 6,
                                          "Hpc.startupHpc");
232
233
    sprintf(tixFilename, "%s.tix", prog_name);
  }
234
235
236

  if (init_open(fopen(tixFilename,"r"))) {
    readTix();
andy@galois.com's avatar
andy@galois.com committed
237
238
239
  }
}

240
241
242
243
244
245
246
247
248
249
250
/*
 * Called on a per-module basis, by a constructor function compiled
 * with each module (see Coverage.hpcInitCode), declaring where the
 * tix boxes are stored in memory.  This memory can be uninitized,
 * because we will initialize it with either the contents of the tix
 * file, or all zeros.
 *
 * Note that we might call this before reading the .tix file, or after
 * in the case where we loaded some Haskell code from a .so with
 * dlopen().  So we must handle the case where we already have an
 * HpcModuleInfo for the module which was read from the .tix file.
andy@galois.com's avatar
andy@galois.com committed
251
252
 */

253
void
254
hs_hpc_module(char *modName,
255
256
	      StgWord32 modCount,
	      StgWord32 modHashNo,
257
258
259
260
              StgWord64 *tixArr)
{
  HpcModuleInfo *tmpModule;
  nat i;
andy@galois.com's avatar
andy@galois.com committed
261

262
263
264
  if (moduleHash == NULL) {
      moduleHash = allocStrHashTable();
  }
andy@galois.com's avatar
andy@galois.com committed
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
  tmpModule = lookupHashTable(moduleHash, (StgWord)modName);
  if (tmpModule == NULL)
  {
      // Did not find entry so add one on.
      tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo),
                                                  "Hpc.hs_hpc_module");
      tmpModule->modName = modName;
      tmpModule->tickCount = modCount;
      tmpModule->hashNo = modHashNo;

      tmpModule->tixArr = tixArr;
      for(i=0;i < modCount;i++) {
          tixArr[i] = 0;
      }
      tmpModule->next = modules;
      tmpModule->from_file = rtsFalse;
      modules = tmpModule;
      insertHashTable(moduleHash, (StgWord)modName, tmpModule);
  }
  else
  {
andy@galois.com's avatar
andy@galois.com committed
287
      if (tmpModule->tickCount != modCount) {
288
          failure("inconsistent number of tick boxes");
andy@galois.com's avatar
andy@galois.com committed
289
      }
290
      ASSERT(tmpModule->tixArr != 0);
291
      if (tmpModule->hashNo != modHashNo) {
292
293
294
295
296
297
          fprintf(stderr,"in module '%s'\n",tmpModule->modName);
          failure("module mismatch with .tix/.mix file hash number");
          if (tixFilename != NULL) {
              fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
          }
          stg_exit(EXIT_FAILURE);
298
      }
299
300
301
      // The existing tixArr was made up when we read the .tix file,
      // whereas this is the real tixArr, so copy the data from the
      // .tix into the real tixArr.
andy@galois.com's avatar
andy@galois.com committed
302
      for(i=0;i < modCount;i++) {
303
          tixArr[i] = tmpModule->tixArr[i];
andy@galois.com's avatar
andy@galois.com committed
304
305
      }

306
307
308
309
310
      if (tmpModule->from_file) {
          stgFree(tmpModule->modName);
          stgFree(tmpModule->tixArr);
      }
      tmpModule->from_file = rtsFalse;
andy@galois.com's avatar
andy@galois.com committed
311
312
313
  }
}

314
315
static void
writeTix(FILE *f) {
316
  HpcModuleInfo *tmpModule;  
317
  unsigned int i, inner_comma, outer_comma;
andy@galois.com's avatar
andy@galois.com committed
318

319
  outer_comma = 0;
andy@galois.com's avatar
andy@galois.com committed
320

321
  if (f == 0) {
andy@galois.com's avatar
andy@galois.com committed
322
323
324
    return;
  }

325
  fprintf(f,"Tix [");
andy@galois.com's avatar
andy@galois.com committed
326
327
  tmpModule = modules;
  for(;tmpModule != 0;tmpModule = tmpModule->next) {
328
    if (outer_comma) {
andy@galois.com's avatar
andy@galois.com committed
329
330
      fprintf(f,",");
    } else {
331
      outer_comma = 1;
andy@galois.com's avatar
andy@galois.com committed
332
    }
333
    fprintf(f," TixModule \"%s\" %u %u [",
andy@galois.com's avatar
andy@galois.com committed
334
	   tmpModule->modName,
335
336
	    (nat)tmpModule->hashNo,
	    (nat)tmpModule->tickCount);
337
    debugTrace(DEBUG_hpc,"%s: %u (hash=%u)\n",
338
	       tmpModule->modName,
Simon Marlow's avatar
Simon Marlow committed
339
	       (nat)tmpModule->tickCount,
340
               (nat)tmpModule->hashNo);
341
342
343
344
345
346
347
348
349
350

    inner_comma = 0;
    for(i = 0;i < tmpModule->tickCount;i++) {
      if (inner_comma) {
	fprintf(f,",");
      } else {
	inner_comma = 1;
      }

      if (tmpModule->tixArr) {
351
	fprintf(f,"%" FMT_Word64,tmpModule->tixArr[i]);
352
353
354
355
356
      } else {
	fprintf(f,"0");
      }
    }
    fprintf(f,"]");
andy@galois.com's avatar
andy@galois.com committed
357
  }
358
  fprintf(f,"]\n");
andy@galois.com's avatar
andy@galois.com committed
359
  
360
361
  fclose(f);
}
andy@galois.com's avatar
andy@galois.com committed
362

363
364
365
366
367
368
369
370
371
372
373
static void
freeHpcModuleInfo (HpcModuleInfo *mod)
{
    if (mod->from_file) {
        stgFree(mod->modName);
        stgFree(mod->tixArr);
    }
    stgFree(mod);
}

/* Called at the end of execution, to write out the Hpc *.tix file
374
375
376
377
378
 * for this exection. Safe to call, even if coverage is not used.
 */
void
exitHpc(void) {
  debugTrace(DEBUG_hpc,"exitHpc");
andy@galois.com's avatar
andy@galois.com committed
379

380
381
  if (hpc_inited == 0) {
    return;
andy@galois.com's avatar
andy@galois.com committed
382
  }
383

384
385
386
387
388
389
390
391
  // Only write the tix file if you are the original process.
  // Any sub-process from use of fork from inside Haskell will
  // not clober the .tix file.

  if (hpc_pid == getpid()) {
    FILE *f = fopen(tixFilename,"w");
    writeTix(f);
  }
392
393
394
395
396
397

  freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo);
  moduleHash = NULL;

  stgFree(tixFilename);
  tixFilename = NULL;
andy@galois.com's avatar
andy@galois.com committed
398
399
}

400
401
402
//////////////////////////////////////////////////////////////////////////////
// This is the API into Hpc RTS from Haskell, allowing the tixs boxes
// to be first class.
403

404
405
406
HpcModuleInfo *hs_hpc_rootModule(void) {
  return modules;
}