From fa00cc50ecd1aa292657720b7594b7bdb82c970c Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Fri, 15 May 2009 16:08:14 +0000 Subject: [PATCH] Keep C main separate from rts lib and link it in for standalone progs Previously the object code for the C main function lived in the rts lib, however this is a problem when the rts is built as a shared lib. With Windows DLLs it always causes problems while on ELF systems it's a problem when the user decides to use their own C main function rather than a Haskell Main.main. So instead we now put main in it's own tiny little static lib libHSrtsmain.a which we install next to the rts libs. Whenever ghc links a program (without -no-hs-main) then it also links in -lHSrtsmain. For consistency we always do it this way now rather than trying to do it differently for static vs shared libraries. --- compiler/main/DriverPipeline.hs | 8 ++ rts/Main.c | 163 ++++------------------------------- rts/RtsMain.c | 179 +++++++++++++++++++++++++++++++++++++++ rts/RtsMain.h | 18 ++++ rts/ghc.mk | 14 ++- 5 files changed, 231 insertions(+), 151 deletions(-) create mode 100644 rts/RtsMain.c create mode 100644 rts/RtsMain.h diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index f8f0676..6c69307 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1379,6 +1379,13 @@ linkBinary dflags o_files dep_packages = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths + -- The C "main" function is not in the rts but in a separate static + -- library libHSrtsmain.a that sits next to the rts lib files. Assuming + -- we're using a Haskell main function then we need to link it in. + let no_hs_main = dopt Opt_NoHsMain dflags + let main_lib | no_hs_main = [] + | otherwise = [ "-lHSrtsmain" ] + pkg_link_opts <- getPackageLinkOpts dflags dep_packages #ifdef darwin_TARGET_OS @@ -1445,6 +1452,7 @@ linkBinary dflags o_files dep_packages = do ++ framework_opts #endif ++ pkg_lib_path_opts + ++ main_lib ++ pkg_link_opts #ifdef darwin_TARGET_OS ++ pkg_framework_path_opts diff --git a/rts/Main.c b/rts/Main.c index aff3011..58d3f37 100644 --- a/rts/Main.c +++ b/rts/Main.c @@ -1,162 +1,29 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team 1998-2000 + * (c) The GHC Team 2009 * - * Main function for a standalone Haskell program. + * The C main() function for a standalone Haskell program. + * + * Note that this is not part of the RTS. It calls into the RTS to get things + * going. It is compiled to a separate Main.o which is linked into every + * standalone Haskell program that uses a Haskell Main.main function + * (as opposed to a mixed Haskell C program using a C main function). * * ---------------------------------------------------------------------------*/ -#define COMPILING_RTS_MAIN - -#include "PosixSource.h" #include "Rts.h" -#include "RtsAPI.h" -#include "SchedAPI.h" -#include "RtsFlags.h" -#include "RtsUtils.h" -#include "Prelude.h" -#include "Task.h" -#if defined(mingw32_HOST_OS) -#include "win32/seh_excn.h" -#endif -#include - -#ifdef DEBUG -# include "Printer.h" /* for printing */ -#endif - -#ifdef PAR -# include "Parallel.h" -# include "ParallelRts.h" -# include "LLC.h" -#endif +#include "RtsMain.h" -#if defined(GRAN) || defined(PAR) -# include "GranSimRts.h" -#endif - -#ifdef HAVE_WINDOWS_H -# include -#endif - -extern void __stginit_ZCMain(void); - -static int progargc; -static char **progargv; - -/* Hack: we assume that we're building a batch-mode system unless - * INTERPRETER is set +/* The symbol for the Haskell Main module's init function. It is safe to refer + * to it here because this Main.o object file will only be linked in if we are + * linking a Haskell program that uses a Haskell Main.main function. */ -#ifndef INTERPRETER /* Hack */ -static void real_main(void) -{ - int exit_status; - SchedulerStatus status; - /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */ - - startupHaskell(progargc,progargv,__stginit_ZCMain); - - /* kick off the computation by creating the main thread with a pointer - to mainIO_closure representing the computation of the overall program; - then enter the scheduler with this thread and off we go; - - the same for GranSim (we have only one instance of this code) - - in a parallel setup, where we have many instances of this code - running on different PEs, we should do this only for the main PE - (IAmMainThread is set in startupHaskell) - */ - -# if defined(PAR) - -# if defined(DEBUG) - { /* a wait loop to allow attachment of gdb to UNIX threads */ - nat i, j, s; - - for (i=0, s=0; i<(nat)RtsFlags.ParFlags.wait; i++) - for (j=0; j<1000000; j++) - s += j % 65536; - } - IF_PAR_DEBUG(verbose, - belch("Passed wait loop")); -# endif - - if (IAmMainThread == rtsTrue) { - IF_PAR_DEBUG(verbose, - debugBelch("==== [%x] Main Thread Started ...\n", mytid)); - - /* ToDo: Dump event for the main thread */ - status = rts_mainLazyIO((HaskellObj)mainIO_closure, NULL); - } else { - /* Just to show we're alive */ - IF_PAR_DEBUG(verbose, - debugBelch("== [%x] Non-Main PE enters scheduler via taskStart() without work ...\n", - mytid)); - - /* all non-main threads enter the scheduler without work */ - taskStart(); - status = Success; // declare victory (see shutdownParallelSystem) - } - -# elif defined(GRAN) - - /* ToDo: Dump event for the main thread */ - status = rts_mainLazyIO(mainIO_closure, NULL); - -# else /* !PAR && !GRAN */ - - /* ToDo: want to start with a larger stack size */ - { - Capability *cap = rts_lock(); - cap = rts_evalLazyIO(cap,(HaskellObj)(void *)mainIO_closure, NULL); - status = rts_getSchedStatus(cap); - taskTimeStamp(myTask()); - rts_unlock(cap); - } +extern void __stginit_ZCMain(void); -# endif /* !PAR && !GRAN */ +/* Similarly, we can refer to the ZCMain_main_closure here */ +extern StgClosure ZCMain_main_closure; - /* check the status of the entire Haskell computation */ - switch (status) { - case Killed: - errorBelch("main thread exited (uncaught exception)"); - exit_status = EXIT_KILLED; - break; - case Interrupted: - errorBelch("interrupted"); - exit_status = EXIT_INTERRUPTED; - break; - case HeapExhausted: - exit_status = EXIT_HEAPOVERFLOW; - break; - case Success: - exit_status = EXIT_SUCCESS; - break; -#if defined(PAR) - case NoStatus: - errorBelch("main thread PE killed; probably due to failure of another PE; check /tmp/pvml..."); - exit_status = EXIT_KILLED; - break; -#endif - default: - barf("main thread completed with invalid status"); - } - shutdownHaskellAndExit(exit_status); -} int main(int argc, char *argv[]) { - /* We do this dance with argc and argv as otherwise the SEH exception - stuff (the BEGIN/END CATCH below) on Windows gets confused */ - progargc = argc; - progargv = argv; - -#if defined(mingw32_HOST_OS) - BEGIN_CATCH -#endif - real_main(); -#if defined(mingw32_HOST_OS) - END_CATCH -#endif - return 0; /* not reached, but keeps gcc -Wall happy */ + return hs_main(argc, argv, &__stginit_ZCMain, &ZCMain_main_closure); } -# endif /* BATCH_MODE */ diff --git a/rts/RtsMain.c b/rts/RtsMain.c new file mode 100644 index 0000000..aa2fe0f --- /dev/null +++ b/rts/RtsMain.c @@ -0,0 +1,179 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 1998-2000 + * + * Main function for a standalone Haskell program. + * + * ---------------------------------------------------------------------------*/ + +#define COMPILING_RTS_MAIN + +#include "PosixSource.h" +#include "Rts.h" +#include "RtsAPI.h" +#include "SchedAPI.h" +#include "RtsFlags.h" +#include "RtsUtils.h" +#include "RtsMain.h" +#include "Prelude.h" +#include "Task.h" +#if defined(mingw32_HOST_OS) +#include "win32/seh_excn.h" +#endif +#include + +#ifdef DEBUG +# include "Printer.h" /* for printing */ +#endif + +#ifdef PAR +# include "Parallel.h" +# include "ParallelRts.h" +# include "LLC.h" +#endif + +#if defined(GRAN) || defined(PAR) +# include "GranSimRts.h" +#endif + +#ifdef HAVE_WINDOWS_H +# include +#endif + +extern void __stginit_ZCMain(void); + +/* Annoying global vars for passing parameters to real_main() below + * This is to get around problem with Windows SEH, see hs_main(). */ +static int progargc; +static char **progargv; +static void (*progmain_init)(void); /* This will be __stginit_ZCMain */ +static StgClosure *progmain_closure; /* This will be ZCMain_main_closure */ + +/* Hack: we assume that we're building a batch-mode system unless + * INTERPRETER is set + */ +#ifndef INTERPRETER /* Hack */ +static void real_main(void) +{ + int exit_status; + SchedulerStatus status; + /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */ + + startupHaskell(progargc,progargv,progmain_init); + + /* kick off the computation by creating the main thread with a pointer + to mainIO_closure representing the computation of the overall program; + then enter the scheduler with this thread and off we go; + + the same for GranSim (we have only one instance of this code) + + in a parallel setup, where we have many instances of this code + running on different PEs, we should do this only for the main PE + (IAmMainThread is set in startupHaskell) + */ + +# if defined(PAR) + +# if defined(DEBUG) + { /* a wait loop to allow attachment of gdb to UNIX threads */ + nat i, j, s; + + for (i=0, s=0; i<(nat)RtsFlags.ParFlags.wait; i++) + for (j=0; j<1000000; j++) + s += j % 65536; + } + IF_PAR_DEBUG(verbose, + belch("Passed wait loop")); +# endif + + if (IAmMainThread == rtsTrue) { + IF_PAR_DEBUG(verbose, + debugBelch("==== [%x] Main Thread Started ...\n", mytid)); + + /* ToDo: Dump event for the main thread */ + status = rts_mainLazyIO(progmain_closure, NULL); + } else { + /* Just to show we're alive */ + IF_PAR_DEBUG(verbose, + debugBelch("== [%x] Non-Main PE enters scheduler via taskStart() without work ...\n", + mytid)); + + /* all non-main threads enter the scheduler without work */ + taskStart(); + status = Success; // declare victory (see shutdownParallelSystem) + } + +# elif defined(GRAN) + + /* ToDo: Dump event for the main thread */ + status = rts_mainLazyIO(progmain_closure, NULL); + +# else /* !PAR && !GRAN */ + + /* ToDo: want to start with a larger stack size */ + { + Capability *cap = rts_lock(); + cap = rts_evalLazyIO(cap,progmain_closure, NULL); + status = rts_getSchedStatus(cap); + taskTimeStamp(myTask()); + rts_unlock(cap); + } + +# endif /* !PAR && !GRAN */ + + /* check the status of the entire Haskell computation */ + switch (status) { + case Killed: + errorBelch("main thread exited (uncaught exception)"); + exit_status = EXIT_KILLED; + break; + case Interrupted: + errorBelch("interrupted"); + exit_status = EXIT_INTERRUPTED; + break; + case HeapExhausted: + exit_status = EXIT_HEAPOVERFLOW; + break; + case Success: + exit_status = EXIT_SUCCESS; + break; +#if defined(PAR) + case NoStatus: + errorBelch("main thread PE killed; probably due to failure of another PE; check /tmp/pvml..."); + exit_status = EXIT_KILLED; + break; +#endif + default: + barf("main thread completed with invalid status"); + } + shutdownHaskellAndExit(exit_status); +} + +/* The rts entry point from a compiled program using a Haskell main function. + * This gets called from a tiny main function which gets linked into each + * compiled Haskell program that uses a Haskell main function. + * + * We expect the caller to pass __stginit_ZCMain for main_init and + * ZCMain_main_closure for main_closure. The reason we cannot refer to + * these symbols directly is because we're inside the rts and we do not know + * for sure that we'll be using a Haskell main function. + */ +int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure) +{ + /* We do this dance with argc and argv as otherwise the SEH exception + stuff (the BEGIN/END CATCH below) on Windows gets confused */ + progargc = argc; + progargv = argv; + progmain_init = main_init; + progmain_closure = main_closure; + +#if defined(mingw32_HOST_OS) + BEGIN_CATCH +#endif + real_main(); +#if defined(mingw32_HOST_OS) + END_CATCH +#endif + return 0; /* not reached, but keeps gcc -Wall happy */ +} +# endif /* BATCH_MODE */ diff --git a/rts/RtsMain.h b/rts/RtsMain.h new file mode 100644 index 0000000..7810f6f --- /dev/null +++ b/rts/RtsMain.h @@ -0,0 +1,18 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2009 + * + * Entry point for standalone Haskell programs. + * + * ---------------------------------------------------------------------------*/ + +#ifndef RTSMAIN_H +#define RTSMAIN_H + +/* ----------------------------------------------------------------------------- + * The entry point for Haskell programs that use a Haskell main function + * -------------------------------------------------------------------------- */ + +extern int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure); + +#endif /* RTSMAIN_H */ diff --git a/rts/ghc.mk b/rts/ghc.mk index 169e4b1..d0719ee 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -19,7 +19,8 @@ rts_dist_HC = $(GHC_STAGE1) # merge GhcLibWays and GhcRTSWays but strip out duplicates rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays)) -ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf)) +ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf)) \ + rts/dist/build/libHSrtsmain.a all_rts : $(ALL_RTS_LIBS) # The per-dir options @@ -36,6 +37,7 @@ else ALL_DIRS += posix endif +EXCLUDED_SRCS += rts/Main.c EXCLUDED_SRCS += rts/parallel/SysMan.c EXCLUDED_SRCS += rts/dyn-wrapper.c EXCLUDED_SRCS += $(wildcard rts/Vis*.c) @@ -253,11 +255,11 @@ endif # XXX DQ is now the same on all platforms, so get rid of it DQ = \" -# If Main.c is built with optimisation then the SEH exception stuff on +# If RtsMain.c is built with optimisation then the SEH exception stuff on # Windows gets confused. # This has to be in HC rather than CC opts, as otherwise there's a # -optc-O2 that comes after it. -Main_HC_OPTS += -optc-O0 +RtsMain_HC_OPTS += -optc-O0 RtsMessages_CC_OPTS += -DProjectVersion=$(DQ)$(ProjectVersion)$(DQ) RtsUtils_CC_OPTS += -DProjectVersion=$(DQ)$(ProjectVersion)$(DQ) @@ -399,6 +401,12 @@ $(DYNWRAPPER_PROG): $(DYNWRAPPER_SRC) $(HC) -cpp -optc-include -optcdyn-wrapper-patchable-behaviour.h $(INPLACE_EXTRA_FLAGS) $< -o $@ # ----------------------------------------------------------------------------- +# build the static lib containing the C main symbol + +rts/dist/build/libHSrtsmain.a : rts/dist/build/Main.o + $(AR) $(EXTRA_AR_ARGS) $@ $< + +# ----------------------------------------------------------------------------- # The RTS package config # If -DDEBUG is in effect, adjust package conf accordingly.. -- 1.7.10.4