%/****************************************************************
%*								*
%*	This is where everything starts 			*
%*								*
%****************************************************************/

\begin{code}
#if defined(PROFILING) || defined(PAR) || defined(CONCURRENT)
#define NON_POSIX_SOURCE /* time things on Solaris -- sigh */
#endif

#include "rtsdefs.h"
#include <setjmp.h>

#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
# include <string.h>
/* An ANSI string.h and pre-ANSI memory.h might conflict.  */
# if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
#  include <memory.h>
# endif /* not STDC_HEADERS and HAVE_MEMORY_H */

#else /* not STDC_HEADERS and not HAVE_STRING_H */
# include <strings.h>
/* memory.h and strings.h conflict on some systems.  */
#endif /* not STDC_HEADERS and not HAVE_STRING_H */

#if defined(PROFILING) || defined(PAR)
/* need some "time" things */

/* ToDo: This is a mess! Improve ? */

# ifdef HAVE_SYS_TYPES_H
#  include <sys/types.h>
# endif

# ifdef HAVE_SYS_TIMES_H
#  include <sys/times.h>
# endif

# ifdef HAVE_SYS_TIME_H
#  include <sys/time.h>
# endif
#endif /* PROFILING || PAR */

#ifndef PAR
STGRegisterTable MainRegTable;
#endif

/* fwd decls */
void shutdownHaskell(STG_NO_ARGS);

EXTFUN(startStgWorld);
extern void PrintTickyInfo(STG_NO_ARGS);
extern void checkAStack(STG_NO_ARGS);

/* a real nasty Global Variable */
/* moved to main/TopClosure(13)?.lc -- *one* of them will get linked in
P_ TopClosure = Main_mainPrimIO_closure;
 */

/* structure to carry around info about the storage manager */
smInfo StorageMgrInfo;

#ifdef PAR
extern I_ 	OkToGC, buckets;
extern rtsBool	TraceSparks, DelaySparks,
    	    	DeferGlobalUpdates;

extern void RunParallelSystem PROTO((P_));
extern void initParallelSystem(STG_NO_ARGS);
extern void SynchroniseSystem(STG_NO_ARGS);

extern void SetTrace PROTO((W_ address, I_ level/*?*/));
#endif

#if defined(GRAN_CHECK) && defined(GRAN)
extern W_ debug;
extern W_ event_trace ;
extern W_ event_trace_all ;
#endif

extern void *stgAllocForGMP   PROTO((size_t));
extern void *stgReallocForGMP PROTO ((void *, size_t, size_t));
extern void  stgDeallocForGMP PROTO ((void *, size_t));

/* NeXTs can't just reach out and touch "end", to use in
   distinguishing things in static vs dynamic (malloc'd) memory.
*/
#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
void *get_end_result;
#endif

int   prog_argc; /* an "int" so as to match normal "argc" */
char  **prog_argv;
int   rts_argc;  /* ditto */
char *rts_argv[MAX_RTS_ARGS];

#ifndef PAR
jmp_buf restart_main;	    /* For restarting after a signal */
#endif

#if defined(PVM)
unsigned nPEs = 0, nIMUs = 0;
#endif

#if defined(PAR)
int nPEs = 0;
#endif

