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 */
17 #if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
19 /* An ANSI string.h and pre-ANSI memory.h might conflict. */
20 # if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
22 # endif /* not STDC_HEADERS and HAVE_MEMORY_H */
24 #else /* not STDC_HEADERS and not HAVE_STRING_H */
26 /* memory.h and strings.h conflict on some systems. */
27 #endif /* not STDC_HEADERS and not HAVE_STRING_H */
29 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
30 /* need some "time" things */
32 /* ToDo: This is a mess! Improve ? */
34 # ifdef HAVE_SYS_TYPES_H
35 # include <sys/types.h>
38 # ifdef HAVE_SYS_TIMES_H
39 # include <sys/times.h>
42 # ifdef HAVE_SYS_TIME_H
43 # include <sys/time.h>
45 #endif /* PROFILING || PAR */
48 STGRegisterTable MainRegTable;
52 void shutdownHaskell(STG_NO_ARGS);
54 EXTFUN(startStgWorld);
55 extern void PrintTickyInfo(STG_NO_ARGS);
56 extern void checkAStack(STG_NO_ARGS);
58 /* a real nasty Global Variable */
59 /* moved to main/TopClosure(13)?.lc -- *one* of them will get linked in
60 P_ TopClosure = GHCmain_mainPrimIO_closure;
63 /* structure to carry around info about the storage manager */
64 smInfo StorageMgrInfo;
67 extern I_ OkToGC, buckets;
68 extern rtsBool TraceSparks, DelaySparks,
71 void RunParallelSystem PROTO((P_));
72 void initParallelSystem(STG_NO_ARGS);
73 void SynchroniseSystem(STG_NO_ARGS);
75 void SetTrace PROTO((W_ address, I_ level/*?*/));
78 void *stgAllocForGMP PROTO((size_t));
79 void *stgReallocForGMP PROTO ((void *, size_t, size_t));
80 void stgDeallocForGMP PROTO ((void *, size_t));
82 /* NeXTs can't just reach out and touch "end", to use in
83 distinguishing things in static vs dynamic (malloc'd) memory.
85 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
89 int prog_argc; /* an "int" so as to match normal "argc" */
91 int rts_argc; /* ditto */
92 char *rts_argv[MAX_RTS_ARGS];
95 jmp_buf restart_main; /* For restarting after a signal */
99 int nPEs = 0; /* Number of PEs */
104 Setting up and initialising the run-time system:
105 (used by main(), and people that don't allow Haskell
110 initRTS(int argc, char *argv[])
117 The very first thing we do is grab the start time...just in case we're
118 collecting timing statistics.
124 The parallel system needs to be initialised and synchronised before
125 the program is run. This is done {\em before} heap allocation, so we
126 can grab all remaining heap without needing to consider the System
127 Manager's requirements.
131 if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
132 IAmMainThread = rtsTrue;
133 argv++; argc--; /* Strip off flag argument */
136 * Grab the number of PEs out of the argument vector, and
137 * eliminate it from further argument processing.
139 nPEs = atoi(argv[1]);
142 initEachPEHook(); /* HWL: hook to be execed on each PE */
146 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
147 /* setup string indicating time of run -- only used for profiling */
151 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
152 get_end_result = get_end();
156 divide the command-line args between pgm and RTS; figure out
157 what statsfile to use (if any); [if so, write the whole
161 initRtsFlagsDefaults();
162 defaultsHook(); /* the one supplied does nothing;
163 the user may have supplied a more interesting one.
166 setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
171 /* Initialise the parallel system -- before initHeap! */
172 initParallelSystem();
175 #if defined(PROFILING) || defined(PAR)
176 if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
178 fprintf(stderr, "init_cc_profiling failed!\n");
184 if (!RTSflags.GranFlags.granSimStats_suppressed)
185 if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
186 fprintf(stderr, "init_gr_simulation failed!\n");
192 if (RTSflags.ParFlags.granSimStats)
193 init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
196 /* initialize the storage manager */
200 if (! initStacks( &StorageMgrInfo )) {
202 fprintf(stderr, "initStacks failed!\n");
207 if (! initHeap( &StorageMgrInfo )) {
209 fprintf(stderr, "initHeap failed!\n");
213 #if defined(CONCURRENT) && !defined(GRAN)
214 if (!initThreadPools()) {
216 fprintf(stderr, "initThreadPools failed!\n");
221 #if defined(PROFILING) || defined(PAR)
222 /* call cost centre registering routine (after heap allocated) */
226 #if defined(TICKY_TICKY)
227 max_SpA = MAIN_SpA; /* initial high-water marks */
231 /* Tell GNU multi-precision pkg about our custom alloc functions */
232 mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
234 /* Record initialization times */
237 #if defined(PROFILING) || defined(CONCURRENT)
239 * Both the context-switcher and the cost-center profiler use
242 if (install_vtalrm_handler()) {
244 fprintf(stderr, "Can't install VTALRM handler.\n");
247 #if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
248 if (! time_profiling)
249 RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
251 if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
252 RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
254 RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
256 RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
257 RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
265 #endif /* PROFILING || CONCURRENT */
268 setjmp(restart_main);
275 int /* return type of "main" is defined by the C standard */
276 main(int argc, char *argv[])
281 AvailableStack = AvailableTSO = PrelBase_Z91Z93_closure;
282 # if defined(GRAN) /* HWL */
283 /* Moved in here from ScheduleThreads, to handle a restart_main
284 (because of a signal) properly. */
285 for (i=0; i<RTSflags.GranFlags.proc; i++)
287 RunnableThreadsHd[i] = RunnableThreadsTl[i] = PrelBase_Z91Z93_closure;
288 WaitThreadsHd[i] = WaitThreadsTl[i] = PrelBase_Z91Z93_closure;
289 PendingSparksHd[i][REQUIRED_POOL] = PendingSparksHd[i][ADVISORY_POOL] =
290 PendingSparksTl[i][REQUIRED_POOL] = PendingSparksTl[i][ADVISORY_POOL] =
294 RunnableThreadsHd = RunnableThreadsTl = PrelBase_Z91Z93_closure;
295 WaitingThreadsHd = WaitingThreadsTl = PrelBase_Z91Z93_closure;
296 PendingSparksHd[REQUIRED_POOL] =
297 PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
298 PendingSparksHd[ADVISORY_POOL] =
299 PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
302 CurrentTSO = PrelBase_Z91Z93_closure;
305 RunParallelSystem(TopClosure);
307 STKO_LINK(MainStkO) = PrelBase_Z91Z93_closure;
308 ScheduleThreads(TopClosure);
311 #else /* not threaded (sequential) */
313 miniInterpret((StgFunPtr)startStgWorld);
315 #endif /* !CONCURRENT */
318 return(EXIT_SUCCESS); /* don't use EXIT! :-) */
322 It should be possible to call @shutdownHaskell@ whenever you want to
323 shut a Haskell program down in an orderly way.
325 Note that some of this code probably depends on the integrity of
326 various internal data structures so this should not be called in
327 response to detecting a catastrophic error.
331 shutdownHaskell(STG_NO_ARGS)
336 /* For some reason this must be before exitSM */
337 if (!RTSflags.GranFlags.granSimStats_suppressed)
341 if (! exitSM(&StorageMgrInfo) ) {
343 fprintf(stderr, "exitSM failed!\n");
347 #if defined(PROFILING)
348 heap_profile_finish();
350 #if defined(PROFILING) || defined(PAR)
351 report_cc_profiling(1 /* final */ );
354 #if defined(TICKY_TICKY)
355 if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
358 /* Give the application a chance to do something sensible
364 /* This fflush is important, because: if "main" just returns,
365 then we will end up in pre-supplied exit code that will close
366 streams and flush buffers. In particular we have seen: it
367 will close fd 0 (stdin), then flush fd 1 (stdout), then <who
370 But if you're playing with sockets, that "close fd 0" might
371 suggest to the daemon that all is over, only to be presented
372 with more stuff on "fd 1" at the flush.
374 The fflush avoids this sad possibility.
379 Sets up and returns a string indicating the date/time of the run.
380 Successive calls simply return the same string again. Initially
381 called by @main.lc@ to initialise the string at the start of the run.
382 Only used for profiling.
385 #if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
389 time_str(STG_NO_ARGS)
391 static time_t now = 0;
392 static char nowstr[26];
396 strcpy(nowstr, ctime(&now));
397 strcpy(nowstr+16,nowstr+19);
402 #endif /* profiling */
405 ToDo: Will this work under threads?
408 StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
411 getErrorHandler(STG_NO_ARGS)
413 return (StgInt) errorHandler;
419 raiseError( handler )
420 StgStablePtr handler;
422 if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
426 TopClosure = deRefStablePointer( handler );
427 longjmp(restart_main,1);
434 catchError( newErrorHandler )
435 StgStablePtr newErrorHandler;
437 StgStablePtr oldErrorHandler = errorHandler;
438 errorHandler = newErrorHandler;
439 return oldErrorHandler;
445 If we have installed an error handler, we might want to
446 indicate that we have successfully recovered from an error by
447 decrementing the counter.
451 decrementErrorCount()
453 ErrorIO_call_count-=1;