diff options
Diffstat (limited to 'rts')
| -rw-r--r-- | rts/Main.c | 24 | ||||
| -rw-r--r-- | rts/RtsFlags.c | 26 | ||||
| -rw-r--r-- | rts/RtsFlags.h | 4 | ||||
| -rw-r--r-- | rts/RtsMain.c | 19 | ||||
| -rw-r--r-- | rts/RtsMain.h | 19 | ||||
| -rwxr-xr-x | rts/RtsStartup.c | 14 | ||||
| -rw-r--r-- | rts/ThreadPaused.c | 132 | ||||
| -rw-r--r-- | rts/ghc.mk | 13 | ||||
| -rw-r--r-- | rts/hooks/RtsOpts.c | 14 |
9 files changed, 114 insertions, 151 deletions
diff --git a/rts/Main.c b/rts/Main.c deleted file mode 100644 index c7a559fc14..0000000000 --- a/rts/Main.c +++ /dev/null @@ -1,24 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (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); -} diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index d2b4945c19..d8bcf1c915 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -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); diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h index a6bfe0a924..73eb6688a6 100644 --- a/rts/RtsFlags.h +++ b/rts/RtsFlags.h @@ -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); diff --git a/rts/RtsMain.c b/rts/RtsMain.c index a822da9749..0f6ca82382 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -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 diff --git a/rts/RtsMain.h b/rts/RtsMain.h deleted file mode 100644 index e004480cce..0000000000 --- a/rts/RtsMain.h +++ /dev/null @@ -1,19 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (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 - * -------------------------------------------------------------------------- */ - -int hs_main(int argc, char *argv[], StgClosure *main_closure) - GNUC3_ATTRIBUTE(__noreturn__); - -#endif /* RTSMAIN_H */ diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index de8bf792c4..e8ed86c994 100755 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -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) @@ -106,6 +111,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) { // second and subsequent inits are ignored @@ -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 */ diff --git a/rts/ThreadPaused.c b/rts/ThreadPaused.c index a35a96232b..0507880e6a 100644 --- a/rts/ThreadPaused.c +++ b/rts/ThreadPaused.c @@ -28,14 +28,58 @@ struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; }; +static struct stack_gap * +updateAdjacentFrames (Capability *cap, StgTSO *tso, + StgUpdateFrame *upd, nat count, struct stack_gap *next) +{ + StgClosure *updatee; + struct stack_gap *gap; + nat i; + + // The first one (highest address) is the frame we take the + // "master" updatee from; all the others will be made indirections + // to this one. It is essential that we do it this way around: we + // used to make the lowest-addressed frame the "master" frame and + // shuffle it down, but a bad case cropped up (#5505) where this + // happened repeatedly, generating a chain of indirections which + // the GC repeatedly traversed (indirection chains longer than one + // are not supposed to happen). So now after identifying a block + // of adjacent update frames we walk downwards again updating them + // all to point to the highest one, before squeezing out all but + // the highest one. + updatee = upd->updatee; + count--; + + upd--; + gap = (struct stack_gap*)upd; + + for (i = count; i > 0; i--, upd--) { + /* + * Check two things: that the two update frames + * don't point to the same object, and that the + * updatee_bypass isn't already an indirection. + * Both of these cases only happen when we're in a + * block hole-style loop (and there are multiple + * update frames on the stack pointing to the same + * closure), but they can both screw us up if we + * don't check. + */ + if (upd->updatee != updatee && !closure_IND(upd->updatee)) { + updateThunk(cap, tso, upd->updatee, updatee); + } + } + + gap->gap_size = count * sizeofW(StgUpdateFrame); + gap->next_gap = next; + + return gap; +} + static void stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) { StgPtr frame; - rtsBool prev_was_update_frame; - StgClosure *updatee = NULL; - StgRetInfoTable *info; - StgWord current_gap_size; + nat adjacent_update_frames; struct stack_gap *gap; // Stage 1: @@ -48,75 +92,43 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) ASSERT(frame < bottom); - prev_was_update_frame = rtsFalse; - current_gap_size = 0; + adjacent_update_frames = 0; gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame)); - while (frame <= bottom) { - - info = get_ret_itbl((StgClosure *)frame); - switch (info->i.type) { + while (frame <= bottom) + { + switch (get_ret_itbl((StgClosure *)frame)->i.type) { - case UPDATE_FRAME: + case UPDATE_FRAME: { - StgUpdateFrame *upd = (StgUpdateFrame *)frame; - - if (prev_was_update_frame) { + if (adjacent_update_frames > 0) { + TICK_UPD_SQUEEZED(); + } + adjacent_update_frames++; - TICK_UPD_SQUEEZED(); - /* wasn't there something about update squeezing and ticky to be - * sorted out? oh yes: we aren't counting each enter properly - * in this case. See the log somewhere. KSW 1999-04-21 - * - * Check two things: that the two update frames don't point to - * the same object, and that the updatee_bypass isn't already an - * indirection. Both of these cases only happen when we're in a - * block hole-style loop (and there are multiple update frames - * on the stack pointing to the same closure), but they can both - * screw us up if we don't check. - */ - if (upd->updatee != updatee && !closure_IND(upd->updatee)) { - updateThunk(cap, tso, upd->updatee, updatee); - } - - // now mark this update frame as a stack gap. The gap - // marker resides in the bottom-most update frame of - // the series of adjacent frames, and covers all the - // frames in this series. - current_gap_size += sizeofW(StgUpdateFrame); - ((struct stack_gap *)frame)->gap_size = current_gap_size; - ((struct stack_gap *)frame)->next_gap = gap; - - frame += sizeofW(StgUpdateFrame); - continue; - } - - // single update frame, or the topmost update frame in a series - else { - prev_was_update_frame = rtsTrue; - updatee = upd->updatee; - frame += sizeofW(StgUpdateFrame); - continue; - } - } + frame += sizeofW(StgUpdateFrame); + continue; + } default: - prev_was_update_frame = rtsFalse; - - // we're not in a gap... check whether this is the end of a gap + // we're not in a gap... check whether this is the end of a gap // (an update frame can't be the end of a gap). - if (current_gap_size != 0) { - gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame)); - } - current_gap_size = 0; + if (adjacent_update_frames > 1) { + gap = updateAdjacentFrames(cap, tso, + (StgUpdateFrame*)(frame - sizeofW(StgUpdateFrame)), + adjacent_update_frames, gap); + } + adjacent_update_frames = 0; frame += stack_frame_sizeW((StgClosure *)frame); continue; } } - if (current_gap_size != 0) { - gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame)); + if (adjacent_update_frames > 1) { + gap = updateAdjacentFrames(cap, tso, + (StgUpdateFrame*)(frame - sizeofW(StgUpdateFrame)), + adjacent_update_frames, gap); } // Now we have a stack with gaps in it, and we have to walk down @@ -349,7 +361,7 @@ end: debugTrace(DEBUG_squeeze, "words_to_squeeze: %d, weight: %d, squeeze: %s", words_to_squeeze, weight, - weight < words_to_squeeze ? "YES" : "NO"); + ((weight <= 8 && words_to_squeeze > 0) || weight < words_to_squeeze) ? "YES" : "NO"); // Should we squeeze or not? Arbitrary heuristic: we squeeze if // the number of words we have to shift down is less than the diff --git a/rts/ghc.mk b/rts/ghc.mk index 54c941d019..40ff02fcc4 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -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) @@ -485,15 +483,6 @@ $(DTRACEPROBES_H): $(DTRACEPROBES_SRC) includes/ghcplatform.h | $$(dir $$@)/. 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 # If -DDEBUG is in effect, adjust package conf accordingly.. diff --git a/rts/hooks/RtsOpts.c b/rts/hooks/RtsOpts.c deleted file mode 100644 index 2aae37246e..0000000000 --- a/rts/hooks/RtsOpts.c +++ /dev/null @@ -1,14 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * 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; |