Adding environment variable HPCTIXDIR, a directory to place tix results.
[ghc.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 if (hpc_inited != 0) {
178 return;
179 }
180 hpc_inited = 1;
181 hpc_pid = getpid();
182 hpc_tixdir = getenv("HPCTIXDIR");
183
184 if (hpc_tixdir != NULL) {
185 /* Make sure the directory is present
186 */
187 mkdir(hpc_tixdir,0777);
188 /* Then, try open the file
189 */
190 tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12);
191 sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,hpc_pid);
192 } else {
193 tixFilename = (char *) malloc(strlen(prog_name) + 6);
194 sprintf(tixFilename, "%s.tix", prog_name);
195 }
196
197 if (init_open(fopen(tixFilename,"r"))) {
198 readTix();
199 }
200 }
201
202 /* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory.
203 * This memory can be uninitized, because we will initialize it with either the contents
204 * of the tix file, or all zeros.
205 */
206
207 int
208 hs_hpc_module(char *modName,
209 StgWord32 modCount,
210 StgWord32 modHashNo,
211 StgWord64 *tixArr) {
212 HpcModuleInfo *tmpModule, *lastModule;
213 unsigned int i;
214 int offset = 0;
215
216 debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount);
217
218 hpc_init();
219
220 tmpModule = modules;
221 lastModule = 0;
222
223 for(;tmpModule != 0;tmpModule = tmpModule->next) {
224 if (!strcmp(tmpModule->modName,modName)) {
225 if (tmpModule->tickCount != modCount) {
226 failure("inconsistent number of tick boxes");
227 }
228 assert(tmpModule->tixArr != 0);
229 if (tmpModule->hashNo != modHashNo) {
230 fprintf(stderr,"in module '%s'\n",tmpModule->modName);
231 failure("module mismatch with .tix/.mix file hash number");
232 fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
233 exit(-1);
234
235 }
236 for(i=0;i < modCount;i++) {
237 tixArr[i] = tmpModule->tixArr[i];
238 }
239 tmpModule->tixArr = tixArr;
240 return tmpModule->tickOffset;
241 }
242 lastModule = tmpModule;
243 }
244 // Did not find entry so add one on.
245 tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo));
246 tmpModule->modName = modName;
247 tmpModule->tickCount = modCount;
248 tmpModule->hashNo = modHashNo;
249 if (lastModule) {
250 tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount;
251 } else {
252 tmpModule->tickOffset = 0;
253 }
254 tmpModule->tixArr = tixArr;
255 for(i=0;i < modCount;i++) {
256 tixArr[i] = 0;
257 }
258 tmpModule->next = 0;
259
260 if (!modules) {
261 modules = tmpModule;
262 } else {
263 lastModule->next=tmpModule;
264 }
265
266 debugTrace(DEBUG_hpc,"end: hs_hpc_module");
267
268 return offset;
269 }
270
271
272 /* This is called after all the modules have registered their local tixboxes,
273 * and does a sanity check: are we good to go?
274 */
275
276 void
277 startupHpc(void) {
278 debugTrace(DEBUG_hpc,"startupHpc");
279
280 if (hpc_inited == 0) {
281 return;
282 }
283 }
284
285
286 static void
287 writeTix(FILE *f) {
288 HpcModuleInfo *tmpModule;
289 unsigned int i, inner_comma, outer_comma;
290
291 outer_comma = 0;
292
293 if (f == 0) {
294 return;
295 }
296
297 fprintf(f,"Tix [");
298 tmpModule = modules;
299 for(;tmpModule != 0;tmpModule = tmpModule->next) {
300 if (outer_comma) {
301 fprintf(f,",");
302 } else {
303 outer_comma = 1;
304 }
305 fprintf(f," TixModule \"%s\" %u %u [",
306 tmpModule->modName,
307 (nat)tmpModule->hashNo,
308 (nat)tmpModule->tickCount);
309 debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n",
310 tmpModule->modName,
311 (nat)tmpModule->tickCount,
312 (nat)tmpModule->hashNo,
313 (nat)tmpModule->tickOffset);
314
315 inner_comma = 0;
316 for(i = 0;i < tmpModule->tickCount;i++) {
317 if (inner_comma) {
318 fprintf(f,",");
319 } else {
320 inner_comma = 1;
321 }
322
323 if (tmpModule->tixArr) {
324 fprintf(f,"%" PRIuWORD64,tmpModule->tixArr[i]);
325 } else {
326 fprintf(f,"0");
327 }
328 }
329 fprintf(f,"]");
330 }
331 fprintf(f,"]\n");
332
333 fclose(f);
334 }
335
336 /* Called at the end of execution, to write out the Hpc *.tix file
337 * for this exection. Safe to call, even if coverage is not used.
338 */
339 void
340 exitHpc(void) {
341 debugTrace(DEBUG_hpc,"exitHpc");
342
343 if (hpc_inited == 0) {
344 return;
345 }
346
347 // Only write the tix file if you are the original process.
348 // Any sub-process from use of fork from inside Haskell will
349 // not clober the .tix file.
350
351 if (hpc_pid == getpid()) {
352 FILE *f = fopen(tixFilename,"w");
353 writeTix(f);
354 }
355 }
356
357 //////////////////////////////////////////////////////////////////////////////
358 // This is the API into Hpc RTS from Haskell, allowing the tixs boxes
359 // to be first class.
360
361 HpcModuleInfo *hs_hpc_rootModule(void) {
362 return modules;
363 }