Commit 1df28a80 authored by Simon Marlow's avatar Simon Marlow

Generate the C main() function when linking a binary (fixes #5373)

Rather than have main() be statically compiled as part of the RTS, we
now generate it into the tiny C file that we compile when linking a
binary.

The main motivation is that we want to pass the settings for the
-rtsotps and -with-rtsopts flags into the RTS, rather than relying on
fragile linking semantics to override the defaults, which don't work
with DLLs on Windows (#5373).  In order to do this, we need to extend
the API for initialising the RTS, so now we have:

void hs_init_ghc (int *argc, char **argv[],   // program arguments
                  RtsConfig rts_config);      // RTS configuration

hs_init_ghc() can optionally be used instead of hs_init(), and allows
passing in configuration options for the RTS.  RtsConfig is a struct,
which currently has two fields:

typedef struct {
    RtsOptsEnabledEnum rts_opts_enabled;
    const char *rts_opts;
} RtsConfig;

but might have more in the future.  There is a default value for the
struct, defaultRtsConfig, the idea being that you start with this and
override individual fields as necessary.

In fact, main() was in a separate static library, libHSrtsmain.a.
That's now gone.
parent 1790dbe4
......@@ -1437,25 +1437,39 @@ mkExtraCObj dflags xs
++ map (FileOption "-I") (includeDirs rtsDetails))
return oFile
-- When linking a binary, we need to create a C main() function that
-- starts everything off. This used to be compiled statically as part
-- of the RTS, but that made it hard to change the -rtsopts setting,
-- so now we generate and compile a main() stub as part of every
-- binary and pass the -rtsopts setting directly to the RTS (#5373)
--
mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
mkExtraObjToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled,
extra_rts_opts,
mkExtraCObj dflags (showSDoc (vcat [main,
link_opts link_info]
<> char '\n')) -- final newline, to
-- keep gcc happy
where
rts_opts_enabled
= vcat [text "#include \"Rts.h\"",
text "#include \"RtsOpts.h\"",
text "const RtsOptsEnabledEnum rtsOptsEnabled = " <>
text (show (rtsOptsEnabled dflags)) <> semi ]
extra_rts_opts = case rtsOpts dflags of
Nothing -> empty
Just opts -> text "char *ghc_rts_opts = " <> text (show opts) <> semi
main
| dopt Opt_NoHsMain dflags = empty
| otherwise = vcat [
ptext (sLit "#include \"Rts.h\""),
ptext (sLit "extern StgClosure ZCMain_main_closure;"),
ptext (sLit "int main(int argc, char *argv[])"),
char '{',
ptext (sLit " RtsConfig __conf = defaultRtsConfig;"),
ptext (sLit " __conf.rts_opts_enabled = ")
<> text (show (rtsOptsEnabled dflags)) <> semi,
case rtsOpts dflags of
Nothing -> empty
Just opts -> ptext (sLit " __conf.rts_opts= ") <>
text (show opts) <> semi,
ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"),
char '}'
]
link_opts info
| not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
......@@ -1607,13 +1621,6 @@ 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" ]
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
pkg_link_opts <- getPackageLinkOpts dflags dep_packages
......@@ -1731,7 +1738,6 @@ linkBinary dflags o_files dep_packages = do
++ framework_path_opts
++ framework_opts
++ pkg_lib_path_opts
++ main_lib
++ [extraLinkObj]
++ pkg_link_opts
++ pkg_framework_path_opts
......@@ -1852,8 +1858,6 @@ linkDynLib dflags o_files dep_packages = do
let extra_ld_opts = getOpts dflags opt_l
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
#if defined(mingw32_HOST_OS)
-----------------------------------------------------------------------------
-- Making a DLL
......@@ -1880,7 +1884,6 @@ linkDynLib dflags o_files dep_packages = do
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ [extraLinkObj]
++ pkg_link_opts
))
#elif defined(darwin_TARGET_OS)
......@@ -1936,7 +1939,6 @@ linkDynLib dflags o_files dep_packages = do
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ [extraLinkObj]
++ pkg_link_opts
))
#else
......@@ -1970,7 +1972,6 @@ linkDynLib dflags o_files dep_packages = do
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ [extraLinkObj]
++ pkg_link_opts
))
#endif
......
......@@ -213,6 +213,7 @@ void _assertFail(const char *filename, unsigned int linenum)
#include "rts/TTY.h"
#include "rts/Utils.h"
#include "rts/PrimFloat.h"
#include "rts/Main.h"
/* Misc stuff without a home */
DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
......
......@@ -37,27 +37,65 @@ typedef struct StgClosure_ *HaskellObj;
*/
typedef struct Capability_ Capability;
/* ----------------------------------------------------------------------------
RTS configuration settings, for passing to hs_init_ghc()
------------------------------------------------------------------------- */
typedef enum {
RtsOptsNone, // +RTS causes an error
RtsOptsSafeOnly, // safe RTS options allowed; others cause an error
RtsOptsAll // all RTS options allowed
} RtsOptsEnabledEnum;
// The RtsConfig struct is passed (by value) to hs_init_ghc(). The
// reason for using a struct is extensibility: we can add more
// fields to this later without breaking existing client code.
typedef struct {
RtsOptsEnabledEnum rts_opts_enabled;
const char *rts_opts;
} RtsConfig;
// Clients should start with defaultRtsConfig and then customise it.
// Bah, I really wanted this to be a const struct value, but it seems
// you can't do that in C (it generates code).
extern const RtsConfig defaultRtsConfig;
/* ----------------------------------------------------------------------------
Starting up and shutting down the Haskell RTS.
------------------------------------------------------------------------- */
extern void startupHaskell ( int argc, char *argv[],
/* DEPRECATED, use hs_init() or hs_init_ghc() instead */
extern void startupHaskell ( int argc, char *argv[],
void (*init_root)(void) );
/* DEPRECATED, use hs_exit() instead */
extern void shutdownHaskell ( void );
/*
* GHC-specific version of hs_init() that allows specifying whether
* +RTS ... -RTS options are allowed or not (default: only "safe"
* options are allowed), and allows passing an option string that is
* to be interpreted by the RTS only, not passed to the program.
*/
extern void hs_init_ghc (int *argc, char **argv[], // program arguments
RtsConfig rts_config); // RTS configuration
extern void shutdownHaskellAndExit ( int exitCode )
#if __GNUC__ >= 3
__attribute__((__noreturn__))
#endif
;
#ifndef mingw32_HOST_OS
extern void shutdownHaskellAndSignal (int sig);
#endif
extern void getProgArgv ( int *argc, char **argv[] );
extern void setProgArgv ( int argc, char *argv[] );
extern void getFullProgArgv ( int *argc, char **argv[] );
extern void setFullProgArgv ( int argc, char *argv[] );
extern void freeFullProgArgv ( void ) ;
#ifndef mingw32_HOST_OS
extern void shutdownHaskellAndSignal (int sig);
#endif
/* exit() override */
extern void (*exitFn)(int);
......
/* -----------------------------------------------------------------------------
*
* (c) The GHC Team, 2010
*
* En/disable RTS options
*
* ---------------------------------------------------------------------------*/
#ifndef RTSOPTS_H
#define RTSOPTS_H
typedef enum {
RtsOptsNone, // +RTS causes an error
RtsOptsSafeOnly, // safe RTS options allowed; others cause an error
RtsOptsAll // all RTS options allowed
} RtsOptsEnabledEnum;
extern const RtsOptsEnabledEnum rtsOptsEnabled;
#endif /* RTSOPTS_H */
......@@ -13,7 +13,9 @@
* The entry point for Haskell programs that use a Haskell main function
* -------------------------------------------------------------------------- */
int hs_main(int argc, char *argv[], StgClosure *main_closure)
int hs_main (int argc, char *argv[], // program args
StgClosure *main_closure, // closure for Main.main
RtsConfig rts_config) // RTS configuration
GNUC3_ATTRIBUTE(__noreturn__);
#endif /* RTSMAIN_H */
/* -----------------------------------------------------------------------------
*
* (c) The GHC Team 2009
*
* 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).
*
* ---------------------------------------------------------------------------*/
#include "PosixSource.h"
#include "Rts.h"
#include "RtsMain.h"
/* Similarly, we can refer to the ZCMain_main_closure here */
extern StgClosure ZCMain_main_closure;
int main(int argc, char *argv[])
{
return hs_main(argc, argv, &ZCMain_main_closure);
}
......@@ -10,7 +10,6 @@
#include "PosixSource.h"
#include "Rts.h"
#include "RtsOpts.h"
#include "RtsUtils.h"
#include "Profiling.h"
#include "RtsFlags.h"
......@@ -396,9 +395,10 @@ strequal(const char *a, const char * b)
return(strcmp(a, b) == 0);
}
static void splitRtsFlags(char *s)
static void splitRtsFlags(const char *s)
{
char *c1, *c2;
const char *c1, *c2;
char *t;
c1 = s;
do {
......@@ -408,10 +408,10 @@ static void splitRtsFlags(char *s)
if (c1 == c2) { break; }
s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
strncpy(s, c1, c2-c1);
s[c2-c1] = '\0';
rts_argv[rts_argc++] = s;
t = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
strncpy(t, c1, c2-c1);
t[c2-c1] = '\0';
rts_argv[rts_argc++] = t;
c1 = c2;
} while (*c1 != '\0');
......@@ -434,7 +434,9 @@ static void splitRtsFlags(char *s)
-------------------------------------------------------------------------- */
void setupRtsFlags (int *argc, char *argv[])
void setupRtsFlags (int *argc, char *argv[],
RtsOptsEnabledEnum rtsOptsEnabled,
const char *ghc_rts_opts)
{
nat mode;
nat total_arg;
......@@ -554,14 +556,14 @@ static void checkUnsafe(RtsOptsEnabledEnum enabled)
}
}
static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled)
static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum rtsOptsEnabled)
{
rtsBool error = rtsFalse;
int arg;
if (!(rts_argc0 < rts_argc)) return;
if (enabled == RtsOptsNone) {
if (rtsOptsEnabled == RtsOptsNone) {
errorBelch("RTS options are disabled. Link with -rtsopts to enable them.");
stg_exit(EXIT_FAILURE);
}
......@@ -578,7 +580,7 @@ static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled)
rtsBool option_checked = rtsFalse;
#define OPTION_SAFE option_checked = rtsTrue;
#define OPTION_UNSAFE checkUnsafe(enabled); option_checked = rtsTrue;
#define OPTION_UNSAFE checkUnsafe(rtsOptsEnabled); option_checked = rtsTrue;
if (rts_argv[arg][0] != '-') {
fflush(stdout);
......@@ -1142,7 +1144,7 @@ error = rtsTrue;
errorBelch("bad value for -N");
error = rtsTrue;
}
if (enabled == RtsOptsSafeOnly &&
if (rtsOptsEnabled == RtsOptsSafeOnly &&
nNodes > (int)getNumberOfProcessors()) {
errorBelch("Using large values for -N is not allowed by default. Link with -rtsopts to allow full control.");
stg_exit(EXIT_FAILURE);
......
......@@ -15,7 +15,9 @@
/* Routines that operate-on/to-do-with RTS flags: */
void initRtsFlagsDefaults (void);
void setupRtsFlags (int *argc, char *argv[]);
void setupRtsFlags (int *argc, char *argv[],
RtsOptsEnabledEnum rtsOptsEnabled,
const char *ghc_rts_opts);
void setProgName (char *argv[]);
void freeRtsArgs (void);
......
......@@ -13,7 +13,6 @@
#include "RtsAPI.h"
#include "RtsUtils.h"
#include "RtsMain.h"
#include "Prelude.h"
#include "Task.h"
#if defined(mingw32_HOST_OS)
......@@ -33,8 +32,9 @@
static int progargc;
static char **progargv;
static StgClosure *progmain_closure; /* This will be ZCMain_main_closure */
static RtsConfig rtsconfig;
/* Hack: we assume that we're building a batch-mode system unless
/* Hack: we assume that we're building a batch-mode system unless
* INTERPRETER is set
*/
#ifndef INTERPRETER /* Hack */
......@@ -43,9 +43,8 @@ static void real_main(void)
{
int exit_status;
SchedulerStatus status;
/* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */
startupHaskell(progargc,progargv,NULL);
hs_init_ghc(&progargc, &progargv, rtsconfig);
/* kick off the computation by creating the main thread with a pointer
to mainIO_closure representing the computation of the overall program;
......@@ -89,22 +88,26 @@ static void real_main(void)
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.
/* The rts entry point from a compiled program using a Haskell main
* function. This gets called from a tiny main function generated by
* GHC and linked into each compiled Haskell program that uses a
* Haskell main function.
*
* We expect the caller to pass ZCMain_main_closure for
* main_closure. The reason we cannot refer to this symbol 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[], StgClosure *main_closure)
int hs_main (int argc, char *argv[], // program args
StgClosure *main_closure, // closure for Main.main
RtsConfig rts_config) // RTS configuration
{
/* 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_closure = main_closure;
rtsconfig = rts_config;
#if defined(mingw32_HOST_OS)
BEGIN_CATCH
......
......@@ -71,6 +71,11 @@ static int hs_init_count = 0;
static void flushStdHandles(void);
const RtsConfig defaultRtsConfig = {
.rts_opts_enabled = RtsOptsSafeOnly,
.rts_opts = NULL
};
/* -----------------------------------------------------------------------------
Initialise floating point unit on x86 (currently disabled; See Note
[x86 Floating point precision] in compiler/nativeGen/X86/Instr.hs)
......@@ -105,6 +110,12 @@ x86_init_fpu ( void )
void
hs_init(int *argc, char **argv[])
{
hs_init_ghc(argc, argv, defaultRtsConfig);
}
void
hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
{
hs_init_count++;
if (hs_init_count > 1) {
......@@ -132,7 +143,8 @@ hs_init(int *argc, char **argv[])
/* Parse the flags, separating the RTS flags from the programs args */
if (argc != NULL && argv != NULL) {
setFullProgArgv(*argc,*argv);
setupRtsFlags(argc, *argv);
setupRtsFlags(argc, *argv,
rts_config.rts_opts_enabled, rts_config.rts_opts);
}
/* Initialise the stats department, phase 1 */
......
......@@ -20,8 +20,7 @@ rts_dist_HC = $(GHC_STAGE1)
rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays))
rts_dist_WAYS = $(rts_WAYS)
ALL_RTS_LIBS = rts/dist/build/libHSrtsmain.a \
$(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf))
ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf))
all_rts : $(ALL_RTS_LIBS)
# -----------------------------------------------------------------------------
......@@ -36,7 +35,6 @@ ALL_DIRS += posix
endif
EXCLUDED_SRCS :=
EXCLUDED_SRCS += rts/Main.c
EXCLUDED_SRCS += rts/parallel/SysMan.c
EXCLUDED_SRCS += $(wildcard rts/Vis*.c)
......@@ -484,15 +482,6 @@ $(DTRACEPROBES_H): $(DTRACEPROBES_SRC) includes/ghcplatform.h | $$(dir $$@)/.
"$(DTRACE)" $(filter -I%,$(rts_CC_OPTS)) -C $(DTRACE_FLAGS) -h -o $@ -s $<
endif
# -----------------------------------------------------------------------------
# build the static lib containing the C main symbol
ifneq "$(BINDIST)" "YES"
rts/dist/build/libHSrtsmain.a : rts/dist/build/Main.o
"$(RM)" $(RM_OPTS) $@
"$(AR_STAGE1)" $(AR_OPTS_STAGE1) $(EXTRA_AR_ARGS_STAGE1) $@ $<
endif
# -----------------------------------------------------------------------------
# The RTS package config
......
/* -----------------------------------------------------------------------------
*
* Default RTS options.
*
* ---------------------------------------------------------------------------*/
#include "PosixSource.h"
#include "Rts.h"
#include <stdlib.h>
// Default RTS options can be given by providing an alternate
// definition for this variable, pointing to a string of RTS options.
char *ghc_rts_opts = NULL;
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment