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