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)
  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 = Main_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 extern void RunParallelSystem PROTO((P_));
  70 extern void initParallelSystem(STG_NO_ARGS);
  71 extern void SynchroniseSystem(STG_NO_ARGS);
  72
  73 extern void SetTrace PROTO((W_ address, I_ level/*?*/));
  74 #endif
  75
  76 #if defined(GRAN_CHECK) && defined(GRAN)
  77 extern W_ debug;
  78 extern W_ event_trace ;
  79 extern W_ event_trace_all ;
  80 #endif
  81
  82 extern void *stgAllocForGMP   PROTO((size_t));
  83 extern void *stgReallocForGMP PROTO ((void *, size_t, size_t));
  84 extern 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 int /* return type of "main" is defined by the C standard */
 107 main(int argc, char *argv[])
 108 {
 109 \end{code}
 110
 111 The very first thing we do is grab the start time...just in case we're
 112 collecting timing statistics.
 113
 114 \begin{code}
 115     start_time();
 116 \end{code}
 117
 118 The parallel system needs to be initialised and synchronised before
 119 the program is run.  This is done {\em before} heap allocation, so we
 120 can grab all remaining heap without needing to consider the System
 121 Manager's requirements.
 122
 123 \begin{code}
 124 #ifdef PAR
 125     if (*argv[0] == '-') {              /* Look to see whether we're the Main Thread */
 126         IAmMainThread = rtsTrue;
 127         argv++; argc--;                 /* Strip off flag argument */
 128 /*      fprintf(stderr, "I am Main Thread\n"); */
 129     }
 130     /*
 131      * Grab the number of PEs out of the argument vector, and
 132      * eliminate it from further argument processing.
 133      */
 134     nPEs = atoi(argv[1]);
 135     argv[1] = argv[0];
 136     argv++; argc--;
 137     SynchroniseSystem();
 138 #endif
 139
 140 #if defined(PROFILING) || defined(PAR)
 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(CONCURRENT) && defined(GRAN)
 179     if (!no_gr_profile)
 180       if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
 181           fprintf(stderr, "init_gr_simulation failed!\n"); EXIT(EXIT_FAILURE);
 182       }
 183 #endif
 184
 185 #ifdef PAR
 186     if (RTSflags.ParFlags.granSimStats)
 187         init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
 188 #endif
 189
 190     /* initialize the storage manager */
 191     initSM();
 192
 193 #ifndef PAR
 194     if (! initStacks( &StorageMgrInfo )) {
 195         fflush(stdout);
 196         fprintf(stderr, "initStacks failed!\n");
 197         EXIT(EXIT_FAILURE);
 198     }
 199 #endif
 200
 201     if (! initHeap( &StorageMgrInfo )) {
 202         fflush(stdout);
 203         fprintf(stderr, "initHeap failed!\n");
 204         EXIT(EXIT_FAILURE);
 205     }
 206
 207 #if defined(CONCURRENT) && !defined(GRAN)
 208     if (!initThreadPools()) {
 209         fflush(stdout);
 210         fprintf(stderr, "initThreadPools failed!\n");
 211         EXIT(EXIT_FAILURE);
 212     }
 213 #endif
 214
 215 #if defined(PROFILING) || defined(PAR)
 216     /* call cost centre registering routine (after heap allocated) */
 217     cc_register();
 218 #endif
 219
 220 #if defined(TICKY_TICKY)
 221     max_SpA = MAIN_SpA; /* initial high-water marks */
 222     max_SpB = MAIN_SpB;
 223 #endif
 224
 225     /* Tell GNU multi-precision pkg about our custom alloc functions */
 226     mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 227
 228     /* Record initialization times */
 229     end_init();
 230
 231 #if defined(PROFILING) || defined(CONCURRENT)
 232     /*
 233      * Both the context-switcher and the cost-center profiler use
 234      * a virtual timer.
 235      */
 236     if (install_vtalrm_handler()) {
 237         fflush(stdout);
 238         fprintf(stderr, "Can't install VTALRM handler.\n");
 239         EXIT(EXIT_FAILURE);
 240     }
 241 #if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
 242     if (! time_profiling)
 243         RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
 244     else {
 245         if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
 246             RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
 247         else
 248             RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
 249
 250         RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
 251         RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
 252     }
 253 #endif
 254
 255 #ifndef CONCURRENT
 256     START_TIME_PROFILER;
 257 #endif
 258
 259 #endif  /* PROFILING || CONCURRENT */
 260
 261 #ifndef PAR
 262     setjmp(restart_main);
 263     initUserSignals();
 264 #endif
 265
 266 #ifdef CONCURRENT
 267 # if defined(GRAN)                                                 /* HWL */
 268     /* RunnableThreadsHd etc. are init in ScheduleThreads */
 269     /*
 270      * I'm not sure about this.  Note that this code is for re-initializing
 271      * things when a longjmp to restart_main occurs.  --JSM
 272      */
 273
 274 # else                                                             /* !GRAN */
 275     AvailableStack = AvailableTSO = Nil_closure;
 276     RunnableThreadsHd = RunnableThreadsTl = Nil_closure;
 277     WaitingThreadsHd = WaitingThreadsTl = Nil_closure;
 278     PendingSparksHd[REQUIRED_POOL] =
 279       PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
 280     PendingSparksHd[ADVISORY_POOL] =
 281       PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
 282 # endif
 283
 284     CurrentTSO = Nil_closure;
 285
 286 # ifdef PAR
 287     RunParallelSystem(TopClosure);
 288 # else
 289     STKO_LINK(MainStkO) = Nil_closure;
 290     ScheduleThreads(TopClosure);
 291 # endif /* PAR */
 292
 293 #else   /* not threaded (sequential) */
 294
 295     miniInterpret((StgFunPtr)startStgWorld);
 296
 297 #endif /* !CONCURRENT */
 298
 299     shutdownHaskell();
 300     return(EXIT_SUCCESS);    /* don't use EXIT! :-) */
 301 }
 302 \end{code}
 303
 304 It should be possible to call @shutdownHaskell@ whenever you want to
 305 shut a Haskell program down in an orderly way.
 306
 307 Note that some of this code probably depends on the integrity of
 308 various internal data structures so this should not be called in
 309 response to detecting a catastrophic error.
 310
 311 \begin{code}
 312 void
 313 shutdownHaskell(STG_NO_ARGS)
 314 {
 315     STOP_TIME_PROFILER;
 316
 317     if (! exitSM(&StorageMgrInfo)) {
 318         fflush(stdout);
 319         fprintf(stderr, "exitSM failed!\n");
 320         EXIT(EXIT_FAILURE);
 321     }
 322
 323 #if defined(PROFILING)
 324     heap_profile_finish();
 325 #endif
 326 #if defined(PROFILING) || defined(PAR)
 327     report_cc_profiling(1 /* final */ );
 328 #endif
 329
 330 #if defined(TICKY_TICKY)
 331     if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
 332 #endif
 333
 334 #if defined(GRAN_CHECK) && defined(GRAN)
 335     if (PrintFetchMisses)
 336       fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);
 337
 338 # if defined(COUNT)
 339     fprintf(stderr,"COUNT statistics:\n");
 340     fprintf(stderr,"  Total number of updates: %u\n",nUPDs);
 341     fprintf(stderr,"  Needed to awaken BQ: %u with avg BQ len of: %f\n",
 342             nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
 343     fprintf(stderr,"  Number of PAPs: %u\n",nPAPs);
 344 # endif
 345
 346     if (!no_gr_profile)
 347       end_gr_simulation();
 348 #endif
 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)
 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 #ifndef 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}