rts_stop_on_exception is a C int, not a W_
[ghc-hetmet.git] / rts / Hpc.c
1 /*
2  * (c)2006 Galois Connections, Inc.
3  */ 
4
5 #include <stdio.h>
6 #include <ctype.h>
7 #include <stdlib.h>
8 #include <string.h>
9 #include <assert.h>
10
11 #include "Rts.h"
12 #include "Hpc.h"
13 #include "Trace.h"
14
15 #ifdef HAVE_SYS_TYPES_H
16 #include <sys/types.h>
17 #endif
18
19 #ifdef HAVE_SYS_STAT_H
20 #include <sys/stat.h>
21 #endif
22
23 #ifdef HAVE_UNISTD_H
24 #include <unistd.h>
25 #endif
26
27
28 /* This is the runtime support for the Haskell Program Coverage (hpc) toolkit,
29  * inside GHC.
30  *
31  */
32
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
38
39 // This is a cruel hack, we should completely redesign the format specifier handling in the RTS.
40 #if SIZEOF_LONG == 8
41 #define PRIuWORD64 "lu"
42 #else
43 #define PRIuWORD64 "llu"
44 #endif
45
46 HpcModuleInfo *modules = 0;
47 HpcModuleInfo *nextModule = 0;
48 int totalTixes = 0;             // total number of tix boxes.
49
50 static char *tixFilename;
51
52 static void failure(char *msg) {
53   debugTrace(DEBUG_hpc,"hpc failure: %s\n",msg);
54   fprintf(stderr,"Hpc failure: %s\n",msg);
55   if (tixFilename) {
56     fprintf(stderr,"(perhaps remove %s file?)\n",tixFilename);
57   } else {
58     fprintf(stderr,"(perhaps remove .tix file?)\n");
59   }
60   exit(-1);
61 }
62
63 static int init_open(FILE *file) {
64   tixFile = file;
65  if (tixFile == 0) {
66     return 0;
67   }
68   tix_ch = getc(tixFile);
69   return 1;
70 }
71
72 static void expect(char c) {
73   if (tix_ch != c) {
74     fprintf(stderr,"('%c' '%c')\n",tix_ch,c);
75     failure("parse error when reading .tix file");
76   }
77   tix_ch = getc(tixFile);
78 }
79
80 static void ws(void) {
81   while (tix_ch == ' ') {
82     tix_ch = getc(tixFile);
83   }
84 }
85
86 static char *expectString(void) {
87   char tmp[256], *res;
88   int tmp_ix = 0;
89   expect('"');
90   while (tix_ch != '"') {
91     tmp[tmp_ix++] = tix_ch;
92     tix_ch = getc(tixFile);
93   }
94   tmp[tmp_ix++] = 0;
95   expect('"');
96   res = malloc(tmp_ix);
97   strcpy(res,tmp);
98   return res;
99 }
100
101 static StgWord64 expectWord64(void) {
102   StgWord64 tmp = 0;
103   while (isdigit(tix_ch)) {
104     tmp = tmp * 10 + (tix_ch -'0');
105     tix_ch = getc(tixFile);
106   }
107   return tmp;
108 }
109
110 static void
111 readTix(void) {
112   unsigned int i;
113   HpcModuleInfo *tmpModule;
114
115   totalTixes = 0;
116     
117   ws();
118   expect('T');
119   expect('i');
120   expect('x');
121   ws();
122   expect('[');
123   ws();
124   
125   while(tix_ch != ']') {
126     tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo));
127     expect('T');
128     expect('i');
129     expect('x');
130     expect('M');
131     expect('o');
132     expect('d');
133     expect('u');
134     expect('l');
135     expect('e');
136     ws();
137     tmpModule -> modName = expectString();
138     ws();
139     tmpModule -> hashNo = (unsigned int)expectWord64();
140     ws();
141     tmpModule -> tickCount = (int)expectWord64();
142     tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));
143     tmpModule -> tickOffset = totalTixes;
144     totalTixes += tmpModule -> tickCount;
145     ws();
146     expect('[');
147     ws();
148     for(i = 0;i < tmpModule->tickCount;i++) {
149       tmpModule->tixArr[i] = expectWord64();
150       ws();
151       if (tix_ch == ',') {
152         expect(',');
153         ws();
154       }
155     }
156     expect(']');
157     ws();
158     
159     if (!modules) {
160       modules = tmpModule;
161     } else {
162       nextModule->next=tmpModule;
163     }
164     nextModule=tmpModule;
165     
166     if (tix_ch == ',') {
167       expect(',');
168       ws();
169     }
170   }
171   expect(']');
172   fclose(tixFile);
173 }
174
175 static void hpc_init(void) {
176   char *hpc_tixdir;
177   char *hpc_tixfile;
178   if (hpc_inited != 0) {
179     return;
180   }
181   hpc_inited = 1;
182   hpc_pid    = getpid();
183   hpc_tixdir = getenv("HPCTIXDIR");
184   hpc_tixfile = getenv("HPCTIXFILE");
185
186   /* XXX Check results of mallocs/strdups, and check we are requesting
187          enough bytes */
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
193      */
194 #ifdef WIN32
195     mkdir(hpc_tixdir);
196 #else
197     mkdir(hpc_tixdir,0777);
198 #endif
199     /* Then, try open the file
200      */
201     tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12);
202     sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,hpc_pid);
203   } else {
204     tixFilename = (char *) malloc(strlen(prog_name) + 6);
205     sprintf(tixFilename, "%s.tix", prog_name);
206   }
207
208   if (init_open(fopen(tixFilename,"r"))) {
209     readTix();
210   }
211 }
212
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.
216  */
217
218 int
219 hs_hpc_module(char *modName,
220               StgWord32 modCount,
221               StgWord32 modHashNo,
222               StgWord64 *tixArr) {
223   HpcModuleInfo *tmpModule, *lastModule;
224   unsigned int i;
225   int offset = 0;
226   
227   debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount);
228
229   hpc_init();
230
231   tmpModule = modules;
232   lastModule = 0;
233   
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");
238       }
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);
244         exit(-1);
245
246       }
247       for(i=0;i < modCount;i++) {
248         tixArr[i] = tmpModule->tixArr[i];
249       }
250       tmpModule->tixArr = tixArr;
251       return tmpModule->tickOffset;
252     }
253     lastModule = tmpModule;
254   }
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;
260   if (lastModule) {
261     tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount;
262   } else {
263     tmpModule->tickOffset = 0;
264   }
265   tmpModule->tixArr = tixArr;
266   for(i=0;i < modCount;i++) {
267     tixArr[i] = 0;
268   }
269   tmpModule->next = 0;
270
271   if (!modules) {
272     modules = tmpModule;
273   } else {
274     lastModule->next=tmpModule;
275   }
276
277   debugTrace(DEBUG_hpc,"end: hs_hpc_module");
278
279   return offset;
280 }
281
282
283 /* This is called after all the modules have registered their local tixboxes,
284  * and does a sanity check: are we good to go?
285  */
286
287 void
288 startupHpc(void) {
289   debugTrace(DEBUG_hpc,"startupHpc");
290  
291  if (hpc_inited == 0) {
292     return;
293   }
294 }
295
296
297 static void
298 writeTix(FILE *f) {
299   HpcModuleInfo *tmpModule;  
300   unsigned int i, inner_comma, outer_comma;
301
302   outer_comma = 0;
303
304   if (f == 0) {
305     return;
306   }
307
308   fprintf(f,"Tix [");
309   tmpModule = modules;
310   for(;tmpModule != 0;tmpModule = tmpModule->next) {
311     if (outer_comma) {
312       fprintf(f,",");
313     } else {
314       outer_comma = 1;
315     }
316     fprintf(f," TixModule \"%s\" %u %u [",
317            tmpModule->modName,
318             (nat)tmpModule->hashNo,
319             (nat)tmpModule->tickCount);
320     debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n",
321                tmpModule->modName,
322                (nat)tmpModule->tickCount,
323                (nat)tmpModule->hashNo,
324                (nat)tmpModule->tickOffset);
325
326     inner_comma = 0;
327     for(i = 0;i < tmpModule->tickCount;i++) {
328       if (inner_comma) {
329         fprintf(f,",");
330       } else {
331         inner_comma = 1;
332       }
333
334       if (tmpModule->tixArr) {
335         fprintf(f,"%" PRIuWORD64,tmpModule->tixArr[i]);
336       } else {
337         fprintf(f,"0");
338       }
339     }
340     fprintf(f,"]");
341   }
342   fprintf(f,"]\n");
343   
344   fclose(f);
345 }
346
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.
349  */
350 void
351 exitHpc(void) {
352   debugTrace(DEBUG_hpc,"exitHpc");
353
354   if (hpc_inited == 0) {
355     return;
356   }
357
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.
361
362   if (hpc_pid == getpid()) {
363     FILE *f = fopen(tixFilename,"w");
364     writeTix(f);
365   }
366 }
367
368 //////////////////////////////////////////////////////////////////////////////
369 // This is the API into Hpc RTS from Haskell, allowing the tixs boxes
370 // to be first class.
371
372 HpcModuleInfo *hs_hpc_rootModule(void) {
373   return modules;
374 }