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     /* Give the application a chance to do something sensible
 346        on-exit
 347     */
 348     OnExitHook();
 349
 350     fflush(stdout);
 351     /* This fflush is important, because: if "main" just returns,
 352        then we will end up in pre-supplied exit code that will close
 353        streams and flush buffers.  In particular we have seen: it
 354        will close fd 0 (stdin), then flush fd 1 (stdout), then <who
 355        cares>...
 356
 357        But if you're playing with sockets, that "close fd 0" might
 358        suggest to the daemon that all is over, only to be presented
 359        with more stuff on "fd 1" at the flush.
 360
 361        The fflush avoids this sad possibility.
 362     */
 363 }
 364 \end{code}
 365
 366 Sets up and returns a string indicating the date/time of the run.
 367 Successive calls simply return the same string again. Initially
 368 called by @main.lc@ to initialise the string at the start of the run.
 369 Only used for profiling.
 370
 371 \begin{code}
 372 #if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
 373 # include <time.h>
 374
 375 char *
 376 time_str(STG_NO_ARGS)
 377 {
 378     static time_t now = 0;
 379     static char nowstr[26];
 380
 381     if (now == 0) {
 382         time(&now);
 383         strcpy(nowstr, ctime(&now));
 384         strcpy(nowstr+16,nowstr+19);
 385         nowstr[21] = '\0';
 386     }
 387     return nowstr;
 388 }
 389 #endif /* profiling */
 390 \end{code}
 391
 392 ToDo: Will this work under threads?
 393
 394 \begin{code}
 395 StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
 396
 397 StgInt
 398 getErrorHandler(STG_NO_ARGS)
 399 {
 400   return (StgInt) errorHandler;
 401 }
 402
 403 #if !defined(PAR)
 404
 405 void
 406 raiseError( handler )
 407   StgStablePtr handler;
 408 {
 409   if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
 410     shutdownHaskell();
 411     EXIT(EXIT_FAILURE);
 412   } else {
 413     TopClosure = deRefStablePointer( handler );
 414     longjmp(restart_main,1);
 415   }
 416 }
 417 \end{code}
 418
 419 \begin{code}
 420 StgInt
 421 catchError( newErrorHandler )
 422   StgStablePtr newErrorHandler;
 423 {
 424   StgStablePtr oldErrorHandler = errorHandler;
 425   errorHandler = newErrorHandler;
 426   return oldErrorHandler;
 427 }
 428
 429 #endif
 430 \end{code}
 431
 432 If we have installed an error handler, we might want to
 433 indicate that we have successfully recovered from an error by
 434 decrementing the counter.
 435
 436 \begin{code}
 437 void
 438 decrementErrorCount()
 439 {
 440   ErrorIO_call_count-=1;
 441 }
 442
 443 \end{code}