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