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