[project @ 1997-07-07 15:18:25 by andre]
[ghc-hetmet.git] / ghc / runtime / main / main.lc
1 %/****************************************************************
2 %*                                                              *
3 %*      This is where everything starts                         *
4 %*                                                              *
5 %****************************************************************/
6
7 \begin{code}
8 #if defined(PROFILING) || defined(PAR) || defined(CONCURRENT)
9 #if !defined(_AIX)
10 #define NON_POSIX_SOURCE /* time things on Solaris -- sigh */
11 #endif
12 #endif
13
14 #include "rtsdefs.h"
15 #include <setjmp.h>
16
17 #if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
18 # include <string.h>
19 /* An ANSI string.h and pre-ANSI memory.h might conflict.  */
20 # if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
21 #  include <memory.h>
22 # endif /* not STDC_HEADERS and HAVE_MEMORY_H */
23
24 #else /* not STDC_HEADERS and not HAVE_STRING_H */
25 # include <strings.h>
26 /* memory.h and strings.h conflict on some systems.  */
27 #endif /* not STDC_HEADERS and not HAVE_STRING_H */
28
29 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
30 /* need some "time" things */
31
32 /* ToDo: This is a mess! Improve ? */
33
34 # ifdef HAVE_SYS_TYPES_H
35 #  include <sys/types.h>
36 # endif
37
38 # ifdef HAVE_SYS_TIMES_H
39 #  include <sys/times.h>
40 # endif
41
42 # ifdef HAVE_SYS_TIME_H
43 #  include <sys/time.h>
44 # endif
45 #endif /* PROFILING || PAR */
46
47 #ifndef PAR
48 STGRegisterTable MainRegTable;
49 #endif
50
51 /* fwd decls */
52 void shutdownHaskell(STG_NO_ARGS);
53
54 EXTFUN(startStgWorld);
55 extern void PrintTickyInfo(STG_NO_ARGS);
56 extern void checkAStack(STG_NO_ARGS);
57
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;
61  */
62
63 /* structure to carry around info about the storage manager */
64 smInfo StorageMgrInfo;
65
66 #ifdef PAR
67 extern I_       OkToGC, buckets;
68 extern rtsBool  TraceSparks, DelaySparks,
69                 DeferGlobalUpdates;
70
71 void RunParallelSystem PROTO((P_));
72 void initParallelSystem(STG_NO_ARGS);
73 void SynchroniseSystem(STG_NO_ARGS);
74
75 void SetTrace PROTO((W_ address, I_ level/*?*/));
76 #endif
77
78 void *stgAllocForGMP   PROTO((size_t));
79 void *stgReallocForGMP PROTO ((void *, size_t, size_t));
80 void  stgDeallocForGMP PROTO ((void *, size_t));
81
82 /* NeXTs can't just reach out and touch "end", to use in
83    distinguishing things in static vs dynamic (malloc'd) memory.
84 */
85 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
86 void *get_end_result;
87 #endif
88
89 int   prog_argc; /* an "int" so as to match normal "argc" */
90 char  **prog_argv;
91 int   rts_argc;  /* ditto */
92 char *rts_argv[MAX_RTS_ARGS];
93
94 #ifndef PAR
95 jmp_buf restart_main;       /* For restarting after a signal */
96 #endif
97
98 #if defined(PAR)
99 int nPEs = 0;               /* Number of PEs */
100 #endif
101
102 int /* return type of "main" is defined by the C standard */
103 main(int argc, char *argv[])
104 {
105 #ifdef GRAN
106  int i;
107 #endif
108 \end{code}
109
110 The very first thing we do is grab the start time...just in case we're
111 collecting timing statistics.
112
113 \begin{code}
114     start_time();
115 \end{code}
116
117 The parallel system needs to be initialised and synchronised before
118 the program is run.  This is done {\em before} heap allocation, so we
119 can grab all remaining heap without needing to consider the System
120 Manager's requirements.
121
122 \begin{code}
123 #ifdef PAR
124     if (*argv[0] == '-') {     /* Look to see whether we're the Main Thread */
125         IAmMainThread = rtsTrue;
126         argv++; argc--;                 /* Strip off flag argument */
127 /*      fprintf(stderr, "I am Main Thread\n"); */
128     }
129     /* 
130      * Grab the number of PEs out of the argument vector, and
131      * eliminate it from further argument processing.
132      */
133     nPEs = atoi(argv[1]);
134     argv[1] = argv[0];
135     argv++; argc--;
136     initEachPEHook();                  /* HWL: hook to be execed on each PE */
137     SynchroniseSystem();
138 #endif
139
140 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
141     /* setup string indicating time of run -- only used for profiling */
142     (void) time_str();
143 #endif
144
145 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
146     get_end_result = get_end();
147 #endif
148
149     /* 
150        divide the command-line args between pgm and RTS; figure out
151        what statsfile to use (if any); [if so, write the whole
152        cmd-line into it]
153        
154        This is unlikely to work well in parallel!  KH.
155     */
156     initRtsFlagsDefaults();
157     defaultsHook(); /* the one supplied does nothing;
158                        the user may have supplied a more interesting one.
159                     */
160
161     setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
162     prog_argc = argc;
163     prog_argv = argv;
164
165 #if defined(PAR)
166    /* Initialise the parallel system -- before initHeap! */
167    initParallelSystem();
168 #endif  /* PAR */
169
170 #if defined(PROFILING) || defined(PAR)
171     if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
172         fflush(stdout);
173         fprintf(stderr, "init_cc_profiling failed!\n");
174         EXIT(EXIT_FAILURE);
175     }
176 #endif
177
178 #if defined(GRAN)
179     if (!RTSflags.GranFlags.granSimStats_suppressed)
180       if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
181           fprintf(stderr, "init_gr_simulation failed!\n"); 
182           EXIT(EXIT_FAILURE);
183       }
184 #endif
185
186 #ifdef PAR
187     if (RTSflags.ParFlags.granSimStats)
188         init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
189 #endif
190
191     /* initialize the storage manager */
192     initSM();
193
194 #ifndef PAR
195     if (! initStacks( &StorageMgrInfo )) {
196         fflush(stdout);
197         fprintf(stderr, "initStacks failed!\n");
198         EXIT(EXIT_FAILURE);
199     }
200 #endif
201
202     if (! initHeap( &StorageMgrInfo )) {
203         fflush(stdout);
204         fprintf(stderr, "initHeap failed!\n");
205         EXIT(EXIT_FAILURE);
206     }
207
208 #if defined(CONCURRENT) && !defined(GRAN)
209     if (!initThreadPools()) {
210         fflush(stdout);
211         fprintf(stderr, "initThreadPools failed!\n"); 
212         EXIT(EXIT_FAILURE);
213     }
214 #endif
215
216 #if defined(PROFILING) || defined(PAR)
217     /* call cost centre registering routine (after heap allocated) */
218     cc_register();
219 #endif
220
221 #if defined(TICKY_TICKY)
222     max_SpA = MAIN_SpA; /* initial high-water marks */
223     max_SpB = MAIN_SpB;
224 #endif
225
226     /* Tell GNU multi-precision pkg about our custom alloc functions */
227     mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
228
229     /* Record initialization times */
230     end_init();
231
232 #if defined(PROFILING) || defined(CONCURRENT) 
233     /* 
234      * Both the context-switcher and the cost-center profiler use 
235      * a virtual timer.
236      */
237     if (install_vtalrm_handler()) {
238         fflush(stdout);
239         fprintf(stderr, "Can't install VTALRM handler.\n");
240         EXIT(EXIT_FAILURE);
241     }
242 #if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
243     if (! time_profiling)
244         RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
245     else {
246         if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
247             RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
248         else
249             RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
250
251         RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
252         RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
253     }
254 #endif
255
256 #ifndef CONCURRENT
257     START_TIME_PROFILER;
258 #endif
259
260 #endif  /* PROFILING || CONCURRENT */
261
262 #ifndef PAR
263     setjmp(restart_main);
264     initUserSignals();
265 #endif
266
267 #ifdef CONCURRENT
268     AvailableStack = AvailableTSO = PrelBase_Z91Z93_closure;
269 # if defined(GRAN)                                                 /* HWL */
270     /* Moved in here from ScheduleThreads, to handle a restart_main 
271        (because of a signal) properly. */
272     for (i=0; i<RTSflags.GranFlags.proc; i++) 
273       {
274         RunnableThreadsHd[i] = RunnableThreadsTl[i] = PrelBase_Z91Z93_closure;
275         WaitThreadsHd[i] = WaitThreadsTl[i] = PrelBase_Z91Z93_closure;
276         PendingSparksHd[i][REQUIRED_POOL] = PendingSparksHd[i][ADVISORY_POOL] = 
277         PendingSparksTl[i][REQUIRED_POOL] = PendingSparksTl[i][ADVISORY_POOL] = 
278             NULL; 
279       }
280 # else
281     RunnableThreadsHd = RunnableThreadsTl = PrelBase_Z91Z93_closure;
282     WaitingThreadsHd = WaitingThreadsTl = PrelBase_Z91Z93_closure;
283     PendingSparksHd[REQUIRED_POOL] = 
284       PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
285     PendingSparksHd[ADVISORY_POOL] = 
286       PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
287 # endif
288
289     CurrentTSO = PrelBase_Z91Z93_closure;
290
291 # ifdef PAR
292     RunParallelSystem(TopClosure);
293 # else
294     STKO_LINK(MainStkO) = PrelBase_Z91Z93_closure;
295     ScheduleThreads(TopClosure);
296 # endif /* PAR */
297
298 #else   /* not threaded (sequential) */
299
300     miniInterpret((StgFunPtr)startStgWorld);
301
302 #endif /* !CONCURRENT */
303
304     shutdownHaskell();
305     return(EXIT_SUCCESS);    /* don't use EXIT! :-) */
306 }
307 \end{code}
308
309 It should be possible to call @shutdownHaskell@ whenever you want to
310 shut a Haskell program down in an orderly way.
311
312 Note that some of this code probably depends on the integrity of
313 various internal data structures so this should not be called in
314 response to detecting a catastrophic error.
315
316 \begin{code}
317 void
318 shutdownHaskell(STG_NO_ARGS)
319 {
320     STOP_TIME_PROFILER;
321
322 #if defined(GRAN)
323     /* For some reason this must be before exitSM */
324     if (!RTSflags.GranFlags.granSimStats_suppressed)
325       end_gr_simulation();
326 #endif
327
328     if (! exitSM(&StorageMgrInfo) ) {
329         fflush(stdout);
330         fprintf(stderr, "exitSM failed!\n");
331         EXIT(EXIT_FAILURE);
332     }
333
334 #if defined(PROFILING)
335     heap_profile_finish();
336 #endif
337 #if defined(PROFILING) || defined(PAR)
338     report_cc_profiling(1 /* final */ );
339 #endif
340
341 #if defined(TICKY_TICKY)
342     if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
343 #endif
344
345     fflush(stdout);
346     /* This fflush is important, because: if "main" just returns,
347        then we will end up in pre-supplied exit code that will close
348        streams and flush buffers.  In particular we have seen: it
349        will close fd 0 (stdin), then flush fd 1 (stdout), then <who
350        cares>...
351
352        But if you're playing with sockets, that "close fd 0" might
353        suggest to the daemon that all is over, only to be presented
354        with more stuff on "fd 1" at the flush.
355
356        The fflush avoids this sad possibility.
357     */
358 }
359 \end{code}
360
361 Sets up and returns a string indicating the date/time of the run.
362 Successive calls simply return the same string again. Initially
363 called by @main.lc@ to initialise the string at the start of the run.
364 Only used for profiling.
365
366 \begin{code}
367 #if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
368 # include <time.h>
369
370 char *
371 time_str(STG_NO_ARGS)
372 {
373     static time_t now = 0;
374     static char nowstr[26];
375
376     if (now == 0) {
377         time(&now);
378         strcpy(nowstr, ctime(&now));
379         strcpy(nowstr+16,nowstr+19);
380         nowstr[21] = '\0';
381     }
382     return nowstr;
383 }
384 #endif /* profiling */
385 \end{code}
386
387 ToDo: Will this work under threads?
388
389 \begin{code}
390 StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
391
392 StgInt
393 getErrorHandler(STG_NO_ARGS)
394 {
395   return (StgInt) errorHandler;
396 }
397
398 #if !defined(PAR)
399
400 void
401 raiseError( handler )
402   StgStablePtr handler;
403 {
404   if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
405     shutdownHaskell();
406     EXIT(EXIT_FAILURE);
407   } else {
408     TopClosure = deRefStablePointer( handler );
409     longjmp(restart_main,1);
410   }
411 }
412 \end{code}
413
414 \begin{code}
415 StgInt
416 catchError( newErrorHandler )
417   StgStablePtr newErrorHandler;
418 {
419   StgStablePtr oldErrorHandler = errorHandler;
420   errorHandler = newErrorHandler;
421   return oldErrorHandler;
422 }
423
424 #endif
425 \end{code}
426
427 If we have installed an error handler, we might want to
428 indicate that we have successfully recovered from an error by
429 decrementing the counter.
430
431 \begin{code}
432 void
433 decrementErrorCount()
434 {
435   ErrorIO_call_count-=1;        
436 }
437
438 \end{code}