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