int /* return type of "main" is defined by the C standard */
main(int argc, char *argv[])
{
\end{code}

The very first thing we do is grab the start time...just in case we're
collecting timing statistics.

\begin{code}
    start_time();
\end{code}

The parallel system needs to be initialised and synchronised before
the program is run.  This is done {\em before} heap allocation, so we
can grab all remaining heap without needing to consider the System
Manager's requirements.

\begin{code}
#ifdef PAR
    /* 
     * Grab the number of PEs out of the argument vector, and
     * eliminate it from further argument processing.
     */
    nPEs = atoi(argv[1]);
    argv[1] = argv[0];
    argv++;
    argc--;

    SynchroniseSystem();
#endif

#if defined(PROFILING) || defined(PAR)
    /* setup string indicating time of run -- only used for profiling */
    (void) time_str();
#endif

#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
    get_end_result = get_end();
#endif

    /* 
       divide the command-line args between pgm and RTS; figure out
       what statsfile to use (if any); [if so, write the whole
       cmd-line into it]
       
       This is unlikely to work well in parallel!  KH.
    */
    initRtsFlagsDefaults();
    defaultsHook(); /* the one supplied does nothing;
		       the user may have supplied a more interesting one.
		    */

    setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
    prog_argc = argc;
    prog_argv = argv;

#if defined(PAR)
   /* Initialise the parallel system -- before initHeap! */
   initParallelSystem();
#endif	/* PAR */

#if defined(PROFILING) || defined(PAR)
    if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
        fflush(stdout);
	fprintf(stderr, "init_cc_profiling failed!\n");
	EXIT(EXIT_FAILURE);
    }
#endif

#if defined(CONCURRENT) && defined(GRAN)
    if (!no_gr_profile)
      if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
	  fprintf(stderr, "init_gr_simulation failed!\n"); EXIT(EXIT_FAILURE);
      }
#endif

#ifdef PAR
    if (RTSflags.ParFlags.granSimStats)
	init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
#endif

    /* initialize the storage manager */
    initSM();

#ifndef PAR
    if (! initStacks( &StorageMgrInfo )) {
        fflush(stdout);
	fprintf(stderr, "initStacks failed!\n");
	EXIT(EXIT_FAILURE);
    }
#endif

    if (! initHeap( &StorageMgrInfo )) {
        fflush(stdout);
	fprintf(stderr, "initHeap failed!\n");
	EXIT(EXIT_FAILURE);
    }

#if defined(CONCURRENT) && !defined(GRAN)
    if (!initThreadPools()) {
        fflush(stdout);
	fprintf(stderr, "initThreadPools failed!\n"); 
        EXIT(EXIT_FAILURE);
    }
#endif

#if defined(PROFILING) || defined(PAR)
    /* call cost centre registering routine (after heap allocated) */
    cc_register();
#endif

#if defined(TICKY_TICKY)
    max_SpA = MAIN_SpA; /* initial high-water marks */
    max_SpB = MAIN_SpB;
#endif

    /* Tell GNU multi-precision pkg about our custom alloc functions */
    mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);

    /* Record initialization times */
    end_init();

#if defined(PROFILING) || defined(CONCURRENT)
    /* 
     * Both the context-switcher and the cost-center profiler use 
     * a virtual timer.
     */
    if (install_vtalrm_handler()) {
	fflush(stdout);
	fprintf(stderr, "Can't install VTALRM handler.\n");
	EXIT(EXIT_FAILURE);
    }
#if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
    if (! time_profiling)
	RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
    else {
	if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
	    RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
	else
	    RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;

	RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
	RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
    }
#endif

#ifndef CONCURRENT
    START_TIME_PROFILER;
#endif

#endif	/* PROFILING || CONCURRENT */

#ifndef PAR
    setjmp(restart_main);
    initUserSignals();
#endif

#ifdef CONCURRENT
# if defined(GRAN)                                                 /* HWL */
    /* RunnableThreadsHd etc. are init in ScheduleThreads */
    /* 
     * I'm not sure about this.  Note that this code is for re-initializing
     * things when a longjmp to restart_main occurs.  --JSM
     */

# else                                                             /* !GRAN */
    AvailableStack = AvailableTSO = Nil_closure;
    RunnableThreadsHd = RunnableThreadsTl = Nil_closure;
    WaitingThreadsHd = WaitingThreadsTl = Nil_closure;
    PendingSparksHd[REQUIRED_POOL] = 
      PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
    PendingSparksHd[ADVISORY_POOL] = 
      PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
# endif

    CurrentTSO = Nil_closure;

