1 %/****************************************************************
3 %* This is where everything starts *
5 %****************************************************************/
8 #if defined(PROFILING) || defined(PAR) || defined(CONCURRENT)
10 #define NON_POSIX_SOURCE /* time things on Solaris -- sigh */
21 #if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
23 /* An ANSI string.h and pre-ANSI memory.h might conflict. */
24 # if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
26 # endif /* not STDC_HEADERS and HAVE_MEMORY_H */
28 #else /* not STDC_HEADERS and not HAVE_STRING_H */
30 /* memory.h and strings.h conflict on some systems. */
31 #endif /* not STDC_HEADERS and not HAVE_STRING_H */
33 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
34 /* need some "time" things */
36 /* ToDo: This is a mess! Improve ? */
38 # ifdef HAVE_SYS_TYPES_H
39 # include <sys/types.h>
42 # ifdef HAVE_SYS_TIMES_H
43 # include <sys/times.h>
46 # ifdef HAVE_SYS_TIME_H
47 # include <sys/time.h>
49 #endif /* PROFILING || PAR */
52 STGRegisterTable MainRegTable;
56 void shutdownHaskell(STG_NO_ARGS);
58 EXTFUN(startStgWorld);
59 extern void PrintTickyInfo(STG_NO_ARGS);
60 extern void checkAStack(STG_NO_ARGS);
62 /* a real nasty Global Variable */
63 /* moved to main/TopClosure(13)?.lc -- *one* of them will get linked in
64 P_ TopClosure = GHCmain_mainPrimIO_closure;
67 /* structure to carry around info about the storage manager */
68 smInfo StorageMgrInfo;
71 extern I_ OkToGC, buckets;
72 extern rtsBool TraceSparks, DelaySparks,
75 void RunParallelSystem PROTO((P_));
76 void initParallelSystem(STG_NO_ARGS);
77 void SynchroniseSystem(STG_NO_ARGS);
79 void SetTrace PROTO((W_ address, I_ level/*?*/));
82 void *stgAllocForGMP PROTO((size_t));
83 void *stgReallocForGMP PROTO ((void *, size_t, size_t));
84 void stgDeallocForGMP PROTO ((void *, size_t));
86 /* NeXTs can't just reach out and touch "end", to use in
87 distinguishing things in static vs dynamic (malloc'd) memory.
89 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
93 int prog_argc; /* an "int" so as to match normal "argc" */
95 int rts_argc; /* ditto */
96 char *rts_argv[MAX_RTS_ARGS];
99 jmp_buf restart_main; /* For restarting after a signal */
103 int nPEs = 0; /* Number of PEs */
108 Setting up and initialising the run-time system:
109 (used by main(), and people that don't allow Haskell
114 initRTS(int argc, char *argv[])
121 The very first thing we do is grab the start time...just in case we're
122 collecting timing statistics.
128 The parallel system needs to be initialised and synchronised before
129 the program is run. This is done {\em before} heap allocation, so we
130 can grab all remaining heap without needing to consider the System
131 Manager's requirements.
135 if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
136 IAmMainThread = rtsTrue;
137 argv++; argc--; /* Strip off flag argument */
140 * Grab the number of PEs out of the argument vector, and
141 * eliminate it from further argument processing.
143 nPEs = atoi(argv[1]);
146 initEachPEHook(); /* HWL: hook to be execed on each PE */
150 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
151 /* setup string indicating time of run -- only used for profiling */
155 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
156 get_end_result = get_end();
160 divide the command-line args between pgm and RTS; figure out
161 what statsfile to use (if any); [if so, write the whole
165 initRtsFlagsDefaults();
166 defaultsHook(); /* the one supplied does nothing;
167 the user may have supplied a more interesting one.
170 setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
175 /* Initialise the parallel system -- before initHeap! */
176 initParallelSystem();
179 #if defined(PROFILING) || defined(PAR)
180 if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
182 fprintf(stderr, "init_cc_profiling failed!\n");
188 if (!RTSflags.GranFlags.granSimStats_suppressed)
189 if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
190 fprintf(stderr, "init_gr_simulation failed!\n");
196 if (RTSflags.ParFlags.granSimStats)
197 init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
200 /* initialize the storage manager */
204 if (! initStacks( &StorageMgrInfo )) {
206 fprintf(stderr, "initStacks failed!\n");
211 if (! initHeap( &StorageMgrInfo )) {
213 fprintf(stderr, "initHeap failed!\n");
217 #if defined(CONCURRENT) && !defined(GRAN)
218 if (!initThreadPools()) {
220 fprintf(stderr, "initThreadPools failed!\n");
225 #if defined(PROFILING) || defined(PAR)
226 /* call cost centre registering routine (after heap allocated) */
230 #if defined(TICKY_TICKY)
231 max_SpA = MAIN_SpA; /* initial high-water marks */
235 /* Tell GNU multi-precision pkg about our custom alloc functions */
236 mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
238 /* Record initialization times */
241 #if defined(PROFILING) || defined(CONCURRENT)
243 * Both the context-switcher and the cost-center profiler use
246 if (install_vtalrm_handler()) {
248 fprintf(stderr, "Can't install VTALRM handler.\n");
251 #if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
252 if (! time_profiling)
253 RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
255 if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
256 RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
258 RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
260 RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
261 RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
269 #endif /* PROFILING || CONCURRENT */
272 setjmp(restart_main);
279 int /* return type of "main" is defined by the C standard */
280 main(int argc, char *argv[])
285 AvailableStack = AvailableTSO = PrelBase_Z91Z93_closure;
286 # if defined(GRAN) /* HWL */
287 /* Moved in here from ScheduleThreads, to handle a restart_main
288 (because of a signal) properly. */
289 for (i=0; i<RTSflags.GranFlags.proc; i++)
291 RunnableThreadsHd[i] = RunnableThreadsTl[i] = PrelBase_Z91Z93_closure;
292 WaitThreadsHd[i] = WaitThreadsTl[i] = PrelBase_Z91Z93_closure;
293 PendingSparksHd[i][REQUIRED_POOL] = PendingSparksHd[i][ADVISORY_POOL] =
294 PendingSparksTl[i][REQUIRED_POOL] = PendingSparksTl[i][ADVISORY_POOL] =
298 RunnableThreadsHd = RunnableThreadsTl = PrelBase_Z91Z93_closure;
299 WaitingThreadsHd = WaitingThreadsTl = PrelBase_Z91Z93_closure;
300 PendingSparksHd[REQUIRED_POOL] =
301 PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
302 PendingSparksHd[ADVISORY_POOL] =
303 PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
306 CurrentTSO = PrelBase_Z91Z93_closure;
309 RunParallelSystem(TopClosure);
311 STKO_LINK(MainStkO) = PrelBase_Z91Z93_closure;
312 ScheduleThreads(TopClosure);
315 #else /* not threaded (sequential) */
317 miniInterpret((StgFunPtr)startStgWorld);
319 #endif /* !CONCURRENT */
322 return(EXIT_SUCCESS); /* don't use EXIT! :-) */
326 It should be possible to call @shutdownHaskell@ whenever you want to
327 shut a Haskell program down in an orderly way.
329 Note that some of this code probably depends on the integrity of
330 various internal data structures so this should not be called in
331 response to detecting a catastrophic error.
335 shutdownHaskell(STG_NO_ARGS)
340 /* For some reason this must be before exitSM */
341 if (!RTSflags.GranFlags.granSimStats_suppressed)
345 if (! exitSM(&StorageMgrInfo) ) {
347 fprintf(stderr, "exitSM failed!\n");
351 #if defined(PROFILING)
352 heap_profile_finish();
354 #if defined(PROFILING) || defined(PAR)
355 report_cc_profiling(1 /* final */ );
358 #if defined(TICKY_TICKY)
359 if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
362 /* Give the application a chance to do something sensible
368 /* This fflush is important, because: if "main" just returns,
369 then we will end up in pre-supplied exit code that will close
370 streams and flush buffers. In particular we have seen: it
371 will close fd 0 (stdin), then flush fd 1 (stdout), then <who
374 But if you're playing with sockets, that "close fd 0" might
375 suggest to the daemon that all is over, only to be presented
376 with more stuff on "fd 1" at the flush.
378 The fflush avoids this sad possibility.
383 Sets up and returns a string indicating the date/time of the run.
384 Successive calls simply return the same string again. Initially
385 called by @main.lc@ to initialise the string at the start of the run.
386 Only used for profiling.
389 #if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
393 time_str(STG_NO_ARGS)
395 static time_t now = 0;
396 static char nowstr[26];
400 strcpy(nowstr, ctime(&now));
401 strcpy(nowstr+16,nowstr+19);
406 #endif /* profiling */
409 ToDo: Will this work under threads?
412 StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
415 getErrorHandler(STG_NO_ARGS)
417 return (StgInt) errorHandler;
423 raiseError( handler )
424 StgStablePtr handler;
426 if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
430 TopClosure = deRefStablePointer( handler );
431 longjmp(restart_main,1);
438 catchError( newErrorHandler )
439 StgStablePtr newErrorHandler;
441 StgStablePtr oldErrorHandler = errorHandler;
442 errorHandler = newErrorHandler;
443 return oldErrorHandler;
449 If we have installed an error handler, we might want to
450 indicate that we have successfully recovered from an error by
451 decrementing the counter.
455 decrementErrorCount()
457 ErrorIO_call_count-=1;