Merge remote-tracking branch 'laptop/newcg' into newcg
[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 Result-checking malloc wrappers.
56 -------------------------------------------------------------------------- */
57
58 void *
59 stgMallocBytes (int n, char *msg)
60 {
61 char *space;
62 size_t n2;
63
64 n2 = (size_t) n;
65 if ((space = (char *) malloc(n2)) == NULL) {
66 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
67 MallocFailHook((W_) n, msg); /*msg*/
68 stg_exit(EXIT_INTERNAL_ERROR);
69 }
70 return space;
71 }
72
73 void *
74 stgReallocBytes (void *p, int n, char *msg)
75 {
76 char *space;
77 size_t n2;
78
79 n2 = (size_t) n;
80 if ((space = (char *) realloc(p, (size_t) n2)) == NULL) {
81 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
82 MallocFailHook((W_) n, msg); /*msg*/
83 stg_exit(EXIT_INTERNAL_ERROR);
84 }
85 return space;
86 }
87
88 void *
89 stgCallocBytes (int n, int m, char *msg)
90 {
91 char *space;
92
93 if ((space = (char *) calloc((size_t) n, (size_t) m)) == NULL) {
94 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
95 MallocFailHook((W_) n*m, msg); /*msg*/
96 stg_exit(EXIT_INTERNAL_ERROR);
97 }
98 return space;
99 }
100
101 /* To simplify changing the underlying allocator used
102 * by stgMallocBytes(), provide stgFree() as well.
103 */
104 void
105 stgFree(void* p)
106 {
107 free(p);
108 }
109
110 /* -----------------------------------------------------------------------------
111 Stack overflow
112
113 Not sure if this belongs here.
114 -------------------------------------------------------------------------- */
115
116 void
117 stackOverflow(void)
118 {
119 StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
120
121 #if defined(TICKY_TICKY)
122 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
123 #endif
124 }
125
126 void
127 heapOverflow(void)
128 {
129 if (!heap_overflow)
130 {
131 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
132 OutOfHeapHook(0/*unknown request size*/,
133 (lnat)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
134
135 heap_overflow = rtsTrue;
136 }
137 }
138
139 /* -----------------------------------------------------------------------------
140 genSym stuff, used by GHC itself for its splitting unique supply.
141
142 ToDo: put this somewhere sensible.
143 ------------------------------------------------------------------------- */
144
145 static HsInt __GenSymCounter = 0;
146
147 HsInt
148 genSymZh(void)
149 {
150 return(__GenSymCounter++);
151 }
152 HsInt
153 resetGenSymZh(void) /* it's your funeral */
154 {
155 __GenSymCounter=0;
156 return(__GenSymCounter);
157 }
158
159 /* -----------------------------------------------------------------------------
160 Get the current time as a string. Used in profiling reports.
161 -------------------------------------------------------------------------- */
162
163 char *
164 time_str(void)
165 {
166 static time_t now = 0;
167 static char nowstr[26];
168
169 if (now == 0) {
170 time(&now);
171 #if HAVE_CTIME_R
172 ctime_r(&now, nowstr);
173 #else
174 strcpy(nowstr, ctime(&now));
175 #endif
176 memmove(nowstr+16,nowstr+19,7);
177 nowstr[21] = '\0'; // removes the \n
178 }
179 return nowstr;
180 }
181
182 /* -----------------------------------------------------------------------------
183 Print large numbers, with punctuation.
184 -------------------------------------------------------------------------- */
185
186 char *
187 showStgWord64(StgWord64 x, char *s, rtsBool with_commas)
188 {
189 if (with_commas) {
190 if (x < (StgWord64)1e3)
191 sprintf(s, "%" FMT_Word64, (StgWord64)x);
192 else if (x < (StgWord64)1e6)
193 sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64,
194 (StgWord64)(x / 1000),
195 (StgWord64)(x % 1000));
196 else if (x < (StgWord64)1e9)
197 sprintf(s, "%" FMT_Word64
198 ",%03" FMT_Word64
199 ",%03" FMT_Word64,
200 (StgWord64)(x / 1e6),
201 (StgWord64)((x / 1000) % 1000),
202 (StgWord64)(x % 1000));
203 else if (x < (StgWord64)1e12)
204 sprintf(s, "%" FMT_Word64
205 ",%03" FMT_Word64
206 ",%03" FMT_Word64
207 ",%03" FMT_Word64,
208 (StgWord64)(x / (StgWord64)1e9),
209 (StgWord64)((x / (StgWord64)1e6) % 1000),
210 (StgWord64)((x / (StgWord64)1e3) % 1000),
211 (StgWord64)(x % 1000));
212 else if (x < (StgWord64)1e15)
213 sprintf(s, "%" FMT_Word64
214 ",%03" FMT_Word64
215 ",%03" FMT_Word64
216 ",%03" FMT_Word64
217 ",%03" FMT_Word64,
218 (StgWord64)(x / (StgWord64)1e12),
219 (StgWord64)((x / (StgWord64)1e9) % 1000),
220 (StgWord64)((x / (StgWord64)1e6) % 1000),
221 (StgWord64)((x / (StgWord64)1e3) % 1000),
222 (StgWord64)(x % 1000));
223 else if (x < (StgWord64)1e18)
224 sprintf(s, "%" FMT_Word64
225 ",%03" FMT_Word64
226 ",%03" FMT_Word64
227 ",%03" FMT_Word64
228 ",%03" FMT_Word64
229 ",%03" FMT_Word64,
230 (StgWord64)(x / (StgWord64)1e15),
231 (StgWord64)((x / (StgWord64)1e12) % 1000),
232 (StgWord64)((x / (StgWord64)1e9) % 1000),
233 (StgWord64)((x / (StgWord64)1e6) % 1000),
234 (StgWord64)((x / (StgWord64)1e3) % 1000),
235 (StgWord64)(x % 1000));
236 else
237 sprintf(s, "%" FMT_Word64
238 ",%03" FMT_Word64
239 ",%03" FMT_Word64
240 ",%03" FMT_Word64
241 ",%03" FMT_Word64
242 ",%03" FMT_Word64
243 ",%03" FMT_Word64,
244 (StgWord64)(x / (StgWord64)1e18),
245 (StgWord64)((x / (StgWord64)1e15) % 1000),
246 (StgWord64)((x / (StgWord64)1e12) % 1000),
247 (StgWord64)((x / (StgWord64)1e9) % 1000),
248 (StgWord64)((x / (StgWord64)1e6) % 1000),
249 (StgWord64)((x / (StgWord64)1e3) % 1000),
250 (StgWord64)(x % 1000));
251 }
252 else {
253 sprintf(s, "%" FMT_Word64, x);
254 }
255 return s;
256 }
257
258
259 // Can be used as a breakpoint to set on every heap check failure.
260 #ifdef DEBUG
261 void
262 heapCheckFail( void )
263 {
264 }
265 #endif
266
267 /*
268 * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD
269 * pthreads (and possibly others). When linking with -lpthreads, we
270 * have to use pthread_kill to send blockable signals. So use that
271 * when we have a threaded rts. So System.Posix.Signals will call
272 * genericRaise(), rather than raise(3).
273 */
274 int genericRaise(int sig) {
275 #if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS))
276 return pthread_kill(pthread_self(), sig);
277 #else
278 return raise(sig);
279 #endif
280 }
281
282 static void mkRtsInfoPair(char *key, char *val) {
283 /* XXX should check for "s, \s etc in key and val */
284 printf(" ,(\"%s\", \"%s\")\n", key, val);
285 }
286
287 /* This little bit of magic allows us to say TOSTRING(SYM) and get
288 * "5" if SYM is 5 */
289 #define TOSTRING2(x) #x
290 #define TOSTRING(x) TOSTRING2(x)
291
292 void printRtsInfo(void) {
293 /* The first entry is just a hack to make it easy to get the
294 * commas right */
295 printf(" [(\"GHC RTS\", \"YES\")\n");
296 mkRtsInfoPair("GHC version", ProjectVersion);
297 mkRtsInfoPair("RTS way", RtsWay);
298 mkRtsInfoPair("Build platform", BuildPlatform);
299 mkRtsInfoPair("Build architecture", BuildArch);
300 mkRtsInfoPair("Build OS", BuildOS);
301 mkRtsInfoPair("Build vendor", BuildVendor);
302 mkRtsInfoPair("Host platform", HostPlatform);
303 mkRtsInfoPair("Host architecture", HostArch);
304 mkRtsInfoPair("Host OS", HostOS);
305 mkRtsInfoPair("Host vendor", HostVendor);
306 mkRtsInfoPair("Target platform", TargetPlatform);
307 mkRtsInfoPair("Target architecture", TargetArch);
308 mkRtsInfoPair("Target OS", TargetOS);
309 mkRtsInfoPair("Target vendor", TargetVendor);
310 mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS));
311 mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
312 mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode);
313 printf(" ]\n");
314 }
315
316 // Provides a way for Haskell programs to tell whether they're being
317 // profiled or not. GHCi uses it (see #2197).
318 int rts_isProfiled(void)
319 {
320 #ifdef PROFILING
321 return 1;
322 #else
323 return 0;
324 #endif
325 }
326
327 // Used for detecting a non-empty FPU stack on x86 (see #4914)
328 void checkFPUStack(void)
329 {
330 #ifdef x86_HOST_ARCH
331 static unsigned char buf[108];
332 asm("FSAVE %0":"=m" (buf));
333
334 if(buf[8]!=255 || buf[9]!=255) {
335 errorBelch("NONEMPTY FPU Stack, TAG = %x %x\n",buf[8],buf[9]);
336 abort();
337 }
338 #endif
339 }
340