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(PVM)
 103 unsigned nPEs = 0, nIMUs = 0;
 104 #endif
 105
 106 #if defined(PAR)
 107 int nPEs = 0;
 108 #endif
 109
 110 int /* return type of "main" is defined by the C standard */
 111 main(int argc, char *argv[])
 112 {
 113 \end{code}
 114
 115 The very first thing we do is grab the start time...just in case we're
 116 collecting timing statistics.
 117
 118 \begin{code}
 119     start_time();
 120 \end{code}
 121
 122 The parallel system needs to be initialised and synchronised before
 123 the program is run.  This is done {\em before} heap allocation, so we
 124 can grab all remaining heap without needing to consider the System
 125 Manager's requirements.
 126
 127 \begin{code}
 128 #ifdef PAR
 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++;
 136     argc--;
 137
 138     SynchroniseSystem();
 139 #endif
 140
 141 #if defined(PROFILING) || defined(PAR)
 142     /* setup string indicating time of run -- only used for profiling */
 143     (void) time_str();
 144 #endif
 145
 146 #if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
 147     get_end_result = get_end();
 148 #endif
 149
 150     /*
 151        divide the command-line args between pgm and RTS; figure out
 152        what statsfile to use (if any); [if so, write the whole
 153        cmd-line into it]
 154
 155        This is unlikely to work well in parallel!  KH.
 156     */
 157     initRtsFlagsDefaults();
 158     defaultsHook(); /* the one supplied does nothing;
 159                        the user may have supplied a more interesting one.
 160                     */
 161
 162     setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
 163     prog_argc = argc;
 164     prog_argv = argv;
 165
 166 #if defined(PAR)
 167    /* Initialise the parallel system -- before initHeap! */
 168    initParallelSystem();
 169 #endif  /* PAR */
 170
 171 #if defined(PROFILING) || defined(PAR)
 172     if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
 173         fflush(stdout);
 174         fprintf(stderr, "init_cc_profiling failed!\n");
 175         EXIT(EXIT_FAILURE);
 176     }
 177 #endif
 178
 179 #if defined(CONCURRENT) && defined(GRAN)
 180     if (!no_gr_profile)
 181       if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
 182           fprintf(stderr, "init_gr_simulation failed!\n"); 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 # if defined(GRAN)                                                 /* HWL */
 269     /* RunnableThreadsHd etc. are init in ScheduleThreads */
 270     /*
 271      * I'm not sure about this.  Note that this code is for re-initializing
 272      * things when a longjmp to restart_main occurs.  --JSM
 273      */
 274
 275 # else                                                             /* !GRAN */
 276     AvailableStack = AvailableTSO = Nil_closure;
 277     RunnableThreadsHd = RunnableThreadsTl = Nil_closure;
 278     WaitingThreadsHd = WaitingThreadsTl = Nil_closure;
 279     PendingSparksHd[REQUIRED_POOL] =
 280       PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
 281     PendingSparksHd[ADVISORY_POOL] =
 282       PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
 283 # endif
 284
 285     CurrentTSO = Nil_closure;
 286
 287 # ifdef PAR
 288     RunParallelSystem(TopClosure);
 289 # else
 290     STKO_LINK(MainStkO) = Nil_closure;
 291     ScheduleThreads(TopClosure);
 292 # endif /* PAR */
 293
 294 #else   /* not threaded (sequential) */
 295
 296     miniInterpret((StgFunPtr)startStgWorld);
 297
 298 #endif /* !CONCURRENT */
 299
 300     shutdownHaskell();
 301     return(EXIT_SUCCESS);    /* don't use EXIT! :-) */
 302 }
 303 \end{code}
 304
 305 It should be possible to call @shutdownHaskell@ whenever you want to
 306 shut a Haskell program down in an orderly way.
 307
 308 Note that some of this code probably depends on the integrity of
 309 various internal data structures so this should not be called in
 310 response to detecting a catastrophic error.
 311
 312 \begin{code}
 313 void
 314 shutdownHaskell(STG_NO_ARGS)
 315 {
 316     STOP_TIME_PROFILER;
 317
 318     if (! exitSM(&StorageMgrInfo)) {
 319         fflush(stdout);
 320         fprintf(stderr, "exitSM failed!\n");
 321         EXIT(EXIT_FAILURE);
 322     }
 323
 324 #if defined(PROFILING)
 325     heap_profile_finish();
 326 #endif
 327 #if defined(PROFILING) || defined(PAR)
 328     report_cc_profiling(1 /* final */ );
 329 #endif
 330
 331 #if defined(TICKY_TICKY)
 332     if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
 333 #endif
 334
 335 #if defined(GRAN_CHECK) && defined(GRAN)
 336     if (PrintFetchMisses)
 337       fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);
 338
 339 # if defined(COUNT)
 340     fprintf(stderr,"COUNT statistics:\n");
 341     fprintf(stderr,"  Total number of updates: %u\n",nUPDs);
 342     fprintf(stderr,"  Needed to awaken BQ: %u with avg BQ len of: %f\n",
 343             nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
 344     fprintf(stderr,"  Number of PAPs: %u\n",nPAPs);
 345 # endif
 346
 347     if (!no_gr_profile)
 348       end_gr_simulation();
 349 #endif
 350
 351     fflush(stdout);
 352     /* This fflush is important, because: if "main" just returns,
 353        then we will end up in pre-supplied exit code that will close
 354        streams and flush buffers.  In particular we have seen: it
 355        will close fd 0 (stdin), then flush fd 1 (stdout), then <who
 356        cares>...
 357
 358        But if you're playing with sockets, that "close fd 0" might
 359        suggest to the daemon that all is over, only to be presented
 360        with more stuff on "fd 1" at the flush.
 361
 362        The fflush avoids this sad possibility.
 363     */
 364 }
 365 \end{code}
 366
 367 Sets up and returns a string indicating the date/time of the run.
 368 Successive calls simply return the same string again. Initially
 369 called by @main.lc@ to initialise the string at the start of the run.
 370 Only used for profiling.
 371
 372 \begin{code}
 373 #if defined(PROFILING) || defined(CONCURRENT)
 374 # include <time.h>
 375
 376 char *
 377 time_str(STG_NO_ARGS)
 378 {
 379     static time_t now = 0;
 380     static char nowstr[26];
 381
 382     if (now == 0) {
 383         time(&now);
 384         strcpy(nowstr, ctime(&now));
 385         strcpy(nowstr+16,nowstr+19);
 386         nowstr[21] = '\0';
 387     }
 388     return nowstr;
 389 }
 390 #endif /* profiling */
 391 \end{code}
 392
 393 ToDo: Will this work under threads?
 394
 395 \begin{code}
 396 StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
 397
 398 StgInt
 399 getErrorHandler(STG_NO_ARGS)
 400 {
 401   return (StgInt) errorHandler;
 402 }
 403
 404 #ifndef PAR
 405
 406 void
 407 raiseError( handler )
 408   StgStablePtr handler;
 409 {
 410   if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
 411     shutdownHaskell();
 412     EXIT(EXIT_FAILURE);
 413   } else {
 414     TopClosure = deRefStablePointer( handler );
 415     longjmp(restart_main,1);
 416   }
 417 }
 418 \end{code}
 419
 420 \begin{code}
 421 StgInt
 422 catchError( newErrorHandler )
 423   StgStablePtr newErrorHandler;
 424 {
 425   StgStablePtr oldErrorHandler = errorHandler;
 426   errorHandler = newErrorHandler;
 427   return oldErrorHandler;
 428 }
 429
 430 #endif
 431 \end{code}
 432
 433 If we have installed an error handler, we might want to
 434 indicate that we have successfully recovered from an error by
 435 decrementing the counter.
 436
 437 \begin{code}
 438 void
 439 decrementErrorCount()
 440 {
 441   ErrorIO_call_count-=1;
 442 }
 443
 444 \end{code}