2 * (c)2006 Galois Connections, Inc.
15 #ifdef HAVE_SYS_TYPES_H
16 #include <sys/types.h>
19 #ifdef HAVE_SYS_STAT_H
28 /* This is the runtime support for the Haskell Program Coverage (hpc) toolkit,
33 static int hpc_inited = 0; // Have you started this component?
34 static pid_t hpc_pid = 0; // pid of this process at hpc-boot time.
35 // Only this pid will read or write .tix file(s).
36 static FILE *tixFile; // file being read/written
37 static int tix_ch; // current char
39 // This is a cruel hack, we should completely redesign the format specifier handling in the RTS.
41 #define PRIuWORD64 "lu"
43 #define PRIuWORD64 "llu"
46 HpcModuleInfo *modules = 0;
47 HpcModuleInfo *nextModule = 0;
48 int totalTixes = 0; // total number of tix boxes.
50 static char *tixFilename;
52 static void failure(char *msg) {
53 debugTrace(DEBUG_hpc,"hpc failure: %s\n",msg);
54 fprintf(stderr,"Hpc failure: %s\n",msg);
56 fprintf(stderr,"(perhaps remove %s file?)\n",tixFilename);
58 fprintf(stderr,"(perhaps remove .tix file?)\n");
63 static int init_open(FILE *file) {
68 tix_ch = getc(tixFile);
72 static void expect(char c) {
74 fprintf(stderr,"('%c' '%c')\n",tix_ch,c);
75 failure("parse error when reading .tix file");
77 tix_ch = getc(tixFile);
80 static void ws(void) {
81 while (tix_ch == ' ') {
82 tix_ch = getc(tixFile);
86 static char *expectString(void) {
90 while (tix_ch != '"') {
91 tmp[tmp_ix++] = tix_ch;
92 tix_ch = getc(tixFile);
101 static StgWord64 expectWord64(void) {
103 while (isdigit(tix_ch)) {
104 tmp = tmp * 10 + (tix_ch -'0');
105 tix_ch = getc(tixFile);
113 HpcModuleInfo *tmpModule;
125 while(tix_ch != ']') {
126 tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo));
137 tmpModule -> modName = expectString();
139 tmpModule -> hashNo = (unsigned int)expectWord64();
141 tmpModule -> tickCount = (int)expectWord64();
142 tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));
143 tmpModule -> tickOffset = totalTixes;
144 totalTixes += tmpModule -> tickCount;
148 for(i = 0;i < tmpModule->tickCount;i++) {
149 tmpModule->tixArr[i] = expectWord64();
162 nextModule->next=tmpModule;
164 nextModule=tmpModule;
175 static void hpc_init(void) {
178 if (hpc_inited != 0) {
183 hpc_tixdir = getenv("HPCTIXDIR");
184 hpc_tixfile = getenv("HPCTIXFILE");
186 /* XXX Check results of mallocs/strdups, and check we are requesting
188 if (hpc_tixfile != NULL) {
189 tixFilename = strdup(hpc_tixfile);
190 } else if (hpc_tixdir != NULL) {
191 /* Make sure the directory is present;
192 * conditional code for mkdir lifted from lndir.c
197 mkdir(hpc_tixdir,0777);
199 /* Then, try open the file
201 tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12);
202 sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,hpc_pid);
204 tixFilename = (char *) malloc(strlen(prog_name) + 6);
205 sprintf(tixFilename, "%s.tix", prog_name);
208 if (init_open(fopen(tixFilename,"r"))) {
213 /* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory.
214 * This memory can be uninitized, because we will initialize it with either the contents
215 * of the tix file, or all zeros.
219 hs_hpc_module(char *modName,
223 HpcModuleInfo *tmpModule, *lastModule;
227 debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount);
234 for(;tmpModule != 0;tmpModule = tmpModule->next) {
235 if (!strcmp(tmpModule->modName,modName)) {
236 if (tmpModule->tickCount != modCount) {
237 failure("inconsistent number of tick boxes");
239 assert(tmpModule->tixArr != 0);
240 if (tmpModule->hashNo != modHashNo) {
241 fprintf(stderr,"in module '%s'\n",tmpModule->modName);
242 failure("module mismatch with .tix/.mix file hash number");
243 fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
247 for(i=0;i < modCount;i++) {
248 tixArr[i] = tmpModule->tixArr[i];
250 tmpModule->tixArr = tixArr;
251 return tmpModule->tickOffset;
253 lastModule = tmpModule;
255 // Did not find entry so add one on.
256 tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo));
257 tmpModule->modName = modName;
258 tmpModule->tickCount = modCount;
259 tmpModule->hashNo = modHashNo;
261 tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount;
263 tmpModule->tickOffset = 0;
265 tmpModule->tixArr = tixArr;
266 for(i=0;i < modCount;i++) {
274 lastModule->next=tmpModule;
277 debugTrace(DEBUG_hpc,"end: hs_hpc_module");
283 /* This is called after all the modules have registered their local tixboxes,
284 * and does a sanity check: are we good to go?
289 debugTrace(DEBUG_hpc,"startupHpc");
291 if (hpc_inited == 0) {
299 HpcModuleInfo *tmpModule;
300 unsigned int i, inner_comma, outer_comma;
310 for(;tmpModule != 0;tmpModule = tmpModule->next) {
316 fprintf(f," TixModule \"%s\" %u %u [",
318 (nat)tmpModule->hashNo,
319 (nat)tmpModule->tickCount);
320 debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n",
322 (nat)tmpModule->tickCount,
323 (nat)tmpModule->hashNo,
324 (nat)tmpModule->tickOffset);
327 for(i = 0;i < tmpModule->tickCount;i++) {
334 if (tmpModule->tixArr) {
335 fprintf(f,"%" PRIuWORD64,tmpModule->tixArr[i]);
347 /* Called at the end of execution, to write out the Hpc *.tix file
348 * for this exection. Safe to call, even if coverage is not used.
352 debugTrace(DEBUG_hpc,"exitHpc");
354 if (hpc_inited == 0) {
358 // Only write the tix file if you are the original process.
359 // Any sub-process from use of fork from inside Haskell will
360 // not clober the .tix file.
362 if (hpc_pid == getpid()) {
363 FILE *f = fopen(tixFilename,"w");
368 //////////////////////////////////////////////////////////////////////////////
369 // This is the API into Hpc RTS from Haskell, allowing the tixs boxes
370 // to be first class.
372 HpcModuleInfo *hs_hpc_rootModule(void) {