# ifdef PAR
    RunParallelSystem(TopClosure);
# else
    STKO_LINK(MainStkO) = Nil_closure;
    ScheduleThreads(TopClosure);
# endif	/* PAR */

#else	/* not threaded (sequential) */

    miniInterpret((StgFunPtr)startStgWorld);

#endif /* !CONCURRENT */

    shutdownHaskell();
    return(EXIT_SUCCESS);    /* don't use EXIT! :-) */
}
\end{code}

It should be possible to call @shutdownHaskell@ whenever you want to
shut a Haskell program down in an orderly way.

Note that some of this code probably depends on the integrity of
various internal data structures so this should not be called in
response to detecting a catastrophic error.

\begin{code}
void
shutdownHaskell(STG_NO_ARGS)
{
    STOP_TIME_PROFILER;

    if (! exitSM(&StorageMgrInfo)) {
	fflush(stdout);
	fprintf(stderr, "exitSM failed!\n");
	EXIT(EXIT_FAILURE);
    }

#if defined(PROFILING)
    heap_profile_finish();
#endif
#if defined(PROFILING) || defined(PAR)
    report_cc_profiling(1 /* final */ );
#endif

#if defined(TICKY_TICKY)
    if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif

#if defined(GRAN_CHECK) && defined(GRAN)
    if (PrintFetchMisses)
      fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);

# if defined(COUNT)
    fprintf(stderr,"COUNT statistics:\n");
    fprintf(stderr,"  Total number of updates: %u\n",nUPDs);
    fprintf(stderr,"  Needed to awaken BQ: %u with avg BQ len of: %f\n",
	    nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
    fprintf(stderr,"  Number of PAPs: %u\n",nPAPs);
# endif

    if (!no_gr_profile)
      end_gr_simulation();
#endif

    fflush(stdout);
    /* This fflush is important, because: if "main" just returns,
       then we will end up in pre-supplied exit code that will close
       streams and flush buffers.  In particular we have seen: it
       will close fd 0 (stdin), then flush fd 1 (stdout), then <who
       cares>...

       But if you're playing with sockets, that "close fd 0" might
       suggest to the daemon that all is over, only to be presented
       with more stuff on "fd 1" at the flush.

       The fflush avoids this sad possibility.
    */
}
\end{code}

Sets up and returns a string indicating the date/time of the run.
Successive calls simply return the same string again. Initially
called by @main.lc@ to initialise the string at the start of the run.
Only used for profiling.

\begin{code}
#if defined(PROFILING) || defined(CONCURRENT)
# include <time.h>

char *
time_str(STG_NO_ARGS)
{
    static time_t now = 0;
    static char nowstr[26];

    if (now == 0) {
	time(&now);
	strcpy(nowstr, ctime(&now));
	strcpy(nowstr+16,nowstr+19);
	nowstr[21] = '\0';
    }
    return nowstr;
}
#endif /* profiling */
\end{code}

ToDo: Will this work under threads?

\begin{code}
StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */

StgInt
getErrorHandler(STG_NO_ARGS)
{
  return (StgInt) errorHandler;
}

#ifndef PAR

void
raiseError( handler )
  StgStablePtr handler;
{
  if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
    shutdownHaskell();
    EXIT(EXIT_FAILURE);
  } else {
    TopClosure = deRefStablePointer( handler );
    longjmp(restart_main,1);
  }
}
\end{code}

\begin{code}
StgInt
catchError( newErrorHandler )
  StgStablePtr newErrorHandler;
{
  StgStablePtr oldErrorHandler = errorHandler;
  errorHandler = newErrorHandler;
  return oldErrorHandler;
}

#endif
\end{code}

If we have installed an error handler, we might want to
indicate that we have successfully recovered from an error by
decrementing the counter.

\begin{code}
void
decrementErrorCount()
{
  ErrorIO_call_count-=1;	
}

\end{code}