Linker: some extra debugging / logging
[ghc.git] / rts / Hpc.c
1 /*
2 * (c)2006 Galois Connections, Inc.
3 */
4
5 #include "PosixSource.h"
6 #include "Rts.h"
7
8 #include "Trace.h"
9 #include "Hash.h"
10 #include "RtsUtils.h"
11
12 #include <stdio.h>
13 #include <ctype.h>
14 #include <string.h>
15 #include <assert.h>
16
17 #ifdef HAVE_SYS_TYPES_H
18 #include <sys/types.h>
19 #endif
20
21 #ifdef HAVE_SYS_STAT_H
22 #include <sys/stat.h>
23 #endif
24
25 #ifdef HAVE_UNISTD_H
26 #include <unistd.h>
27 #endif
28
29
30 /* This is the runtime support for the Haskell Program Coverage (hpc) toolkit,
31 * inside GHC.
32 *
33 */
34
35 static int hpc_inited = 0; // Have you started this component?
36 static pid_t hpc_pid = 0; // pid of this process at hpc-boot time.
37 // Only this pid will read or write .tix file(s).
38 static FILE *tixFile; // file being read/written
39 static int tix_ch; // current char
40
41 static HashTable * moduleHash = NULL; // module name -> HpcModuleInfo
42
43 HpcModuleInfo *modules = 0;
44
45 static char *tixFilename = NULL;
46
47 static void GNU_ATTRIBUTE(__noreturn__)
48 failure(char *msg) {
49 debugTrace(DEBUG_hpc,"hpc failure: %s\n",msg);
50 fprintf(stderr,"Hpc failure: %s\n",msg);
51 if (tixFilename) {
52 fprintf(stderr,"(perhaps remove %s file?)\n",tixFilename);
53 } else {
54 fprintf(stderr,"(perhaps remove .tix file?)\n");
55 }
56 stg_exit(1);
57 }
58
59 static int init_open(FILE *file) {
60 tixFile = file;
61 if (tixFile == 0) {
62 return 0;
63 }
64 tix_ch = getc(tixFile);
65 return 1;
66 }
67
68 static void expect(char c) {
69 if (tix_ch != c) {
70 fprintf(stderr,"('%c' '%c')\n",tix_ch,c);
71 failure("parse error when reading .tix file");
72 }
73 tix_ch = getc(tixFile);
74 }
75
76 static void ws(void) {
77 while (tix_ch == ' ') {
78 tix_ch = getc(tixFile);
79 }
80 }
81
82 static char *expectString(void) {
83 char tmp[256], *res; // XXX
84 int tmp_ix = 0;
85 expect('"');
86 while (tix_ch != '"') {
87 tmp[tmp_ix++] = tix_ch;
88 tix_ch = getc(tixFile);
89 }
90 tmp[tmp_ix++] = 0;
91 expect('"');
92 res = stgMallocBytes(tmp_ix,"Hpc.expectString");
93 strcpy(res,tmp);
94 return res;
95 }
96
97 static StgWord64 expectWord64(void) {
98 StgWord64 tmp = 0;
99 while (isdigit(tix_ch)) {
100 tmp = tmp * 10 + (tix_ch -'0');
101 tix_ch = getc(tixFile);
102 }
103 return tmp;
104 }
105
106 static void
107 readTix(void) {
108 unsigned int i;
109 HpcModuleInfo *tmpModule;
110 const HpcModuleInfo *lookup;
111
112 ws();
113 expect('T');
114 expect('i');
115 expect('x');
116 ws();
117 expect('[');
118 ws();
119
120 while(tix_ch != ']') {
121 tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo),
122 "Hpc.readTix");
123 tmpModule->from_file = rtsTrue;
124 expect('T');
125 expect('i');
126 expect('x');
127 expect('M');
128 expect('o');
129 expect('d');
130 expect('u');
131 expect('l');
132 expect('e');
133 ws();
134 tmpModule -> modName = expectString();
135 ws();
136 tmpModule -> hashNo = (unsigned int)expectWord64();
137 ws();
138 tmpModule -> tickCount = (int)expectWord64();
139 tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));
140 ws();
141 expect('[');
142 ws();
143 for(i = 0;i < tmpModule->tickCount;i++) {
144 tmpModule->tixArr[i] = expectWord64();
145 ws();
146 if (tix_ch == ',') {
147 expect(',');
148 ws();
149 }
150 }
151 expect(']');
152 ws();
153
154 lookup = lookupHashTable(moduleHash, (StgWord)tmpModule->modName);
155 if (lookup == NULL) {
156 debugTrace(DEBUG_hpc,"readTix: new HpcModuleInfo for %s",
157 tmpModule->modName);
158 insertHashTable(moduleHash, (StgWord)tmpModule->modName, tmpModule);
159 } else {
160 ASSERT(lookup->tixArr != 0);
161 ASSERT(!strcmp(tmpModule->modName, lookup->modName));
162 debugTrace(DEBUG_hpc,"readTix: existing HpcModuleInfo for %s",
163 tmpModule->modName);
164 if (tmpModule->hashNo != lookup->hashNo) {
165 fprintf(stderr,"in module '%s'\n",tmpModule->modName);
166 failure("module mismatch with .tix/.mix file hash number");
167 if (tixFilename != NULL) {
168 fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
169 }
170 stg_exit(EXIT_FAILURE);
171 }
172 for (i=0; i < tmpModule->tickCount; i++) {
173 lookup->tixArr[i] = tmpModule->tixArr[i];
174 }
175 stgFree(tmpModule->tixArr);
176 stgFree(tmpModule->modName);
177 stgFree(tmpModule);
178 }
179
180 if (tix_ch == ',') {
181 expect(',');
182 ws();
183 }
184 }
185 expect(']');
186 fclose(tixFile);
187 }
188
189 void
190 startupHpc(void)
191 {
192 char *hpc_tixdir;
193 char *hpc_tixfile;
194
195 if (moduleHash == NULL) {
196 // no modules were registered with hs_hpc_module, so don't bother
197 // creating the .tix file.
198 return;
199 }
200
201 if (hpc_inited != 0) {
202 return;
203 }
204 hpc_inited = 1;
205 hpc_pid = getpid();
206 hpc_tixdir = getenv("HPCTIXDIR");
207 hpc_tixfile = getenv("HPCTIXFILE");
208
209 debugTrace(DEBUG_hpc,"startupHpc");
210
211 /* XXX Check results of mallocs/strdups, and check we are requesting
212 enough bytes */
213 if (hpc_tixfile != NULL) {
214 tixFilename = strdup(hpc_tixfile);
215 } else if (hpc_tixdir != NULL) {
216 /* Make sure the directory is present;
217 * conditional code for mkdir lifted from lndir.c
218 */
219 #ifdef WIN32
220 mkdir(hpc_tixdir);
221 #else
222 mkdir(hpc_tixdir,0777);
223 #endif
224 /* Then, try open the file
225 */
226 tixFilename = (char *) stgMallocBytes(strlen(hpc_tixdir) +
227 strlen(prog_name) + 12,
228 "Hpc.startupHpc");
229 sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid);
230 } else {
231 tixFilename = (char *) stgMallocBytes(strlen(prog_name) + 6,
232 "Hpc.startupHpc");
233 sprintf(tixFilename, "%s.tix", prog_name);
234 }
235
236 if (init_open(fopen(tixFilename,"r"))) {
237 readTix();
238 }
239 }
240
241 /*
242 * Called on a per-module basis, by a constructor function compiled
243 * with each module (see Coverage.hpcInitCode), declaring where the
244 * tix boxes are stored in memory. This memory can be uninitized,
245 * because we will initialize it with either the contents of the tix
246 * file, or all zeros.
247 *
248 * Note that we might call this before reading the .tix file, or after
249 * in the case where we loaded some Haskell code from a .so with
250 * dlopen(). So we must handle the case where we already have an
251 * HpcModuleInfo for the module which was read from the .tix file.
252 */
253
254 void
255 hs_hpc_module(char *modName,
256 StgWord32 modCount,
257 StgWord32 modHashNo,
258 StgWord64 *tixArr)
259 {
260 HpcModuleInfo *tmpModule;
261 uint32_t i;
262
263 if (moduleHash == NULL) {
264 moduleHash = allocStrHashTable();
265 }
266
267 tmpModule = lookupHashTable(moduleHash, (StgWord)modName);
268 if (tmpModule == NULL)
269 {
270 // Did not find entry so add one on.
271 tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo),
272 "Hpc.hs_hpc_module");
273 tmpModule->modName = modName;
274 tmpModule->tickCount = modCount;
275 tmpModule->hashNo = modHashNo;
276
277 tmpModule->tixArr = tixArr;
278 for(i=0;i < modCount;i++) {
279 tixArr[i] = 0;
280 }
281 tmpModule->next = modules;
282 tmpModule->from_file = rtsFalse;
283 modules = tmpModule;
284 insertHashTable(moduleHash, (StgWord)modName, tmpModule);
285 }
286 else
287 {
288 if (tmpModule->tickCount != modCount) {
289 failure("inconsistent number of tick boxes");
290 }
291 ASSERT(tmpModule->tixArr != 0);
292 if (tmpModule->hashNo != modHashNo) {
293 fprintf(stderr,"in module '%s'\n",tmpModule->modName);
294 failure("module mismatch with .tix/.mix file hash number");
295 if (tixFilename != NULL) {
296 fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
297 }
298 stg_exit(EXIT_FAILURE);
299 }
300 // The existing tixArr was made up when we read the .tix file,
301 // whereas this is the real tixArr, so copy the data from the
302 // .tix into the real tixArr.
303 for(i=0;i < modCount;i++) {
304 tixArr[i] = tmpModule->tixArr[i];
305 }
306
307 if (tmpModule->from_file) {
308 stgFree(tmpModule->modName);
309 stgFree(tmpModule->tixArr);
310 }
311 tmpModule->from_file = rtsFalse;
312 }
313 }
314
315 static void
316 writeTix(FILE *f) {
317 HpcModuleInfo *tmpModule;
318 unsigned int i, inner_comma, outer_comma;
319
320 outer_comma = 0;
321
322 if (f == 0) {
323 return;
324 }
325
326 fprintf(f,"Tix [");
327 tmpModule = modules;
328 for(;tmpModule != 0;tmpModule = tmpModule->next) {
329 if (outer_comma) {
330 fprintf(f,",");
331 } else {
332 outer_comma = 1;
333 }
334 fprintf(f," TixModule \"%s\" %u %u [",
335 tmpModule->modName,
336 (uint32_t)tmpModule->hashNo,
337 (uint32_t)tmpModule->tickCount);
338 debugTrace(DEBUG_hpc,"%s: %u (hash=%u)\n",
339 tmpModule->modName,
340 (uint32_t)tmpModule->tickCount,
341 (uint32_t)tmpModule->hashNo);
342
343 inner_comma = 0;
344 for(i = 0;i < tmpModule->tickCount;i++) {
345 if (inner_comma) {
346 fprintf(f,",");
347 } else {
348 inner_comma = 1;
349 }
350
351 if (tmpModule->tixArr) {
352 fprintf(f,"%" FMT_Word64,tmpModule->tixArr[i]);
353 } else {
354 fprintf(f,"0");
355 }
356 }
357 fprintf(f,"]");
358 }
359 fprintf(f,"]\n");
360
361 fclose(f);
362 }
363
364 static void
365 freeHpcModuleInfo (HpcModuleInfo *mod)
366 {
367 if (mod->from_file) {
368 stgFree(mod->modName);
369 stgFree(mod->tixArr);
370 }
371 stgFree(mod);
372 }
373
374 /* Called at the end of execution, to write out the Hpc *.tix file
375 * for this exection. Safe to call, even if coverage is not used.
376 */
377 void
378 exitHpc(void) {
379 debugTrace(DEBUG_hpc,"exitHpc");
380
381 if (hpc_inited == 0) {
382 return;
383 }
384
385 // Only write the tix file if you are the original process.
386 // Any sub-process from use of fork from inside Haskell will
387 // not clober the .tix file.
388
389 if (hpc_pid == getpid()) {
390 FILE *f = fopen(tixFilename,"w");
391 writeTix(f);
392 }
393
394 freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo);
395 moduleHash = NULL;
396
397 stgFree(tixFilename);
398 tixFilename = NULL;
399 }
400
401 //////////////////////////////////////////////////////////////////////////////
402 // This is the API into Hpc RTS from Haskell, allowing the tixs boxes
403 // to be first class.
404
405 HpcModuleInfo *hs_hpc_rootModule(void) {
406 return modules;
407 }