1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 1998-2002
4 *
5 * Main function for a standalone Haskell program.
6 *
7 * ---------------------------------------------------------------------------*/
8
9 #include "Rts.h"
10 #include "RtsAPI.h"
11 #include "HsFFI.h"
12
13 #include "sm/Storage.h"
14 #include "RtsFlags.h"
15 #include "RtsUtils.h"
16 #include "Prelude.h"
17 #include "Printer.h" /* DEBUG_LoadSymbols */
18 #include "Schedule.h" /* initScheduler */
19 #include "Stats.h" /* initStats */
20 #include "STM.h" /* initSTM */
21 #include "RtsSignals.h"
22 #include "Weak.h"
23 #include "ForeignExports.h" /* processForeignExports */
24 #include "Ticky.h"
25 #include "StgRun.h"
26 #include "Prelude.h" /* fixupRTStoPreludeRefs */
27 #include "ThreadLabels.h"
28 #include "sm/BlockAlloc.h"
29 #include "Trace.h"
30 #include "StableName.h"
31 #include "StablePtr.h"
32 #include "StaticPtrTable.h"
33 #include "Hash.h"
34 #include "Profiling.h"
35 #include "ProfHeap.h"
36 #include "Timer.h"
37 #include "Globals.h"
38 #include "FileLock.h"
39 #include "LinkerInternals.h"
40 #include "LibdwPool.h"
41 #include "sm/CNF.h"
42 #include "TopHandler.h"
43
44 #if defined(PROFILING)
45 # include "ProfHeap.h"
46 # include "RetainerProfile.h"
47 #endif
48
49 #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS)
50 #include "win32/AsyncIO.h"
51 #endif
52
53 #if defined(mingw32_HOST_OS)
54 #include <fenv.h>
55 #else
56 #include "posix/TTY.h"
57 #endif
58
59 #if defined(HAVE_UNISTD_H)
60 #include <unistd.h>
61 #endif
62 #if defined(HAVE_LOCALE_H)
63 #include <locale.h>
64 #endif
65
66 // Count of how many outstanding hs_init()s there have been.
67 static int hs_init_count = 0;
68 static bool rts_shutdown = false;
69
70 static void flushStdHandles(void);
71
72 /* -----------------------------------------------------------------------------
73 Initialise floating point unit on x86 (currently disabled; See Note
74 [x86 Floating point precision] in compiler/nativeGen/X86/Instr.hs)
75 -------------------------------------------------------------------------- */
76
77 #define X86_INIT_FPU 0
78
79 static void
x86_init_fpu(void)80 x86_init_fpu ( void )
81 {
82 #if defined(mingw32_HOST_OS) && !X86_INIT_FPU
83 /* Mingw-w64 does a stupid thing. They set the FPU precision to extended mode by default.
84 The reasoning is that it's for compatibility with GNU Linux ported libraries. However the
85 problem is this is incompatible with the standard Windows double precision mode. In fact,
86 if we create a new OS thread then Windows will reset the FPU to double precision mode.
87 So we end up with a weird state where the main thread by default has a different precision
88 than any child threads. */
89 fesetenv(FE_PC53_ENV);
90 #elif X86_INIT_FPU
91 __volatile unsigned short int fpu_cw;
92
93 // Grab the control word
94 __asm __volatile ("fnstcw %0" : "=m" (fpu_cw));
95
96 #if 0
97 printf("fpu_cw: %x\n", fpu_cw);
98 #endif
99
100 // Set bits 8-9 to 10 (64-bit precision).
101 fpu_cw = (fpu_cw & 0xfcff) | 0x0200;
102
103 // Store the new control word back
104 __asm __volatile ("fldcw %0" : : "m" (fpu_cw));
105 #else
106 return;
107 #endif
108 }
109
110 #if defined(mingw32_HOST_OS)
111 /* And now we have to override the build in ones in Mingw-W64's CRT. */
_fpreset(void)112 void _fpreset(void)
113 {
114 x86_init_fpu();
115 }
116
117 #if defined(__GNUC__)
118 void __attribute__((alias("_fpreset"))) fpreset(void);
119 #else
fpreset(void)120 void fpreset(void) {
121 _fpreset();
122 }
123 #endif
124 #endif
125
126 /* -----------------------------------------------------------------------------
127 Starting up the RTS
128 -------------------------------------------------------------------------- */
129
130 void
hs_init(int * argc,char ** argv[])131 hs_init(int *argc, char **argv[])
132 {
133 hs_init_ghc(argc, argv, defaultRtsConfig);
134 }
135
136 void
hs_init_with_rtsopts(int * argc,char ** argv[])137 hs_init_with_rtsopts(int *argc, char **argv[])
138 {
139 RtsConfig rts_opts = defaultRtsConfig; /* by value */
140 rts_opts.rts_opts_enabled = RtsOptsAll;
141 hs_init_ghc(argc, argv, rts_opts);
142 }
143
144 void
hs_init_ghc(int * argc,char ** argv[],RtsConfig rts_config)145 hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
146 {
147 hs_init_count++;
148 if (hs_init_count > 1) {
149 // second and subsequent inits are ignored
150 return;
151 }
152 if (rts_shutdown) {
153 errorBelch("hs_init_ghc: reinitializing the RTS after shutdown is not currently supported");
154 stg_exit(1);
155 }
156
157 setlocale(LC_CTYPE,"");
158
159 /* Initialise the stats department, phase 0 */
160 initStats0();
161
162 /* Initialize system timer before starting to collect stats */
163 initializeTimer();
164
165 /* Next we do is grab the start time...just in case we're
166 * collecting timing statistics.
167 */
168 stat_startInit();
169
170 /* Set the RTS flags to default values. */
171 initRtsFlagsDefaults();
172
173 /* Call the user hook to reset defaults, if present */
174 rts_config.defaultsHook();
175
176 /* Whether to GC CAFs */
177 if (rts_config.keep_cafs) {
178 setKeepCAFs();
179 }
180
181 /* Parse the flags, separating the RTS flags from the programs args */
182 if (argc == NULL || argv == NULL) {
183 // Use a default for argc & argv if either is not supplied
184 int my_argc = 1;
185 #if defined(mingw32_HOST_OS)
186 //Retry larger buffer sizes on error up to about the NTFS length limit.
187 wchar_t* pathBuf;
188 char *my_argv[2] = { NULL, NULL };
189 for(DWORD maxLength = MAX_PATH; maxLength <= 33280; maxLength *= 2)
190 {
191 pathBuf = (wchar_t*) stgMallocBytes(sizeof(wchar_t) * maxLength,
192 "hs_init_ghc: GetModuleFileName");
193 DWORD pathLength = GetModuleFileNameW(NULL, pathBuf, maxLength);
194 if(GetLastError() == ERROR_INSUFFICIENT_BUFFER || pathLength == 0) {
195 stgFree(pathBuf);
196 pathBuf = NULL;
197 } else {
198 break;
199 }
200 }
201 if(pathBuf == NULL) {
202 my_argv[0] = "<unknown>";
203 } else {
204 my_argv[0] = lpcwstrToUTF8(pathBuf);
205 stgFree(pathBuf);
206 }
207
208
209 #else
210 char *my_argv[] = { "<unknown>", NULL };
211 #endif
212 setFullProgArgv(my_argc,my_argv);
213 setupRtsFlags(&my_argc, my_argv, rts_config);
214 } else {
215 setFullProgArgv(*argc,*argv);
216 setupRtsFlags(argc, *argv, rts_config);
217
218 #if defined(DEBUG)
219 /* load debugging symbols for current binary */
220 DEBUG_LoadSymbols((*argv)[0]);
221 #endif /* DEBUG */
222 }
223
224 /* Initialise the stats department, phase 1 */
225 initStats1();
226
227 /* initTracing must be after setupRtsFlags() */
228 #if defined(TRACING)
229 initTracing();
230 #endif
231
232 /* Initialise libdw session pool */
233 libdwPoolInit();
234
235 /* Start the "ticker" and profiling timer but don't start until the
236 * scheduler is up. However, the ticker itself needs to be initialized
237 * before the scheduler to ensure that the ticker mutex is initialized as
238 * moreCapabilities will attempt to acquire it.
239 */
240 initTimer();
241
242 /* initialise scheduler data structures (needs to be done before
243 * initStorage()).
244 */
245 initScheduler();
246
247 /* Trace some basic information about the process */
248 traceWallClockTime();
249 traceOSProcessInfo();
250 flushTrace();
251
252 /* initialize the storage manager */
253 initStorage();
254
255 /* initialise the stable pointer table */
256 initStablePtrTable();
257
258 /* initialise the stable name table */
259 initStableNameTable();
260
261 /* Add some GC roots for things in the base package that the RTS
262 * knows about. We don't know whether these turn out to be CAFs
263 * or refer to CAFs, but we have to assume that they might.
264 *
265 * Because these stable pointers will retain any CAF references in
266 * these closures `Id`s of these can be safely marked as non-CAFFY
267 * in the compiler.
268 */
269 getStablePtr((StgPtr)runIO_closure);
270 getStablePtr((StgPtr)runNonIO_closure);
271 getStablePtr((StgPtr)flushStdHandles_closure);
272
273 getStablePtr((StgPtr)runFinalizerBatch_closure);
274
275 getStablePtr((StgPtr)stackOverflow_closure);
276 getStablePtr((StgPtr)heapOverflow_closure);
277 getStablePtr((StgPtr)unpackCString_closure);
278 getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure);
279 getStablePtr((StgPtr)nonTermination_closure);
280 getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure);
281 getStablePtr((StgPtr)allocationLimitExceeded_closure);
282 getStablePtr((StgPtr)cannotCompactFunction_closure);
283 getStablePtr((StgPtr)cannotCompactPinned_closure);
284 getStablePtr((StgPtr)cannotCompactMutable_closure);
285 getStablePtr((StgPtr)nestedAtomically_closure);
286 getStablePtr((StgPtr)absentSumFieldError_closure);
287 // `Id` for this closure is marked as non-CAFFY,
288 // see Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore.
289
290 getStablePtr((StgPtr)runSparks_closure);
291 getStablePtr((StgPtr)ensureIOManagerIsRunning_closure);
292 getStablePtr((StgPtr)ioManagerCapabilitiesChanged_closure);
293 #if !defined(mingw32_HOST_OS)
294 getStablePtr((StgPtr)blockedOnBadFD_closure);
295 getStablePtr((StgPtr)runHandlersPtr_closure);
296 #endif
297
298 /*
299 * process any foreign exports which were registered while loading the
300 * image
301 * */
302 processForeignExports();
303
304 /* initialize the top-level handler system */
305 initTopHandler();
306
307 /* initialise the shared Typeable store */
308 initGlobalStore();
309
310 /* initialise file locking, if necessary */
311 initFileLocking();
312
313 #if defined(DEBUG)
314 /* initialise thread label table (tso->char*) */
315 initThreadLabelTable();
316 #endif
317
318 #if defined(PROFILING)
319 initProfiling();
320 #endif
321 initHeapProfiling();
322
323 /* start the virtual timer 'subsystem'. */
324 startTimer();
325
326 #if defined(RTS_USER_SIGNALS)
327 if (RtsFlags.MiscFlags.install_signal_handlers) {
328 /* Initialise the user signal handler set */
329 initUserSignals();
330 /* Set up handler to run on SIGINT, etc. */
331 initDefaultHandlers();
332 }
333 #endif
334
335 #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS)
336 startupAsyncIO();
337 #endif
338
339 x86_init_fpu();
340
341 startupHpc();
342
343 // ditto.
344 #if defined(THREADED_RTS)
345 ioManagerStart();
346 #endif
347
348 /* Record initialization times */
349 stat_endInit();
350 }
351
352 // Compatibility interface
353 void
startupHaskell(int argc,char * argv[],void (* init_root)(void)STG_UNUSED)354 startupHaskell(int argc, char *argv[], void (*init_root)(void) STG_UNUSED)
355 {
356 hs_init(&argc, &argv);
357 }
358
359 /* ----------------------------------------------------------------------------
360 * Shutting down the RTS
361 *
362 * The wait_foreign parameter means:
363 * True ==> wait for any threads doing foreign calls now.
364 * False ==> threads doing foreign calls may return in the
365 * future, but will immediately block on a mutex.
366 * (capability->lock).
367 *
368 * If this RTS is a DLL that we're about to unload, then you want
369 * safe=True, otherwise the thread might return to code that has been
370 * unloaded. If this is a standalone program that is about to exit,
371 * then you can get away with safe=False, which is better because we
372 * won't hang on exit if there is a blocked foreign call outstanding.
373 *
374 ------------------------------------------------------------------------- */
375
376 static void
hs_exit_(bool wait_foreign)377 hs_exit_(bool wait_foreign)
378 {
379 uint32_t g, i;
380
381 if (hs_init_count <= 0) {
382 errorBelch("warning: too many hs_exit()s");
383 return;
384 }
385 hs_init_count--;
386 if (hs_init_count > 0) {
387 // ignore until it's the last one
388 return;
389 }
390 rts_shutdown = true;
391
392 /* start timing the shutdown */
393 stat_startExit();
394
395 rtsConfig.onExitHook();
396
397 flushStdHandles();
398
399 // sanity check
400 #if defined(DEBUG)
401 checkFPUStack();
402 #endif
403
404 #if defined(THREADED_RTS)
405 ioManagerDie();
406 #endif
407
408 /* stop all running tasks. This is also where we stop concurrent non-moving
409 * collection if it's running */
410 exitScheduler(wait_foreign);
411
412 /* run C finalizers for all active weak pointers */
413 for (i = 0; i < n_capabilities; i++) {
414 runAllCFinalizers(capabilities[i]->weak_ptr_list_hd);
415 }
416 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
417 runAllCFinalizers(generations[g].weak_ptr_list);
418 }
419
420 #if defined(RTS_USER_SIGNALS)
421 if (RtsFlags.MiscFlags.install_signal_handlers) {
422 freeSignalHandlers();
423 }
424 #endif
425
426 /* stop the ticker */
427 stopTimer();
428 /*
429 * it is quite important that we wait here as some timer implementations
430 * (e.g. pthread) may fire even after we exit, which may segfault as we've
431 * already freed the capabilities.
432 */
433 exitTimer(true);
434
435 // set the terminal settings back to what they were
436 #if !defined(mingw32_HOST_OS)
437 resetTerminalSettings();
438 #endif
439
440 #if defined(RTS_USER_SIGNALS)
441 if (RtsFlags.MiscFlags.install_signal_handlers) {
442 // uninstall signal handlers
443 resetDefaultHandlers();
444 }
445 #endif
446
447 /* stop timing the shutdown, we're about to print stats */
448 stat_endExit();
449
450 /* shutdown the hpc support (if needed) */
451 exitHpc();
452
453 // clean up things from the storage manager's point of view.
454 // also outputs the stats (+RTS -s) info.
455 exitStorage();
456
457 /* free the tasks */
458 freeScheduler();
459
460 /* free shared Typeable store */
461 exitGlobalStore();
462
463 /* free linker data */
464 exitLinker();
465
466 /* free file locking tables, if necessary */
467 freeFileLocking();
468
469 /* free the Static Pointer Table */
470 exitStaticPtrTable();
471
472 /* remove the top-level handler */
473 exitTopHandler();
474
475 /* free the stable pointer table */
476 exitStablePtrTable();
477
478 /* free the stable name table */
479 exitStableNameTable();
480
481 #if defined(DEBUG)
482 /* free the thread label table */
483 freeThreadLabelTable();
484 #endif
485
486 #if defined(PROFILING)
487 reportCCSProfiling();
488 #endif
489
490 endHeapProfiling();
491 freeHeapProfiling();
492
493 #if defined(PROFILING)
494 endProfiling();
495 freeProfiling();
496 #endif
497
498 #if defined(PROFILING)
499 // Originally, this was in report_ccs_profiling(). Now, retainer
500 // profiling might tack some extra stuff on to the end of this file
501 // during endProfiling().
502 if (prof_file != NULL) fclose(prof_file);
503 #endif
504
505 #if defined(TRACING)
506 endTracing();
507 freeTracing();
508 #endif
509
510 #if defined(TICKY_TICKY)
511 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
512
513 FILE *tf = RtsFlags.TickyFlags.tickyFile;
514 if (tf != NULL) fclose(tf);
515 #endif
516
517 #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS)
518 shutdownAsyncIO(wait_foreign);
519 #endif
520
521 /* tear down statistics subsystem */
522 stat_exit();
523
524 // Finally, free all our storage. However, we only free the heap
525 // memory if we have waited for foreign calls to complete;
526 // otherwise a foreign call in progress may still be referencing
527 // heap memory (e.g. by being passed a ByteArray#).
528 freeStorage(wait_foreign);
529
530 // Free the various argvs
531 freeRtsArgs();
532
533 // Free threading resources
534 freeThreadingResources();
535 }
536
537 // Flush stdout and stderr. We do this during shutdown so that it
538 // happens even when the RTS is being used as a library, without a
539 // main (#5594)
flushStdHandles(void)540 static void flushStdHandles(void)
541 {
542 Capability *cap;
543 cap = rts_lock();
544 rts_evalIO(&cap, flushStdHandles_closure, NULL);
545 rts_unlock(cap);
546 }
547
548 // The real hs_exit():
549 void
hs_exit(void)550 hs_exit(void)
551 {
552 hs_exit_(true);
553 // be safe; this might be a DLL
554 }
555
556 void
hs_exit_nowait(void)557 hs_exit_nowait(void)
558 {
559 hs_exit_(false);
560 // do not wait for outstanding foreign calls to return; if they return in
561 // the future, they will block indefinitely.
562 }
563
564 // Compatibility interfaces
565 void
shutdownHaskell(void)566 shutdownHaskell(void)
567 {
568 hs_exit();
569 }
570
571 void
shutdownHaskellAndExit(int n,int fastExit)572 shutdownHaskellAndExit(int n, int fastExit)
573 {
574 if (!fastExit) {
575 // we're about to exit(), no need to wait for foreign calls to return.
576 hs_exit_(false);
577 }
578
579 stg_exit(n);
580 }
581
582 #if !defined(mingw32_HOST_OS)
583 static void exitBySignal(int sig) GNUC3_ATTRIBUTE(__noreturn__);
584
585 void
shutdownHaskellAndSignal(int sig,int fastExit)586 shutdownHaskellAndSignal(int sig, int fastExit)
587 {
588 if (!fastExit) {
589 hs_exit_(false);
590 }
591
592 exitBySignal(sig);
593 }
594
595 void
exitBySignal(int sig)596 exitBySignal(int sig)
597 {
598 // We're trying to kill ourselves with a given signal.
599 // That's easier said that done because:
600 // - signals can be ignored have handlers set for them
601 // - signals can be masked
602 // - signals default action can do things other than terminate:
603 // + can do nothing
604 // + can do weirder things: stop/continue the process
605
606 struct sigaction dfl;
607 sigset_t sigset;
608
609 // So first of all, we reset the signal to use the default action.
610 (void)sigemptyset(&dfl.sa_mask);
611 dfl.sa_flags = 0;
612 dfl.sa_handler = SIG_DFL;
613 (void)sigaction(sig, &dfl, NULL);
614
615 // Then we unblock the signal so we can deliver it to ourselves
616 sigemptyset(&sigset);
617 sigaddset(&sigset, sig);
618 sigprocmask(SIG_UNBLOCK, &sigset, NULL);
619
620 switch (sig) {
621 case SIGSTOP: case SIGTSTP: case SIGTTIN: case SIGTTOU: case SIGCONT:
622 // These signals stop (or continue) the process, so are no good for
623 // exiting.
624 exit(0xff);
625
626 default:
627 kill(getpid(),sig);
628 // But it's possible the signal is one where the default action is to
629 // ignore, in which case we'll still be alive... so just exit.
630 exit(0xff);
631 }
632 }
633 #endif
634
635 /*
636 * called from STG-land to exit the program
637 */
638
639 void (*exitFn)(int) = 0;
640
641 void
stg_exit(int n)642 stg_exit(int n)
643 {
644 if (exitFn)
645 (*exitFn)(n);
646 exit(n);
647 }
648