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 \end{code}
 103
 104 Setting up and initialising the run-time system:
 105 (used by main(), and people that don't allow Haskell
 106 to stay in control.)
 107
 108 \begin{code}
 109 void
 110 initRTS(int argc, char *argv[])
 111 {
 112 #ifdef GRAN
 113  int i;
 114 #endif
 115 \end{code}
 116
 117 The very first thing we do is grab the start time...just in case we're
 118 collecting timing statistics.
 119
 120 \begin{code}
 121     start_time();
 122 \end{code}
 123
 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.
 128
 129 \begin{code}
 130 #ifdef PAR
 131     if (*argv[0] == '-') {     /* Look to see whether we're the Main Thread */
 132         IAmMainThread = rtsTrue;
 133         argv++; argc--;                 /* Strip off flag argument */
 134     }
 135     /*
 136      * Grab the number of PEs out of the argument vector, and
 137      * eliminate it from further argument processing.
 138      */
 139     nPEs = atoi(argv[1]);
 140     argv[1] = argv[0];
 141     argv++; argc--;
 142     initEachPEHook();                  /* HWL: hook to be execed on each PE */
 143     SynchroniseSystem();
 144 #endif
 145
 146 #if defined(PROFILING) || defined(PAR) || defined(GRAN)
 147     /* setup string indicating time of run -- only used for profiling */
 148     (void) time_str();
 149 #endif
 150
 151 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
 152     get_end_result = get_end();
 153 #endif
 154
 155     /*
 156        divide the command-line args between pgm and RTS; figure out
 157        what statsfile to use (if any); [if so, write the whole
 158        cmd-line into it]
 159
 160     */
 161     initRtsFlagsDefaults();
 162     defaultsHook(); /* the one supplied does nothing;
 163                        the user may have supplied a more interesting one.
 164                     */
 165
 166     setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
 167     prog_argc = argc;
 168     prog_argv = argv;
 169
 170 #if defined(PAR)
 171    /* Initialise the parallel system -- before initHeap! */
 172    initParallelSystem();
 173 #endif  /* PAR */
 174
 175 #if defined(PROFILING) || defined(PAR)
 176     if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
 177         fflush(stdout);
 178         fprintf(stderr, "init_cc_profiling failed!\n");
 179         EXIT(EXIT_FAILURE);
 180     }
 181 #endif
 182
 183 #if defined(GRAN)
 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");
 187           EXIT(EXIT_FAILURE);
 188       }
 189 #endif
 190
 191 #ifdef PAR
 192     if (RTSflags.ParFlags.granSimStats)
 193         init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
 194 #endif
 195
 196     /* initialize the storage manager */
 197     initSM();
 198
 199 #ifndef PAR
 200     if (! initStacks( &StorageMgrInfo )) {
 201         fflush(stdout);
 202         fprintf(stderr, "initStacks failed!\n");
 203         EXIT(EXIT_FAILURE);
 204     }
 205 #endif
 206
 207     if (! initHeap( &StorageMgrInfo )) {
 208         fflush(stdout);
 209         fprintf(stderr, "initHeap failed!\n");
 210         EXIT(EXIT_FAILURE);
 211     }
 212
 213 #if defined(CONCURRENT) && !defined(GRAN)
 214     if (!initThreadPools()) {
 215         fflush(stdout);
 216         fprintf(stderr, "initThreadPools failed!\n");
 217         EXIT(EXIT_FAILURE);
 218     }
 219 #endif
 220
 221 #if defined(PROFILING) || defined(PAR)
 222     /* call cost centre registering routine (after heap allocated) */
 223     cc_register();
 224 #endif
 225
 226 #if defined(TICKY_TICKY)
 227     max_SpA = MAIN_SpA; /* initial high-water marks */
 228     max_SpB = MAIN_SpB;
 229 #endif
 230
 231     /* Tell GNU multi-precision pkg about our custom alloc functions */
 232     mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 233
 234     /* Record initialization times */
 235     end_init();
 236
 237 #if defined(PROFILING) || defined(CONCURRENT)
 238     /*
 239      * Both the context-switcher and the cost-center profiler use
 240      * a virtual timer.
 241      */
 242     if (install_vtalrm_handler()) {
 243         fflush(stdout);
 244         fprintf(stderr, "Can't install VTALRM handler.\n");
 245         EXIT(EXIT_FAILURE);
 246     }
 247 #if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
 248     if (! time_profiling)
 249         RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
 250     else {
 251         if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
 252             RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
 253         else
 254             RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
 255
 256         RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
 257         RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
 258     }
 259 #endif
 260
 261 #ifndef CONCURRENT
 262     START_TIME_PROFILER;
 263 #endif
 264
 265 #endif  /* PROFILING || CONCURRENT */
 266
 267 #ifndef PAR
 268     setjmp(restart_main);
 269     initUserSignals();
 270 #endif
 271
 272
 273 }
 274
 275 int /* return type of "main" is defined by the C standard */
 276 main(int argc, char *argv[])
 277 {
 278   initRTS(argc,argv);
 279
 280 #ifdef CONCURRENT
 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++)
 286       {
 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] =
 291             NULL;
 292       }
 293 # else
 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];
 300 # endif
 301
 302     CurrentTSO = PrelBase_Z91Z93_closure;
 303
 304 # ifdef PAR
 305     RunParallelSystem(TopClosure);
 306 # else
 307     STKO_LINK(MainStkO) = PrelBase_Z91Z93_closure;
 308     ScheduleThreads(TopClosure);
 309 # endif /* PAR */
 310
 311 #else   /* not threaded (sequential) */
 312
 313     miniInterpret((StgFunPtr)startStgWorld);
 314
 315 #endif /* !CONCURRENT */
 316
 317     shutdownHaskell();
 318     return(EXIT_SUCCESS);    /* don't use EXIT! :-) */
 319 }
 320 \end{code}
 321
 322 It should be possible to call @shutdownHaskell@ whenever you want to
 323 shut a Haskell program down in an orderly way.
 324
 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.
 328
 329 \begin{code}
 330 void
 331 shutdownHaskell(STG_NO_ARGS)
 332 {
 333     STOP_TIME_PROFILER;
 334
 335 #if defined(GRAN)
 336     /* For some reason this must be before exitSM */
 337     if (!RTSflags.GranFlags.granSimStats_suppressed)
 338       end_gr_simulation();
 339 #endif
 340
 341     if (! exitSM(&StorageMgrInfo) ) {
 342         fflush(stdout);
 343         fprintf(stderr, "exitSM failed!\n");
 344         EXIT(EXIT_FAILURE);
 345     }
 346
 347 #if defined(PROFILING)
 348     heap_profile_finish();
 349 #endif
 350 #if defined(PROFILING) || defined(PAR)
 351     report_cc_profiling(1 /* final */ );
 352 #endif
 353
 354 #if defined(TICKY_TICKY)
 355     if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
 356 #endif
 357
 358     /* Give the application a chance to do something sensible
 359        on-exit
 360     */
 361     OnExitHook();
 362
 363     fflush(stdout);
 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
 368        cares>...
 369
 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.
 373
 374        The fflush avoids this sad possibility.
 375     */
 376 }
 377 \end{code}
 378
 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.
 383
 384 \begin{code}
 385 #if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
 386 # include <time.h>
 387
 388 char *
 389 time_str(STG_NO_ARGS)
 390 {
 391     static time_t now = 0;
 392     static char nowstr[26];
 393
 394     if (now == 0) {
 395         time(&now);
 396         strcpy(nowstr, ctime(&now));
 397         strcpy(nowstr+16,nowstr+19);
 398         nowstr[21] = '\0';
 399     }
 400     return nowstr;
 401 }
 402 #endif /* profiling */
 403 \end{code}
 404
 405 ToDo: Will this work under threads?
 406
 407 \begin{code}
 408 StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
 409
 410 StgInt
 411 getErrorHandler(STG_NO_ARGS)
 412 {
 413   return (StgInt) errorHandler;
 414 }
 415
 416 #if !defined(PAR)
 417
 418 void
 419 raiseError( handler )
 420   StgStablePtr handler;
 421 {
 422   if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
 423     shutdownHaskell();
 424     EXIT(EXIT_FAILURE);
 425   } else {
 426     TopClosure = deRefStablePointer( handler );
 427     longjmp(restart_main,1);
 428   }
 429 }
 430 \end{code}
 431
 432 \begin{code}
 433 StgInt
 434 catchError( newErrorHandler )
 435   StgStablePtr newErrorHandler;
 436 {
 437   StgStablePtr oldErrorHandler = errorHandler;
 438   errorHandler = newErrorHandler;
 439   return oldErrorHandler;
 440 }
 441
 442 #endif
 443 \end{code}
 444
 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.
 448
 449 \begin{code}
 450 void
 451 decrementErrorCount()
 452 {
 453   ErrorIO_call_count-=1;
 454 }
 455
 456 \end{code}