RTS tidyup sweep, first phase
[ghc.git] / rts / RtsUtils.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 1998-2004
4 *
5 * General utility functions used in the RTS.
6 *
7 * ---------------------------------------------------------------------------*/
8
9 #include "PosixSource.h"
10 #include "Rts.h"
11 #include "RtsAPI.h"
12
13 #include "RtsUtils.h"
14 #include "Ticky.h"
15 #include "Schedule.h"
16
17 #ifdef HAVE_TIME_H
18 #include <time.h>
19 #endif
20
21 /* HACK: On Mac OS X 10.4 (at least), time.h doesn't declare ctime_r with
22 * _POSIX_C_SOURCE. If this is the case, we declare it ourselves.
23 */
24 #if HAVE_CTIME_R && !HAVE_DECL_CTIME_R
25 extern char *ctime_r(const time_t *, char *);
26 #endif
27
28 #ifdef HAVE_FCNTL_H
29 #include <fcntl.h>
30 #endif
31
32 #ifdef HAVE_GETTIMEOFDAY
33 #include <sys/time.h>
34 #endif
35
36 #include <stdlib.h>
37 #include <string.h>
38 #include <stdarg.h>
39 #include <stdio.h>
40
41 #ifdef HAVE_SIGNAL_H
42 #include <signal.h>
43 #endif
44
45 #if defined(THREADED_RTS) && defined(openbsd_HOST_OS) && defined(HAVE_PTHREAD_H)
46 #include <pthread.h>
47 #endif
48
49
50 #if defined(_WIN32)
51 #include <windows.h>
52 #endif
53
54 /* -----------------------------------------------------------------------------
55 Debugging allocator
56 -------------------------------------------------------------------------- */
57
58 #if defined(DEBUG)
59
60 typedef struct Allocated_ {
61 void *addr;
62 size_t len;
63 struct Allocated_ *next;
64 } Allocated;
65
66 static Allocated *allocs = NULL;
67
68 #ifdef THREADED_RTS
69 static Mutex allocator_mutex;
70 #endif
71
72 void
73 initAllocator(void)
74 {
75 Allocated *a;
76 size_t alloc_size;
77
78 #ifdef THREADED_RTS
79 initMutex(&allocator_mutex);
80 #endif
81 alloc_size = sizeof(Allocated);
82 if ((a = (Allocated *) malloc(alloc_size)) == NULL) {
83 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
84 MallocFailHook((W_) alloc_size, "initialising debugging allocator");
85 stg_exit(EXIT_INTERNAL_ERROR);
86 }
87 a->addr = NULL;
88 a->len = 0;
89 a->next = NULL;
90 allocs = a;
91 }
92
93 void
94 shutdownAllocator(void)
95 {
96 Allocated *prev, *a;
97
98 if (allocs == NULL) {
99 barf("Allocator shutdown requested, but not initialised!");
100 }
101
102 #ifdef THREADED_RTS
103 closeMutex(&allocator_mutex);
104 #endif
105
106 prev = allocs;
107 while (1) {
108 a = prev->next;
109 free(prev);
110 if (a == NULL) return;
111 IF_DEBUG(sanity,
112 debugBelch("Warning: %ld bytes at %p still allocated at shutdown\n",
113 (long)a->len, a->addr);)
114 prev = a;
115 }
116 }
117
118 static void addAllocation(void *addr, size_t len) {
119 Allocated *a;
120 size_t alloc_size;
121
122 if (allocs != NULL) {
123 alloc_size = sizeof(Allocated);
124 if ((a = (Allocated *) malloc(alloc_size)) == NULL) {
125 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
126 MallocFailHook((W_) alloc_size,
127 "creating info for debugging allocator");
128 stg_exit(EXIT_INTERNAL_ERROR);
129 }
130 a->addr = addr;
131 a->len = len;
132 ACQUIRE_LOCK(&allocator_mutex);
133 a->next = allocs->next;
134 allocs->next = a;
135 RELEASE_LOCK(&allocator_mutex);
136 }
137 else {
138 /* This doesn't actually help as we haven't looked at the flags
139 * at the time that it matters (while running constructors) */
140 IF_DEBUG(sanity,
141 debugBelch("Ignoring allocation %p %zd as allocs is NULL\n",
142 addr, len);)
143 }
144 }
145
146 static void removeAllocation(void *addr, int overwrite_with_aa) {
147 Allocated *prev, *a;
148
149 if (addr == NULL) {
150 barf("Freeing NULL!");
151 }
152
153 if (allocs != NULL) {
154 ACQUIRE_LOCK(&allocator_mutex);
155 prev = allocs;
156 a = prev->next;
157 while (a != NULL) {
158 if (a->addr == addr) {
159 prev->next = a->next;
160 if (overwrite_with_aa) {
161 memset(addr, 0xaa, a->len);
162 }
163 free(a);
164 RELEASE_LOCK(&allocator_mutex);
165 return;
166 }
167 prev = a;
168 a = a->next;
169 }
170 /* We would like to barf here, but we can't as conc021
171 * allocates some stuff in a constructor which then gets freed
172 * during hs_exit */
173 /* barf("Freeing non-allocated memory at %p", addr); */
174 IF_DEBUG(sanity,
175 debugBelch("Warning: Freeing non-allocated memory at %p\n",
176 addr);)
177 RELEASE_LOCK(&allocator_mutex);
178 }
179 else {
180 IF_DEBUG(sanity,
181 debugBelch("Ignoring free of %p as allocs is NULL\n",
182 addr);)
183 }
184 }
185 #endif
186
187 /* -----------------------------------------------------------------------------
188 Result-checking malloc wrappers.
189 -------------------------------------------------------------------------- */
190
191 void *
192 stgMallocBytes (int n, char *msg)
193 {
194 char *space;
195 size_t n2;
196
197 n2 = (size_t) n;
198 if ((space = (char *) malloc(n2)) == NULL) {
199 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
200 MallocFailHook((W_) n, msg); /*msg*/
201 stg_exit(EXIT_INTERNAL_ERROR);
202 }
203 #if defined(DEBUG)
204 addAllocation(space, n2);
205 #endif
206 return space;
207 }
208
209 void *
210 stgReallocBytes (void *p, int n, char *msg)
211 {
212 char *space;
213 size_t n2;
214
215 n2 = (size_t) n;
216 if ((space = (char *) realloc(p, (size_t) n2)) == NULL) {
217 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
218 MallocFailHook((W_) n, msg); /*msg*/
219 stg_exit(EXIT_INTERNAL_ERROR);
220 }
221 #if defined(DEBUG)
222 removeAllocation(p, 0);
223 addAllocation(space, n2);
224 #endif
225 return space;
226 }
227
228 void *
229 stgCallocBytes (int n, int m, char *msg)
230 {
231 char *space;
232
233 if ((space = (char *) calloc((size_t) n, (size_t) m)) == NULL) {
234 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
235 MallocFailHook((W_) n*m, msg); /*msg*/
236 stg_exit(EXIT_INTERNAL_ERROR);
237 }
238 #if defined(DEBUG)
239 addAllocation(space, (size_t) n * (size_t) m);
240 #endif
241 return space;
242 }
243
244 /* To simplify changing the underlying allocator used
245 * by stgMallocBytes(), provide stgFree() as well.
246 */
247 void
248 stgFree(void* p)
249 {
250 #if defined(DEBUG)
251 removeAllocation(p, 1);
252 #endif
253 free(p);
254 }
255
256 /* -----------------------------------------------------------------------------
257 Stack overflow
258
259 Not sure if this belongs here.
260 -------------------------------------------------------------------------- */
261
262 void
263 stackOverflow(void)
264 {
265 StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
266
267 #if defined(TICKY_TICKY)
268 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
269 #endif
270 }
271
272 void
273 heapOverflow(void)
274 {
275 if (!heap_overflow)
276 {
277 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
278 OutOfHeapHook(0/*unknown request size*/,
279 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
280
281 heap_overflow = rtsTrue;
282 }
283 }
284
285 /* -----------------------------------------------------------------------------
286 genSym stuff, used by GHC itself for its splitting unique supply.
287
288 ToDo: put this somewhere sensible.
289 ------------------------------------------------------------------------- */
290
291 static HsInt __GenSymCounter = 0;
292
293 HsInt
294 genSymZh(void)
295 {
296 return(__GenSymCounter++);
297 }
298 HsInt
299 resetGenSymZh(void) /* it's your funeral */
300 {
301 __GenSymCounter=0;
302 return(__GenSymCounter);
303 }
304
305 /* -----------------------------------------------------------------------------
306 Get the current time as a string. Used in profiling reports.
307 -------------------------------------------------------------------------- */
308
309 char *
310 time_str(void)
311 {
312 static time_t now = 0;
313 static char nowstr[26];
314
315 if (now == 0) {
316 time(&now);
317 #if HAVE_CTIME_R
318 ctime_r(&now, nowstr);
319 #else
320 strcpy(nowstr, ctime(&now));
321 #endif
322 memmove(nowstr+16,nowstr+19,7);
323 nowstr[21] = '\0'; // removes the \n
324 }
325 return nowstr;
326 }
327
328 /* -----------------------------------------------------------------------------
329 Print large numbers, with punctuation.
330 -------------------------------------------------------------------------- */
331
332 char *
333 ullong_format_string(ullong x, char *s, rtsBool with_commas)
334 {
335 if (x < (ullong)1000)
336 sprintf(s, "%lu", (lnat)x);
337 else if (x < (ullong)1000000)
338 sprintf(s, (with_commas) ? "%lu,%3.3lu" : "%lu%3.3lu",
339 (lnat)((x)/(ullong)1000),
340 (lnat)((x)%(ullong)1000));
341 else if (x < (ullong)1000000000)
342 sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu",
343 (lnat)((x)/(ullong)1000000),
344 (lnat)((x)/(ullong)1000%(ullong)1000),
345 (lnat)((x)%(ullong)1000));
346 else
347 sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu%3.3lu",
348 (lnat)((x)/(ullong)1000000000),
349 (lnat)((x)/(ullong)1000000%(ullong)1000),
350 (lnat)((x)/(ullong)1000%(ullong)1000),
351 (lnat)((x)%(ullong)1000));
352 return s;
353 }
354
355
356 // Can be used as a breakpoint to set on every heap check failure.
357 #ifdef DEBUG
358 void
359 heapCheckFail( void )
360 {
361 }
362 #endif
363
364 /*
365 * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD
366 * pthreads (and possibly others). When linking with -lpthreads, we
367 * have to use pthread_kill to send blockable signals. So use that
368 * when we have a threaded rts. So System.Posix.Signals will call
369 * genericRaise(), rather than raise(3).
370 */
371 int genericRaise(int sig) {
372 #if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
373 return pthread_kill(pthread_self(), sig);
374 #else
375 return raise(sig);
376 #endif
377 }
378
379 static void mkRtsInfoPair(char *key, char *val) {
380 /* XXX should check for "s, \s etc in key and val */
381 printf(" ,(\"%s\", \"%s\")\n", key, val);
382 }
383
384 /* This little bit of magic allows us to say TOSTRING(SYM) and get
385 * "5" if SYM is 5 */
386 #define TOSTRING2(x) #x
387 #define TOSTRING(x) TOSTRING2(x)
388
389 void printRtsInfo(void) {
390 /* The first entry is just a hack to make it easy to get the
391 * commas right */
392 printf(" [(\"GHC RTS\", \"YES\")\n");
393 mkRtsInfoPair("GHC version", ProjectVersion);
394 mkRtsInfoPair("RTS way", RtsWay);
395 mkRtsInfoPair("Host platform", HostPlatform);
396 mkRtsInfoPair("Host architecture", HostArch);
397 mkRtsInfoPair("Host OS", HostOS);
398 mkRtsInfoPair("Host vendor", HostVendor);
399 mkRtsInfoPair("Build platform", BuildPlatform);
400 mkRtsInfoPair("Build architecture", BuildArch);
401 mkRtsInfoPair("Build OS", BuildOS);
402 mkRtsInfoPair("Build vendor", BuildVendor);
403 mkRtsInfoPair("Target platform", TargetPlatform);
404 mkRtsInfoPair("Target architecture", TargetArch);
405 mkRtsInfoPair("Target OS", TargetOS);
406 mkRtsInfoPair("Target vendor", TargetVendor);
407 mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS));
408 mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
409 mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode);
410 printf(" ]\n");
411 }
412
413 // Provides a way for Haskell programs to tell whether they're being
414 // profiled or not. GHCi uses it (see #2197).
415 int rts_isProfiled(void)
416 {
417 #ifdef PROFILING
418 return 1;
419 #else
420 return 0;
421 #endif
422 }