\begin{code}
fixedHdrSize :: WordOff
-fixedHdrSize = sTD_HDR_SIZE + profHdrSize + granHdrSize
+fixedHdrSize = sTD_HDR_SIZE + profHdrSize
profHdrSize :: WordOff
profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE
| otherwise = 0
-granHdrSize :: WordOff
-granHdrSize | opt_GranMacros = gRAN_HDR_SIZE
- | otherwise = 0
-
arrWordsHdrSize :: ByteOff
arrWordsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr
pROF_HDR_SIZE :: Int
pROF_HDR_SIZE = PROF_HDR_SIZE
-
-gRAN_HDR_SIZE :: Int
-gRAN_HDR_SIZE = GRAN_HDR_SIZE
\end{code}
Size of a double in StgWords.
#define SET_STATIC_PROF_HDR(ccs)
#endif
-#ifdef GRAN
-#define SET_GRAN_HDR(c,pe) (c)->header.gran.procs = pe
-#define SET_STATIC_GRAN_HDR gran : { procs : Everywhere },
-#else
-#define SET_GRAN_HDR(c,pe)
-#define SET_STATIC_GRAN_HDR
-#endif
-
-#ifdef PAR
-#define SET_PAR_HDR(c,stuff)
-#define SET_STATIC_PAR_HDR(stuff)
-#else
-#define SET_PAR_HDR(c,stuff)
-#define SET_STATIC_PAR_HDR(stuff)
-#endif
-
#ifdef TICKY_TICKY
#define SET_TICKY_HDR(c,stuff) /* old: (c)->header.ticky.updated = stuff */
#define SET_STATIC_TICKY_HDR(stuff) /* old: ticky : { updated : stuff } */
#define SET_HDR(c,_info,ccs) \
{ \
(c)->header.info = _info; \
- SET_GRAN_HDR((StgClosure *)(c),ThisPE); \
- SET_PAR_HDR((StgClosure *)(c),LOCAL_GA); \
SET_PROF_HDR((StgClosure *)(c),ccs); \
SET_TICKY_HDR((StgClosure *)(c),0); \
}
} StgProfHeader;
/* -----------------------------------------------------------------------------
- The GranSim header
- -------------------------------------------------------------------------- */
-
-typedef struct {
- StgWord procs; /* bitmask indicating on which PEs this closure resides */
-} StgGranHeader;
-
-/* -----------------------------------------------------------------------------
The SMP header
A thunk has a padding word to take the updated value. This is so
#ifdef PROFILING
StgProfHeader prof;
#endif
-#ifdef GRAN
- StgGranHeader gran;
-#endif
} StgHeader;
typedef struct {
#ifdef PROFILING
StgProfHeader prof;
#endif
-#ifdef GRAN
- StgGranHeader gran;
-#endif
StgSMPThunkHeader smp;
} StgThunkHeader;
StgClosure *alt_code;
} StgCatchRetryFrame;
-#if defined(PAR) || defined(GRAN)
-/*
- StgBlockingQueueElement is a ``collective type'' representing the types
- of closures that can be found on a blocking queue: StgTSO, StgRBHSave,
- StgBlockedFetch. (StgRBHSave can only appear at the end of a blocking
- queue). Logically, this is a union type, but defining another struct
- with a common layout is easier to handle in the code.
- Note that in the standard setup only StgTSOs can be on a blocking queue.
- This is one of the main reasons for slightly different code in files
- such as Schedule.c.
-*/
-typedef struct StgBlockingQueueElement_ {
- StgHeader header;
- struct StgBlockingQueueElement_ *link; /* next elem in BQ */
- struct StgClosure_ *payload[FLEXIBLE_ARRAY];/* contents of the closure */
-} StgBlockingQueueElement;
-
-/* only difference to std code is type of the elem in the BQ */
-typedef struct StgBlockingQueue_ {
- StgHeader header;
- struct StgBlockingQueueElement_ *blocking_queue; /* start of the BQ */
-} StgBlockingQueue;
-
-/* this closure is hanging at the end of a blocking queue in (see RBH.c) */
-typedef struct StgRBHSave_ {
- StgHeader header;
- StgClosure *payload[FLEXIBLE_ARRAY]; /* 2 words ripped out of the guts of the */
-} StgRBHSave; /* closure holding the blocking queue */
-
-typedef struct StgRBH_ {
- StgHeader header;
- struct StgBlockingQueueElement_ *blocking_queue; /* start of the BQ */
-} StgRBH;
-
-#endif
-
-#if defined(PAR)
-/* global indirections aka FETCH_ME closures */
-typedef struct StgFetchMe_ {
- StgHeader header;
- globalAddr *ga; /* ptr to unique id for a closure */
-} StgFetchMe;
-
-/* same contents as an ordinary StgBlockingQueue */
-typedef struct StgFetchMeBlockingQueue_ {
- StgHeader header;
- struct StgBlockingQueueElement_ *blocking_queue; /* start of the BQ */
-} StgFetchMeBlockingQueue;
-
-/* This is an entry in a blocking queue. It indicates a fetch request from a
- TSO on another PE demanding the value of this closur. Note that a
- StgBlockedFetch can only occur in a BQ. Once the node is evaluated and
- updated with the result, the result will be sent back (the PE is encoded
- in the globalAddr) and the StgBlockedFetch closure will be nuked.
-*/
-typedef struct StgBlockedFetch_ {
- StgHeader header;
- struct StgBlockingQueueElement_ *link; /* next elem in the BQ */
- StgClosure *node; /* node to fetch */
- globalAddr ga; /* where to send the result to */
-} StgBlockedFetch; /* NB: not just a ptr to a GA */
-#endif
-
#endif /* CLOSURES_H */
extern void OutOfHeapHook (unsigned long request_size, unsigned long heap_size);
extern void MallocFailHook (unsigned long request_size /* in bytes */, char *msg);
extern void defaultsHook (void);
-#if defined(PAR)
-extern void InitEachPEHook (void);
-extern void ShutdownEachPEHook (void);
-#endif
} StgProfInfo;
/* -----------------------------------------------------------------------------
- Parallelism info
- -------------------------------------------------------------------------- */
-
-#if 0 && (defined(PAR) || defined(GRAN))
-
-/* CURRENTLY UNUSED
- ToDo: use this in StgInfoTable (mutually recursive) -- HWL */
-
-typedef struct {
- StgInfoTable *rbh_infoptr; /* infoptr to the RBH */
-} StgParInfo;
-
-#endif /* 0 */
-
-/*
- Copied from ghc-0.29; ToDo: check this code -- HWL
-
- In the parallel system, all updatable closures have corresponding
- revertible black holes. When we are assembly-mangling, we guarantee
- that the revertible black hole code precedes the normal entry code, so
- that the RBH info table resides at a fixed offset from the normal info
- table. Otherwise, we add the RBH info table pointer to the end of the
- normal info table and vice versa.
-
- Currently has to use a !RBH_MAGIC_OFFSET setting.
- Still todo: init of par.infoptr field in all infotables!!
-*/
-
-#if defined(PAR) || defined(GRAN)
-
-# ifdef RBH_MAGIC_OFFSET
-
-# error magic offset not yet implemented
-
-# define RBH_INFO_WORDS 0
-# define INCLUDE_RBH_INFO(infoptr)
-
-# define RBH_INFOPTR(infoptr) (((P_)infoptr) - RBH_MAGIC_OFFSET)
-# define REVERT_INFOPTR(infoptr) (((P_)infoptr) + RBH_MAGIC_OFFSET)
-
-# else
-
-# define RBH_INFO_WORDS 1
-# define INCLUDE_RBH_INFO(info) rbh_infoptr : &(info)
-
-# define RBH_INFOPTR(infoptr) (((StgInfoTable *)(infoptr))->rbh_infoptr)
-# define REVERT_INFOPTR(infoptr) (((StgInfoTable *)(infoptr))->rbh_infoptr)
-
-# endif
-
-/* see ParallelRts.h */
-/*
-EXTFUN(RBH_entry);
-StgClosure *convertToRBH(StgClosure *closure);
-#if defined(GRAN)
-void convertFromRBH(StgClosure *closure);
-#elif defined(PAR)
-void convertToFetchMe(StgPtr closure, globalAddr *ga);
-#endif
-*/
-
-#endif
-
-/* -----------------------------------------------------------------------------
Ticky info
There is no ticky-specific stuff in an info table at this time.
StgFunPtr entry; /* pointer to the entry code */
#endif
-#if defined(PAR) || defined(GRAN)
- struct _StgInfoTable *rbh_infoptr;
-#endif
#ifdef PROFILING
StgProfInfo prof;
#endif
StgDLL.h /* stuff related to Windows DLLs */
MachRegs.h /* global register assignments for this arch */
Regs.h /* "registers" in the virtual machine */
+ TickyCounters.h
StgMiscClosures.h /* decls for closures & info tables in the RTS */
SMP.h /* basic primitives for synchronisation */
/* Info tables, closures & code fragments defined in the RTS */
#include "StgMiscClosures.h"
-/* Simulated-parallel information */
-#include "GranSim.h"
-
/* Parallel information */
-#include "Parallel.h"
#include "OSThreads.h"
#include "SMPClosureOps.h"
#include "SpinLock.h"
#include "Block.h"
#include "ClosureMacros.h"
- /* Ticky-ticky counters */
-#include "TickyCounters.h"
-
/* Runtime-system hooks */
#include "Hooks.h"
#include "RtsMessages.h"
#define DEBUG_ONLY(s) doNothing()
#endif
-#if defined(GRAN) && defined(DEBUG)
-#define IF_GRAN_DEBUG(c,s) if (RtsFlags.GranFlags.Debug.c) { s; }
-#else
-#define IF_GRAN_DEBUG(c,s) doNothing()
-#endif
-
-#if defined(PAR) && defined(DEBUG)
-#define IF_PAR_DEBUG(c,s) if (RtsFlags.ParFlags.Debug.c) { s; }
-#else
-#define IF_PAR_DEBUG(c,s) doNothing()
-#endif
-
/* -----------------------------------------------------------------------------
Useful macros and inline functions
-------------------------------------------------------------------------- */
/*
* Whether the runtime system will use libbfd for debugging purposes.
*/
-#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32) && !defined(PAR) && !defined(GRAN)
+#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32)
#define USING_LIBBFD 1
#endif
Signals - supported on non-PAR versions of the runtime. See RtsSignals.h.
-------------------------------------------------------------------------- */
-#if !defined(PAR)
#define RTS_USER_SIGNALS 1
-#endif
/* Profile spin locks */
rtsBool stable; /* 't' */
rtsBool prof; /* 'p' */
rtsBool eventlog; /* 'e' */
- rtsBool gran; /* 'r' */
- rtsBool par; /* 'P' */
rtsBool linker; /* 'l' the object linker */
rtsBool apply; /* 'a' */
rtsBool stm; /* 'm' */
* for the linker, NULL ==> off */
};
-#ifdef PAR
-/* currently the same as GRAN_STATS_FLAGS */
-struct PAR_STATS_FLAGS {
- rtsBool Full; /* Full .gr profile (rtsTrue) or only END events? */
- rtsBool Suppressed; /* No .gr profile at all */
- rtsBool Binary; /* Binary profile? (not yet implemented) */
- rtsBool Sparks; /* Info on sparks in profile? */
- rtsBool Heap; /* Info on heap allocs in profile? */
- rtsBool NewLogfile; /* Use new log-file format? (not yet implemented) */
- rtsBool Global; /* Global statistics? (printed on shutdown; no log file) */
-};
-
-struct PAR_DEBUG_FLAGS {
- /* flags to control debugging output in various subsystems */
- rtsBool verbose : 1; /* 1 */
- rtsBool bq : 1; /* 2 */
- rtsBool schedule : 1; /* 4 */
- rtsBool free : 1; /* 8 */
- rtsBool resume : 1; /* 16 */
- rtsBool weight : 1; /* 32 */
- rtsBool fetch : 1; /* 64 */
- rtsBool fish : 1; /* 128 */
- rtsBool tables : 1; /* 256 */
- rtsBool packet : 1; /* 512 */
- rtsBool pack : 1; /* 1024 */
- rtsBool paranoia : 1; /* 2048 */
-};
-
-#define MAX_PAR_DEBUG_OPTION 11
-#define PAR_DEBUG_MASK(n) ((nat)(ldexp(1,n)))
-#define MAX_PAR_DEBUG_MASK ((nat)(ldexp(1,(MAX_PAR_DEBUG_OPTION+1))-1))
-
-struct PAR_FLAGS {
- struct PAR_STATS_FLAGS ParStats; /* profile and stats output */
- struct PAR_DEBUG_FLAGS Debug; /* debugging options */
- rtsBool outputDisabled; /* Disable output for performance purposes */
- rtsBool doFairScheduling; /* Fair-ish scheduling (round robin; no time-slices) */
- nat packBufferSize;
- nat thunksToPack; /* number of thunks in packet + 1 */
- nat globalising; /* globalisation scheme */
- nat maxLocalSparks; /* spark pool size */
- nat maxThreads; /* thread pool size */
- nat maxFishes; /* max number of active fishes */
- rtsTime fishDelay; /* delay before sending a new fish */
- long wait;
-};
-#endif /* PAR */
-
#ifdef THREADED_RTS
struct PAR_FLAGS {
nat nNodes; /* number of threads to run simultaneously */
};
#endif /* THREADED_RTS */
-#ifdef GRAN
-struct GRAN_STATS_FLAGS {
- rtsBool Full; /* Full .gr profile (rtsTrue) or only END events? */
- rtsBool Suppressed; /* No .gr profile at all */
- rtsBool Binary; /* Binary profile? (not yet implemented) */
- rtsBool Sparks; /* Info on sparks in profile? */
- rtsBool Heap; /* Info on heap allocs in profile? */
- rtsBool NewLogfile; /* Use new log-file format? (not yet implemented) */
- rtsBool Global; /* Global statistics? (printed on shutdown; no log file) */
-};
-
-struct GRAN_COST_FLAGS {
- /* Communication Cost Variables -- set in main program */
- nat latency; /* Latency for single packet */
- nat additional_latency; /* Latency for additional packets */
- nat fetchtime;
- nat lunblocktime; /* Time for local unblock */
- nat gunblocktime; /* Time for global unblock */
- nat mpacktime; /* Cost of creating a packet */
- nat munpacktime; /* Cost of receiving a packet */
- nat mtidytime; /* Cost of cleaning up after send */
-
- nat threadcreatetime; /* Thread creation costs */
- nat threadqueuetime; /* Cost of adding a thread to the running/runnable queue */
- nat threaddescheduletime; /* Cost of descheduling a thread */
- nat threadscheduletime; /* Cost of scheduling a thread */
- nat threadcontextswitchtime; /* Cost of context switch */
-
- /* Instruction Costs */
- nat arith_cost; /* arithmetic instructions (+,i,< etc) */
- nat branch_cost; /* branch instructions */
- nat load_cost; /* load into register */
- nat store_cost; /* store into memory */
- nat float_cost; /* floating point operations */
-
- nat heapalloc_cost; /* heap allocation costs */
-
- /* Overhead for granularity control mechanisms */
- /* overhead per elem of spark queue */
- nat pri_spark_overhead;
- /* overhead per elem of thread queue */
- nat pri_sched_overhead;
-};
-
-struct GRAN_DEBUG_FLAGS {
- /* flags to control debugging output in various subsystems */
- rtsBool event_trace : 1; /* 1 */
- rtsBool event_stats : 1; /* 2 */
- rtsBool bq : 1; /* 4 */
- rtsBool pack : 1; /* 8 */
- rtsBool checkSparkQ : 1; /* 16 */
- rtsBool thunkStealing : 1; /* 32 */
- rtsBool randomSteal : 1; /* 64 */
- rtsBool findWork : 1; /* 128 */
- rtsBool unused : 1; /* 256 */
- rtsBool pri : 1; /* 512 */
- rtsBool checkLight : 1; /* 1024 */
- rtsBool sortedQ : 1; /* 2048 */
- rtsBool blockOnFetch : 1; /* 4096 */
- rtsBool packBuffer : 1; /* 8192 */
- rtsBool blockOnFetch_sanity : 1; /* 16384 */
-};
-
-#define MAX_GRAN_DEBUG_OPTION 14
-#define GRAN_DEBUG_MASK(n) ((nat)(ldexp(1,n)))
-#define MAX_GRAN_DEBUG_MASK ((nat)(ldexp(1,(MAX_GRAN_DEBUG_OPTION+1))-1))
-
-struct GRAN_FLAGS {
- struct GRAN_STATS_FLAGS GranSimStats; /* profile and stats output */
- struct GRAN_COST_FLAGS Costs; /* cost metric for simulation */
- struct GRAN_DEBUG_FLAGS Debug; /* debugging options */
-
- nat maxThreads; /* ToDo: share with THREADED_RTS and GUM */
- /* rtsBool labelling; */
- nat packBufferSize;
- nat packBufferSize_internal;
-
- PEs proc; /* number of processors */
- rtsBool Fishing; /* Simulate GUM style fishing mechanism? */
- nat maxFishes; /* max number of spark or thread steals */
- rtsTime time_slice; /* max time slice of one reduction thread */
-
- /* GrAnSim-Light: This version puts no bound on the number of
- processors but in exchange doesn't model communication costs
- (all communication is 0 cost). Mainly intended to show maximal
- degree of parallelism in the program (*not* to simulate the
- execution on a real machine). */
-
- rtsBool Light;
-
- rtsBool DoFairSchedule ; /* fair scheduling alg? default: unfair */
- rtsBool DoAsyncFetch; /* async. communication? */
- rtsBool DoStealThreadsFirst; /* prefer threads over sparks when stealing */
- rtsBool DoAlwaysCreateThreads; /* eager thread creation */
- rtsBool DoBulkFetching; /* bulk fetching */
- rtsBool DoThreadMigration; /* allow to move threads */
- nat FetchStrategy; /* what to do when waiting for data */
- rtsBool PreferSparksOfLocalNodes; /* prefer local over global sparks */
- rtsBool DoPrioritySparking; /* sparks sorted by priorities */
- rtsBool DoPriorityScheduling; /* threads sorted by priorities */
- nat SparkPriority; /* threshold for cut-off mechanism */
- nat SparkPriority2;
- rtsBool RandomPriorities;
- rtsBool InversePriorities;
- rtsBool IgnorePriorities;
- nat ThunksToPack; /* number of thunks in packet + 1 */
- rtsBool RandomSteal; /* steal spark/thread from random proc */
- rtsBool NoForward; /* no forwarding of fetch messages */
-
- /* unsigned int debug; */
- /* rtsBool event_trace; */
- /* rtsBool event_trace_all; */
-};
-#endif /* GRAN */
-
struct TICKY_FLAGS {
rtsBool showTickyStats;
FILE *tickyFile;
#endif
struct TICKY_FLAGS TickyFlags;
-#if defined(THREADED_RTS) || defined(PAR)
+#if defined(THREADED_RTS)
struct PAR_FLAGS ParFlags;
#endif
-#ifdef GRAN
- struct GRAN_FLAGS GranFlags;
-#endif
#ifdef USE_PAPI
struct PAPI_FLAGS PapiFlags;
#endif
typedef ullong rtsTime;
-#if defined(PAR)
-/* types only needed in the parallel system */
-typedef struct hashtable ParHashTable;
-typedef struct hashlist ParHashList;
-
-/* typedef double REAL_TIME; */
-/* typedef W_ TIME; */
-/* typedef GlobalTaskId Proc; */
-typedef int GlobalTaskId;
-typedef GlobalTaskId PEs;
-typedef unsigned int rtsWeight;
-typedef int rtsPacket;
-typedef int OpCode;
-
-/* Global addresses i.e. unique ids in a parallel setup; needed in Closures.h*/
-typedef struct {
- union {
- StgPtr plc;
- struct {
- GlobalTaskId gtid;
- int slot;
- } gc;
- } payload;
- rtsWeight weight;
-} globalAddr;
-
-/* (GA, LA) pairs */
-typedef struct gala {
- globalAddr ga;
- StgPtr la;
- struct gala *next;
- rtsBool preferred;
-} GALA;
-
-#elif defined(GRAN)
-
-/*
- * GlobalTaskId is dummy in GranSim;
- * we define it to have cleaner code in the RTS
- */
-typedef int GlobalTaskId;
-typedef lnat rtsTime;
-typedef StgWord PEs;
-
-#endif
-
#endif /* RTS_TYPES_H */
#if defined(THREADED_RTS)
-#if defined(TICKY_TICKY)
+#if defined(TICKY_TICKY)
#error Build options incompatible with THREADED_RTS.
#endif
#ifndef SCHEDAPI_H
#define SCHEDAPI_H
-#if defined(GRAN)
-/* Dummy def for NO_PRI if not in GranSim */
-#define NO_PRI 0
-#endif
-
/*
* Creating threads
*/
-#if defined(GRAN)
-StgTSO *createThread (Capability *cap, nat stack_size, StgInt pri);
-#else
StgTSO *createThread (Capability *cap, nat stack_size);
-#endif
Capability *scheduleWaitThread (StgTSO *tso, /*out*/HaskellObj* ret,
Capability *cap);
#include "MachRegs.h"
#include "Regs.h"
-#ifdef TICKY_TICKY
#include "TickyCounters.h"
-#endif
#if IN_STG_CODE
/*
RTS_INFO(__stg_EAGER_BLACKHOLE_info);
RTS_INFO(stg_CAF_BLACKHOLE_info);
-#if defined(PAR) || defined(GRAN)
-RTS_INFO(stg_RBH_info);
-#endif
-#if defined(PAR)
-RTS_INFO(stg_FETCH_ME_BQ_info);
-#endif
RTS_FUN_INFO(stg_BCO_info);
RTS_INFO(stg_EVACUATED_info);
RTS_INFO(stg_WEAK_info);
RTS_ENTRY(stg_BLACKHOLE_entry);
RTS_ENTRY(__stg_EAGER_BLACKHOLE_entry);
RTS_ENTRY(stg_CAF_BLACKHOLE_entry);
-#if defined(PAR) || defined(GRAN)
-RTS_ENTRY(stg_RBH_entry);
-#endif
-#if defined(PAR)
-RTS_ENTRY(stg_FETCH_ME_BQ_entry);
-#endif
RTS_ENTRY(stg_BCO_entry);
RTS_ENTRY(stg_EVACUATED_entry);
RTS_ENTRY(stg_WEAK_entry);
} StgTSOStatBuf;
/*
- * GRAN: We distinguish between the various classes of threads in
- * the system.
- */
-typedef enum {
- AdvisoryPriority,
- MandatoryPriority,
- RevalPriority
-} StgThreadPriority;
-
-/*
* PROFILING info in a TSO
*/
typedef struct {
} StgTSOProfInfo;
/*
- * PAR info in a TSO
- */
-typedef StgTSOStatBuf StgTSOParInfo;
-
-/*
- * DIST info in a TSO
- */
-typedef struct {
- StgThreadPriority priority;
- StgInt revalTid; /* ToDo: merge both into 1 word */
- StgInt revalSlot;
-} StgTSODistInfo;
-
-/*
- * GRAN info in a TSO
- */
-typedef StgTSOStatBuf StgTSOGranInfo;
-
-/*
* There is no TICKY info in a TSO at this time.
*/
#ifdef PROFILING
StgTSOProfInfo prof;
#endif
-#ifdef PAR
- StgTSOParInfo par;
-#endif
-#ifdef GRAN
- StgTSOGranInfo gran;
-#endif
-#ifdef DIST
- StgTSODistInfo dist;
-#endif
#ifdef mingw32_HOST_OS
StgWord32 saved_winerror;
#endif
#define TSO_STRUCT_SIZEW (TSO_STRUCT_SIZE / sizeof(W_))
-
/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
-#if defined(PAR) || defined(GRAN)
-/* this is the NIL ptr for a blocking queue */
-# define END_BQ_QUEUE ((StgBlockingQueueElement *)(void*)&stg_END_TSO_QUEUE_closure)
-/* this is the NIL ptr for a blocked fetch queue (as in PendingFetches in GUM) */
-# define END_BF_QUEUE ((StgBlockedFetch *)(void*)&stg_END_TSO_QUEUE_closure)
-#endif
-/* ToDo?: different name for end of sleeping queue ? -- HWL */
-
#endif /* TSO_H */
/* End of counter declarations. */
-/* Here are stubs for a bunch of macros that aren't
- implemented yet. */
-
-#define TICK_ALLOC_FUN(g,s)
-#define TICK_ALLOC_CON(g,s)
-#define TICK_ALLOC_TUP(g,s)
-#define TICK_ALLOC_BH(g,s)
-#define TICK_ALLOC_PAP(g,s)
-#define TICK_ALLOC_FMBQ(a,g,s)
-#define TICK_ALLOC_FME(a,g,s)
-#define TICK_ALLOC_BF(a,g,s)
-#define TICK_ALLOC_PRIM2(w)
-
#endif /* TICKY_TICKY */
/* This is ugly, but the story is:
/* Full byte offset for a TSO field, for use from Cmm */
#define tso_field_offset_macro(str) \
- printf("#define TSO_OFFSET_" str " (SIZEOF_StgHeader+SIZEOF_OPT_StgTSOProfInfo+SIZEOF_OPT_StgTSOParInfo+SIZEOF_OPT_StgTSOGranInfo+SIZEOF_OPT_StgTSODistInfo+OFFSET_" str ")\n");
+ printf("#define TSO_OFFSET_" str " (SIZEOF_StgHeader+SIZEOF_OPT_StgTSOProfInfo+OFFSET_" str ")\n");
#define tso_field_offset(s_type, field) \
tso_payload_offset(s_type, field); \
printf("#define STD_HDR_SIZE %lu\n", (unsigned long)sizeofW(StgHeader) - sizeofW(StgProfHeader));
/* grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader) */
printf("#define PROF_HDR_SIZE %lu\n", (unsigned long)sizeofW(StgProfHeader));
- printf("#define GRAN_HDR_SIZE %lu\n", (unsigned long)sizeofW(StgGranHeader));
printf("#define BLOCK_SIZE %u\n", BLOCK_SIZE);
printf("#define MBLOCK_SIZE %u\n", MBLOCK_SIZE);
tso_field(StgTSO, stack_size);
struct_size(StgTSOProfInfo);
- struct_size(StgTSOParInfo);
- struct_size(StgTSOGranInfo);
- struct_size(StgTSODistInfo);
opt_struct_size(StgTSOProfInfo,PROFILING);
- opt_struct_size(StgTSOParInfo,PAR);
- opt_struct_size(StgTSOGranInfo,GRAN);
- opt_struct_size(StgTSODistInfo,DIST);
closure_field(StgUpdateFrame, updatee);
freeCapability (Capability *cap)
{
stgFree(cap->mut_lists);
-#if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
+#if defined(THREADED_RTS)
freeSparkPool(cap->sparks);
#endif
}
GC_GENERIC
}
-#if defined(GRAN)
-/*
- ToDo: merge the block and yield macros, calling something like BLOCK(N)
- at the end;
-*/
-
-/*
- Should we actually ever do a yield in such a case?? -- HWL
-*/
-gran_yield_0
-{
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-gran_yield_1
-{
- Sp_adj(-1);
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 2 Regs--------------------------------------------------------------------*/
-
-gran_yield_2
-{
- Sp_adj(-2);
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 3 Regs -------------------------------------------------------------------*/
-
-gran_yield_3
-{
- Sp_adj(-3);
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 4 Regs -------------------------------------------------------------------*/
-
-gran_yield_4
-{
- Sp_adj(-4);
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 5 Regs -------------------------------------------------------------------*/
-
-gran_yield_5
-{
- Sp_adj(-5);
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 6 Regs -------------------------------------------------------------------*/
-
-gran_yield_6
-{
- Sp_adj(-6);
- Sp(5) = R6;
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 7 Regs -------------------------------------------------------------------*/
-
-gran_yield_7
-{
- Sp_adj(-7);
- Sp(6) = R7;
- Sp(5) = R6;
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-/*- 8 Regs -------------------------------------------------------------------*/
-
-gran_yield_8
-{
- Sp_adj(-8);
- Sp(7) = R8;
- Sp(6) = R7;
- Sp(5) = R6;
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadYielding;
- jump StgReturn;
-}
-
-// the same routines but with a block rather than a yield
-
-gran_block_1
-{
- Sp_adj(-1);
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 2 Regs--------------------------------------------------------------------*/
-
-gran_block_2
-{
- Sp_adj(-2);
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 3 Regs -------------------------------------------------------------------*/
-
-gran_block_3
-{
- Sp_adj(-3);
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 4 Regs -------------------------------------------------------------------*/
-
-gran_block_4
-{
- Sp_adj(-4);
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 5 Regs -------------------------------------------------------------------*/
-
-gran_block_5
-{
- Sp_adj(-5);
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 6 Regs -------------------------------------------------------------------*/
-
-gran_block_6
-{
- Sp_adj(-6);
- Sp(5) = R6;
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 7 Regs -------------------------------------------------------------------*/
-
-gran_block_7
-{
- Sp_adj(-7);
- Sp(6) = R7;
- Sp(5) = R6;
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-/*- 8 Regs -------------------------------------------------------------------*/
-
-gran_block_8
-{
- Sp_adj(-8);
- Sp(7) = R8;
- Sp(6) = R7;
- Sp(5) = R6;
- Sp(4) = R5;
- Sp(3) = R4;
- Sp(2) = R3;
- Sp(1) = R2;
- Sp(0) = R1;
- SAVE_THREAD_STATE();
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-#endif
-
-#if 0 && defined(PAR)
-
-/*
- Similar to stg_block_1 (called via StgMacro BLOCK_NP) but separates the
- saving of the thread state from the actual jump via an StgReturn.
- We need this separation because we call RTS routines in blocking entry codes
- before jumping back into the RTS (see parallel/FetchMe.hc).
-*/
-
-par_block_1_no_jump
-{
- Sp_adj(-1);
- Sp(0) = R1;
- SAVE_THREAD_STATE();
-}
-
-par_jump
-{
- TSO_what_next(CurrentTSO) = ThreadRunGHC;
- R1 = ThreadBlocked;
- jump StgReturn;
-}
-
-#endif
-
/* -----------------------------------------------------------------------------
Heap checks in Primitive case alternatives
void *addr;
} RtsSymbolVal;
-#if !defined(PAR)
#define Maybe_Stable_Names SymI_HasProto(mkWeakzh_fast) \
SymI_HasProto(mkWeakForeignEnvzh_fast) \
SymI_HasProto(makeStableNamezh_fast) \
SymI_HasProto(finalizzeWeakzh_fast)
-#else
-/* These are not available in GUM!!! -- HWL */
-#define Maybe_Stable_Names
-#endif
#if !defined (mingw32_HOST_OS)
#define RTS_POSIX_ONLY_SYMBOLS \
#include <stdlib.h>
#include <string.h>
-#if defined(GRAN) || defined(PAR)
-// HWL: explicit fixed header size to make debugging easier
-int fixed_hs = sizeof(StgHeader), itbl_sz = sizeofW(StgInfoTable),
- uf_sz=sizeofW(StgUpdateFrame);
-#endif
-
/* --------------------------------------------------------------------------
* local function decls
* ------------------------------------------------------------------------*/
debugBelch(")\n");
break;
-#if defined(PAR)
- case BLOCKED_FETCH:
- debugBelch("BLOCKED_FETCH(");
- printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
- printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
- debugBelch(")\n");
- break;
-
- case FETCH_ME:
- debugBelch("FETCH_ME(");
- printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- debugBelch(")\n");
- break;
-
- case FETCH_ME_BQ:
- debugBelch("FETCH_ME_BQ(");
- // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
- debugBelch(")\n");
- break;
-#endif
-
-#if defined(GRAN) || defined(PAR)
- case RBH:
- debugBelch("RBH(");
- printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
- debugBelch(")\n");
- break;
-
-#endif
-
#if 0
/* Symptomatic of a problem elsewhere, have it fall-through & fail */
case EVACUATED:
break;
#endif
-#if defined(PAR) && defined(DIST)
- case REMOTE_REF:
- debugBelch("REMOTE_REF(");
- printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- debugBelch(")\n");
- break;
-#endif
-
default:
//barf("printClosure %d",get_itbl(obj)->type);
debugBelch("*** printClosure: unknown type %d ****\n",
createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
{
StgTSO *t;
-#if defined(GRAN)
- t = createThread (cap, stack_size, NO_PRI);
-#else
t = createThread (cap, stack_size);
-#endif
pushClosure(t, (W_)closure);
pushClosure(t, (W_)&stg_enter_info);
return t;
createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
{
StgTSO *t;
-#if defined(GRAN)
- t = createThread (cap, stack_size, NO_PRI);
-#else
t = createThread (cap, stack_size);
-#endif
pushClosure(t, (W_)&stg_noforceIO_info);
pushClosure(t, (W_)&stg_ap_v_info);
pushClosure(t, (W_)closure);
createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
{
StgTSO *t;
-#if defined(GRAN)
- t = createThread(cap, stack_size, NO_PRI);
-#else
t = createThread(cap, stack_size);
-#endif
pushClosure(t, (W_)&stg_forceIO_info);
pushClosure(t, (W_)&stg_ap_v_info);
pushClosure(t, (W_)closure);
#define RTS 1
#define PGM 0
-#if defined(GRAN)
-
-static char *gran_debug_opts_strs[] = {
- "DEBUG (-bDe, -bD1): event_trace; printing event trace.\n",
- "DEBUG (-bDE, -bD2): event_stats; printing event statistics.\n",
- "DEBUG (-bDb, -bD4): bq; check blocking queues\n",
- "DEBUG (-bDG, -bD8): pack; routines for (un-)packing graph structures.\n",
- "DEBUG (-bDq, -bD16): checkSparkQ; check consistency of the spark queues.\n",
- "DEBUG (-bDf, -bD32): thunkStealing; print forwarding of fetches.\n",
- "DEBUG (-bDr, -bD64): randomSteal; stealing sparks/threads from random PEs.\n",
- "DEBUG (-bDF, -bD128): findWork; searching spark-pools (local & remote), thread queues for work.\n",
- "DEBUG (-bDu, -bD256): unused; currently unused flag.\n",
- "DEBUG (-bDS, -bD512): pri; priority sparking or scheduling.\n",
- "DEBUG (-bD:, -bD1024): checkLight; check GranSim-Light setup.\n",
- "DEBUG (-bDo, -bD2048): sortedQ; check whether spark/thread queues are sorted.\n",
- "DEBUG (-bDz, -bD4096): blockOnFetch; check for blocked on fetch.\n",
- "DEBUG (-bDP, -bD8192): packBuffer; routines handling pack buffer (GranSim internal!).\n",
- "DEBUG (-bDt, -bD16384): blockOnFetch_sanity; check for TSO asleep on fetch.\n",
-};
-
-/* one character codes for the available debug options */
-static char gran_debug_opts_flags[] = {
- 'e', 'E', 'b', 'G', 'q', 'f', 'r', 'F', 'u', 'S', ':', 'o', 'z', 'P', 't'
-};
-
-#elif defined(PAR)
-
-static char *par_debug_opts_strs[] = {
- "DEBUG (-qDv, -qD1): verbose; be generally verbose with parallel related stuff.\n",
- "DEBUG (-qDq, -qD2): bq; print blocking queues.\n",
- "DEBUG (-qDs, -qD4): schedule; scheduling of parallel threads.\n",
- "DEBUG (-qDe, -qD8): free; free messages.\n",
- "DEBUG (-qDr, -qD16): resume; resume messages.\n",
- "DEBUG (-qDw, -qD32): weight; print weights and distrib GC stuff.\n",
- "DEBUG (-qDF, -qD64): fetch; fetch messages.\n",
- // "DEBUG (-qDa, -qD128): ack; ack messages.\n",
- "DEBUG (-qDf, -qD128): fish; fish messages.\n",
- //"DEBUG (-qDo, -qD512): forward; forwarding messages to other PEs.\n",
- "DEBUG (-qDl, -qD256): tables; print internal LAGA etc tables.\n",
- "DEBUG (-qDo, -qD512): packet; packets and graph structures when packing.\n",
- "DEBUG (-qDp, -qD1024): pack; packing and unpacking graphs.\n",
- "DEBUG (-qDz, -qD2048): paranoia; ridiculously detailed output (excellent for filling a partition).\n"
-};
-
-/* one character codes for the available debug options */
-static char par_debug_opts_flags[] = {
- 'v', 'q', 's', 'e', 'r', 'w', 'F', 'f', 'l', 'o', 'p', 'z'
-};
-
-#endif /* PAR */
-
/* -----------------------------------------------------------------------------
Static function decls
-------------------------------------------------------------------------- */
static I_ decode(const char *s);
static void bad_option(const char *s);
-#if defined(GRAN)
-static void enable_GranSimLight(void);
-static void process_gran_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error);
-static void set_GranSim_debug_options(nat n);
-static void help_GranSim_debug_options(nat n);
-#elif defined(PAR)
-static void process_par_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error);
-static void set_par_debug_options(nat n);
-static void help_par_debug_options(nat n);
-#endif
-
/* -----------------------------------------------------------------------------
* Command-line option parsing routines.
* ---------------------------------------------------------------------------*/
RtsFlags.GcFlags.heapSizeSuggestion = 0; /* none */
RtsFlags.GcFlags.pcFreeHeap = 3; /* 3% */
RtsFlags.GcFlags.oldGenFactor = 2;
-#if defined(PAR)
- /* A hack currently needed for GUM -- HWL */
- RtsFlags.GcFlags.generations = 1;
- RtsFlags.GcFlags.steps = 2;
- RtsFlags.GcFlags.squeezeUpdFrames = rtsFalse;
-#else
RtsFlags.GcFlags.generations = 2;
RtsFlags.GcFlags.steps = 2;
RtsFlags.GcFlags.squeezeUpdFrames = rtsTrue;
-#endif
RtsFlags.GcFlags.compact = rtsFalse;
RtsFlags.GcFlags.compactThreshold = 30.0;
RtsFlags.GcFlags.sweep = rtsFalse;
RtsFlags.DebugFlags.stm = rtsFalse;
RtsFlags.DebugFlags.prof = rtsFalse;
RtsFlags.DebugFlags.eventlog = rtsFalse;
- RtsFlags.DebugFlags.gran = rtsFalse;
- RtsFlags.DebugFlags.par = rtsFalse;
RtsFlags.DebugFlags.apply = rtsFalse;
RtsFlags.DebugFlags.linker = rtsFalse;
RtsFlags.DebugFlags.squeeze = rtsFalse;
RtsFlags.DebugFlags.timestamp = rtsFalse;
#endif
-#if defined(PROFILING) || defined(PAR)
+#if defined(PROFILING)
RtsFlags.CcFlags.doCostCentres = 0;
-#endif /* PROFILING or PAR */
+#endif /* PROFILING */
RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
RtsFlags.ProfFlags.profileInterval = 100;
RtsFlags.ParFlags.setAffinity = 0;
#endif
-#ifdef PAR
- RtsFlags.ParFlags.ParStats.Full = rtsFalse;
- RtsFlags.ParFlags.ParStats.Suppressed = rtsFalse;
- RtsFlags.ParFlags.ParStats.Binary = rtsFalse;
- RtsFlags.ParFlags.ParStats.Sparks = rtsFalse;
- RtsFlags.ParFlags.ParStats.Heap = rtsFalse;
- RtsFlags.ParFlags.ParStats.NewLogfile = rtsFalse;
- RtsFlags.ParFlags.ParStats.Global = rtsFalse;
-
- RtsFlags.ParFlags.outputDisabled = rtsFalse;
-#ifdef DIST
- RtsFlags.ParFlags.doFairScheduling = rtsTrue; /* fair sched by def */
-#else
- RtsFlags.ParFlags.doFairScheduling = rtsFalse; /* unfair sched by def */
-#endif
- RtsFlags.ParFlags.packBufferSize = 1024;
- RtsFlags.ParFlags.thunksToPack = 1; /* 0 ... infinity; */
- RtsFlags.ParFlags.globalising = 1; /* 0 ... everything */
- RtsFlags.ParFlags.maxThreads = 1024;
- RtsFlags.ParFlags.maxFishes = MAX_FISHES;
- RtsFlags.ParFlags.fishDelay = FISH_DELAY;
-#endif
-
-#if defined(PAR) || defined(THREADED_RTS)
+#if defined(THREADED_RTS)
RtsFlags.ParFlags.maxLocalSparks = 4096;
-#endif /* PAR || THREADED_RTS */
-
-#if defined(GRAN)
- /* ToDo: check defaults for GranSim and GUM */
- RtsFlags.GcFlags.maxStkSize = (8 * 1024 * 1024) / sizeof(W_);
- RtsFlags.GcFlags.initialStkSize = 1024 / sizeof(W_);
-
- RtsFlags.GranFlags.maxThreads = 65536; // refers to mandatory threads
- RtsFlags.GranFlags.GranSimStats.Full = rtsFalse;
- RtsFlags.GranFlags.GranSimStats.Suppressed = rtsFalse;
- RtsFlags.GranFlags.GranSimStats.Binary = rtsFalse;
- RtsFlags.GranFlags.GranSimStats.Sparks = rtsFalse;
- RtsFlags.GranFlags.GranSimStats.Heap = rtsFalse;
- RtsFlags.GranFlags.GranSimStats.NewLogfile = rtsFalse;
- RtsFlags.GranFlags.GranSimStats.Global = rtsFalse;
-
- RtsFlags.GranFlags.packBufferSize = 1024;
- RtsFlags.GranFlags.packBufferSize_internal = GRANSIM_DEFAULT_PACK_BUFFER_SIZE;
-
- RtsFlags.GranFlags.proc = MAX_PROC;
- RtsFlags.GranFlags.Fishing = rtsFalse;
- RtsFlags.GranFlags.maxFishes = MAX_FISHES;
- RtsFlags.GranFlags.time_slice = GRAN_TIME_SLICE;
- RtsFlags.GranFlags.Light = rtsFalse;
-
- RtsFlags.GranFlags.Costs.latency = LATENCY;
- RtsFlags.GranFlags.Costs.additional_latency = ADDITIONAL_LATENCY;
- RtsFlags.GranFlags.Costs.fetchtime = FETCHTIME;
- RtsFlags.GranFlags.Costs.lunblocktime = LOCALUNBLOCKTIME;
- RtsFlags.GranFlags.Costs.gunblocktime = GLOBALUNBLOCKTIME;
- RtsFlags.GranFlags.Costs.mpacktime = MSGPACKTIME;
- RtsFlags.GranFlags.Costs.munpacktime = MSGUNPACKTIME;
- RtsFlags.GranFlags.Costs.mtidytime = MSGTIDYTIME;
-
- RtsFlags.GranFlags.Costs.threadcreatetime = THREADCREATETIME;
- RtsFlags.GranFlags.Costs.threadqueuetime = THREADQUEUETIME;
- RtsFlags.GranFlags.Costs.threaddescheduletime = THREADDESCHEDULETIME;
- RtsFlags.GranFlags.Costs.threadscheduletime = THREADSCHEDULETIME;
- RtsFlags.GranFlags.Costs.threadcontextswitchtime = THREADCONTEXTSWITCHTIME;
-
- RtsFlags.GranFlags.Costs.arith_cost = ARITH_COST;
- RtsFlags.GranFlags.Costs.branch_cost = BRANCH_COST;
- RtsFlags.GranFlags.Costs.load_cost = LOAD_COST;
- RtsFlags.GranFlags.Costs.store_cost = STORE_COST;
- RtsFlags.GranFlags.Costs.float_cost = FLOAT_COST;
-
- RtsFlags.GranFlags.Costs.heapalloc_cost = HEAPALLOC_COST;
-
- RtsFlags.GranFlags.Costs.pri_spark_overhead = PRI_SPARK_OVERHEAD;
- RtsFlags.GranFlags.Costs.pri_sched_overhead = PRI_SCHED_OVERHEAD;
-
- RtsFlags.GranFlags.DoFairSchedule = rtsFalse;
- RtsFlags.GranFlags.DoAsyncFetch = rtsFalse;
- RtsFlags.GranFlags.DoStealThreadsFirst = rtsFalse;
- RtsFlags.GranFlags.DoAlwaysCreateThreads = rtsFalse;
- RtsFlags.GranFlags.DoBulkFetching = rtsFalse;
- RtsFlags.GranFlags.DoThreadMigration = rtsFalse;
- RtsFlags.GranFlags.FetchStrategy = 2;
- RtsFlags.GranFlags.PreferSparksOfLocalNodes = rtsFalse;
- RtsFlags.GranFlags.DoPrioritySparking = rtsFalse;
- RtsFlags.GranFlags.DoPriorityScheduling = rtsFalse;
- RtsFlags.GranFlags.SparkPriority = 0;
- RtsFlags.GranFlags.SparkPriority2 = 0;
- RtsFlags.GranFlags.RandomPriorities = rtsFalse;
- RtsFlags.GranFlags.InversePriorities = rtsFalse;
- RtsFlags.GranFlags.IgnorePriorities = rtsFalse;
- RtsFlags.GranFlags.ThunksToPack = 0;
- RtsFlags.GranFlags.RandomSteal = rtsTrue;
-#endif
+#endif /* THREADED_RTS */
#ifdef TICKY_TICKY
RtsFlags.TickyFlags.showTickyStats = rtsFalse;
"",
" -Z Don't squeeze out update frames on stack overflow",
" -B Sound the bell at the start of each garbage collection",
-#if defined(PROFILING) || defined(PAR)
+#if defined(PROFILING)
"",
" -px Time/allocation profile (XML) (output file <program>.prof)",
" -p Time/allocation profile (output file <program>.prof)",
" -r<file> Produce ticky-ticky statistics (with -rstderr for stderr)",
"",
#endif
-#if defined(PAR)
-" -N<n> Use <n> PVMish processors in parallel (default: 2)",
-/* NB: the -N<n> is implemented by the driver!! */
-#endif
" -C<secs> Context-switch interval in seconds.",
" 0 or no argument means switch as often as possible.",
" Default: 0.02 sec; resolution is set by -V below.",
" -Dt DEBUG: stable",
" -Dp DEBUG: prof",
" -De DEBUG: event logging",
-" -Dr DEBUG: gran",
-" -DP DEBUG: par",
" -Da DEBUG: apply",
" -Dl DEBUG: linker",
" -Dm DEBUG: stm",
#endif
" --install-signal-handlers=<yes|no>",
" Install signal handlers (default: yes)",
-#if defined(THREADED_RTS) || defined(PAR)
+#if defined(THREADED_RTS)
" -e<size> Size of spark pools (default 100)",
#endif
-#if defined(PAR)
-" -t<num> Set maximum number of advisory threads per PE (default 32)",
-" -qP Enable activity profile (output files in ~/<program>*.gr)",
-" -qQ<size> Set pack-buffer size (default: 1024)",
-" -qd Turn on PVM-ish debugging",
-" -qO Disable output for performance measurement",
-#endif
-#if defined(THREADED_RTS) || defined(PAR)
+#if defined(THREADED_RTS)
" -e<n> Maximum number of outstanding local sparks (default: 4096)",
#endif
-#if defined(PAR)
-" -d Turn on PVM-ish debugging",
-" -O Disable output for performance measurement",
-#endif /* PAR */
-#if defined(GRAN) /* ToDo: fill in decent Docu here */
-" -b... All GranSim options start with -b; see GranSim User's Guide for details",
-#endif
#if defined(x86_64_HOST_ARCH)
" -xm Base address to mmap memory in the GHCi linker",
" (hex; must be <80000000)",
} else {
switch(rts_argv[arg][1]) {
- /* process: general args, then PROFILING-only ones,
- then CONCURRENT-only, PARallel-only, GRAN-only,
- TICKY-only (same order as defined in RtsFlags.lh);
- within those groups, mostly in case-insensitive
- alphabetical order.
- Final group is x*, which allows for more options.
+ /* process: general args, then PROFILING-only ones, then
+ CONCURRENT-only, TICKY-only (same order as defined in
+ RtsFlags.lh); within those groups, mostly in
+ case-insensitive alphabetical order. Final group is
+ x*, which allows for more options.
*/
#ifdef TICKY_TICKY
error = rtsTrue;
#endif
-#if defined(PROFILING)
-# define COST_CENTRE_USING_BUILD_ONLY(x) x
-#else
-# define COST_CENTRE_USING_BUILD_ONLY(x) \
-errorBelch("not built for: -prof or -parallel"); \
-error = rtsTrue;
-#endif
-
#ifdef PROFILING
# define PROFILING_BUILD_ONLY(x) x
#else
error = rtsTrue;
#endif
-#ifdef PAR
-# define PAR_BUILD_ONLY(x) x
-#else
-# define PAR_BUILD_ONLY(x) \
-errorBelch("not built for: -parallel"); \
-error = rtsTrue;
-#endif
-
#ifdef THREADED_RTS
# define THREADED_BUILD_ONLY(x) x
#else
error = rtsTrue;
#endif
-#if defined(THREADED_RTS) || defined(PAR)
-# define PAR_OR_THREADED_BUILD_ONLY(x) x
-#else
-# define PAR_OR_THREADED_BUILD_ONLY(x) \
-errorBelch("not built for: -parallel or -smp"); \
-error = rtsTrue;
-#endif
-
-#ifdef GRAN
-# define GRAN_BUILD_ONLY(x) x
-#else
-# define GRAN_BUILD_ONLY(x) \
-errorBelch("not built for: -gransim"); \
-error = rtsTrue;
-#endif
-
/* =========== GENERAL ========================== */
case '?':
error = rtsTrue;
case 'e':
RtsFlags.DebugFlags.eventlog = rtsTrue;
break;
- case 'r':
- RtsFlags.DebugFlags.gran = rtsTrue;
- break;
- case 'P':
- RtsFlags.DebugFlags.par = rtsTrue;
- break;
case 'l':
RtsFlags.DebugFlags.linker = rtsTrue;
break;
goto stats;
stats:
-#ifdef PAR
- /* Opening all those files would almost certainly fail... */
- // RtsFlags.ParFlags.ParStats.Full = rtsTrue;
- RtsFlags.GcFlags.statsFile = NULL; /* temporary; ToDo: rm */
-#else
{
int r;
r = open_stats_file(arg, *argc, argv,
&RtsFlags.GcFlags.statsFile);
if (r == -1) { error = rtsTrue; }
}
-#endif
- break;
+ break;
case 'Z':
RtsFlags.GcFlags.squeezeUpdFrames = rtsFalse;
case 'P': /* detailed cost centre profiling (time/alloc) */
case 'p': /* cost centre profiling (time/alloc) */
- COST_CENTRE_USING_BUILD_ONLY(
+ PROFILING_BUILD_ONLY(
switch (rts_argv[arg][2]) {
case 'x':
RtsFlags.CcFlags.doCostCentres = COST_CENTRES_XML;
#endif
/* =========== PARALLEL =========================== */
case 'e':
- PAR_OR_THREADED_BUILD_ONLY(
+ THREADED_BUILD_ONLY(
if (rts_argv[arg][2] != '\0') {
RtsFlags.ParFlags.maxLocalSparks
= strtol(rts_argv[arg]+2, (char **) NULL, 10);
}
) break;
-#ifdef PAR
- case 'q':
- PAR_BUILD_ONLY(
- process_par_option(arg, rts_argc, rts_argv, &error);
- ) break;
-#endif
-
- /* =========== GRAN =============================== */
-
- case 'b':
- GRAN_BUILD_ONLY(
- process_gran_option(arg, rts_argc, rts_argv, &error);
- ) break;
-
/* =========== TICKY ============================== */
case 'r': /* Basic profiling stats */
}
}
-#if defined(GRAN)
-
-static void
-enable_GranSimLight(void) {
-
- debugBelch("GrAnSim Light enabled (infinite number of processors; 0 communication costs)\n");
- RtsFlags.GranFlags.Light=rtsTrue;
- RtsFlags.GranFlags.Costs.latency =
- RtsFlags.GranFlags.Costs.fetchtime =
- RtsFlags.GranFlags.Costs.additional_latency =
- RtsFlags.GranFlags.Costs.gunblocktime =
- RtsFlags.GranFlags.Costs.lunblocktime =
- RtsFlags.GranFlags.Costs.threadcreatetime =
- RtsFlags.GranFlags.Costs.threadqueuetime =
- RtsFlags.GranFlags.Costs.threadscheduletime =
- RtsFlags.GranFlags.Costs.threaddescheduletime =
- RtsFlags.GranFlags.Costs.threadcontextswitchtime = 0;
-
- RtsFlags.GranFlags.Costs.mpacktime =
- RtsFlags.GranFlags.Costs.munpacktime = 0;
-
- RtsFlags.GranFlags.DoFairSchedule = rtsTrue;
- RtsFlags.GranFlags.DoAsyncFetch = rtsFalse;
- RtsFlags.GranFlags.DoAlwaysCreateThreads = rtsTrue;
- /* FetchStrategy is irrelevant in GrAnSim-Light */
-
- /* GrAnSim Light often creates an abundance of parallel threads,
- each with its own stack etc. Therefore, it's in general a good
- idea to use small stack chunks (use the -o<size> option to
- increase it again).
- */
- // RtsFlags.ConcFlags.stkChunkSize = 100;
-
- RtsFlags.GranFlags.proc = 1;
-}
-
-static void
-process_gran_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error)
-{
- if (rts_argv[arg][1] != 'b') /* All GranSim options start with -b */
- return;
-
- /* or a ridiculously idealised simulator */
- if(strcmp((rts_argv[arg]+2),"oring")==0) {
- RtsFlags.GranFlags.Costs.latency =
- RtsFlags.GranFlags.Costs.fetchtime =
- RtsFlags.GranFlags.Costs.additional_latency =
- RtsFlags.GranFlags.Costs.gunblocktime =
- RtsFlags.GranFlags.Costs.lunblocktime =
- RtsFlags.GranFlags.Costs.threadcreatetime =
- RtsFlags.GranFlags.Costs.threadqueuetime =
- RtsFlags.GranFlags.Costs.threadscheduletime =
- RtsFlags.GranFlags.Costs.threaddescheduletime =
- RtsFlags.GranFlags.Costs.threadcontextswitchtime = 0;
-
- RtsFlags.GranFlags.Costs.mpacktime =
- RtsFlags.GranFlags.Costs.munpacktime = 0;
-
- RtsFlags.GranFlags.Costs.arith_cost =
- RtsFlags.GranFlags.Costs.float_cost =
- RtsFlags.GranFlags.Costs.load_cost =
- RtsFlags.GranFlags.Costs.store_cost =
- RtsFlags.GranFlags.Costs.branch_cost = 0;
-
- RtsFlags.GranFlags.Costs.heapalloc_cost = 1;
-
- /* ++RtsFlags.GranFlags.DoFairSchedule; */
- RtsFlags.GranFlags.DoStealThreadsFirst = rtsTrue; /* -bZ */
- RtsFlags.GranFlags.DoThreadMigration = rtsTrue; /* -bM */
- RtsFlags.GranFlags.GranSimStats.Full = rtsTrue; /* -bP */
- return;
- }
-
- /* or a somewhat idealised simulator */
- if(strcmp((rts_argv[arg]+2),"onzo")==0) {
- RtsFlags.GranFlags.Costs.latency =
- RtsFlags.GranFlags.Costs.fetchtime =
- RtsFlags.GranFlags.Costs.additional_latency =
- RtsFlags.GranFlags.Costs.gunblocktime =
- RtsFlags.GranFlags.Costs.lunblocktime =
- RtsFlags.GranFlags.Costs.threadcreatetime =
- RtsFlags.GranFlags.Costs.threadqueuetime =
- RtsFlags.GranFlags.Costs.threadscheduletime =
- RtsFlags.GranFlags.Costs.threaddescheduletime =
- RtsFlags.GranFlags.Costs.threadcontextswitchtime = 0;
-
- RtsFlags.GranFlags.Costs.mpacktime =
- RtsFlags.GranFlags.Costs.munpacktime = 0;
-
- RtsFlags.GranFlags.Costs.heapalloc_cost = 1;
-
- /* RtsFlags.GranFlags.DoFairSchedule = rtsTrue; */ /* -b-R */
- /* RtsFlags.GranFlags.DoStealThreadsFirst = rtsTrue; */ /* -b-T */
- RtsFlags.GranFlags.DoAsyncFetch = rtsTrue; /* -bZ */
- RtsFlags.GranFlags.DoThreadMigration = rtsTrue; /* -bM */
- RtsFlags.GranFlags.GranSimStats.Full = rtsTrue; /* -bP */
-# if defined(GRAN_CHECK) && defined(GRAN)
- RtsFlags.GranFlags.Debug.event_stats = rtsTrue; /* print event statistics */
-# endif
- return;
- }
-
- /* Communication and task creation cost parameters */
- switch(rts_argv[arg][2]) {
- case '.':
- IgnoreYields = rtsTrue; // HWL HACK
- break;
-
- case ':':
- enable_GranSimLight(); /* set flags for GrAnSim-Light mode */
- break;
-
- case 'l':
- if (rts_argv[arg][3] != '\0')
- {
- RtsFlags.GranFlags.Costs.gunblocktime =
- RtsFlags.GranFlags.Costs.latency = decode(rts_argv[arg]+3);
- RtsFlags.GranFlags.Costs.fetchtime = 2*RtsFlags.GranFlags.Costs.latency;
- }
- else
- RtsFlags.GranFlags.Costs.latency = LATENCY;
- break;
-
- case 'a':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.additional_latency = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.additional_latency = ADDITIONAL_LATENCY;
- break;
-
- case 'm':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.mpacktime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.mpacktime = MSGPACKTIME;
- break;
-
- case 'x':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.mtidytime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.mtidytime = 0;
- break;
-
- case 'r':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.munpacktime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.munpacktime = MSGUNPACKTIME;
- break;
-
- case 'g':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.fetchtime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.fetchtime = FETCHTIME;
- break;
-
- case 'n':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.gunblocktime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.gunblocktime = GLOBALUNBLOCKTIME;
- break;
-
- case 'u':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.lunblocktime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.lunblocktime = LOCALUNBLOCKTIME;
- break;
-
- /* Thread-related metrics */
- case 't':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.threadcreatetime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.threadcreatetime = THREADCREATETIME;
- break;
-
- case 'q':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.threadqueuetime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.threadqueuetime = THREADQUEUETIME;
- break;
-
- case 'c':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.threadscheduletime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.threadscheduletime = THREADSCHEDULETIME;
-
- RtsFlags.GranFlags.Costs.threadcontextswitchtime = RtsFlags.GranFlags.Costs.threadscheduletime
- + RtsFlags.GranFlags.Costs.threaddescheduletime;
- break;
-
- case 'd':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.threaddescheduletime = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.threaddescheduletime = THREADDESCHEDULETIME;
-
- RtsFlags.GranFlags.Costs.threadcontextswitchtime = RtsFlags.GranFlags.Costs.threadscheduletime
- + RtsFlags.GranFlags.Costs.threaddescheduletime;
- break;
-
- /* Instruction Cost Metrics */
- case 'A':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.arith_cost = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.arith_cost = ARITH_COST;
- break;
-
- case 'F':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.float_cost = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.float_cost = FLOAT_COST;
- break;
-
- case 'B':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.branch_cost = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.branch_cost = BRANCH_COST;
- break;
-
- case 'L':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.load_cost = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.load_cost = LOAD_COST;
- break;
-
- case 'S':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.store_cost = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.store_cost = STORE_COST;
- break;
-
- case 'H':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.heapalloc_cost = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.heapalloc_cost = 0;
- break;
-
- case 'y':
- RtsFlags.GranFlags.DoAsyncFetch = rtsTrue;
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.FetchStrategy = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.FetchStrategy = 2;
- if (RtsFlags.GranFlags.FetchStrategy == 0)
- RtsFlags.GranFlags.DoAsyncFetch = rtsFalse;
- break;
-
- case 'K': /* sort overhead (per elem in spark list) */
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.pri_spark_overhead = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.pri_spark_overhead = PRI_SPARK_OVERHEAD;
- debugBelch("Overhead for pri spark: %d (per elem).\n",
- RtsFlags.GranFlags.Costs.pri_spark_overhead);
- break;
-
- case 'O': /* sort overhead (per elem in spark list) */
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.Costs.pri_sched_overhead = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.Costs.pri_sched_overhead = PRI_SCHED_OVERHEAD;
- debugBelch("Overhead for pri sched: %d (per elem).\n",
- RtsFlags.GranFlags.Costs.pri_sched_overhead);
- break;
-
- /* General Parameters */
- case 'p':
- if (rts_argv[arg][3] != '\0')
- {
- RtsFlags.GranFlags.proc = decode(rts_argv[arg]+3);
- if (RtsFlags.GranFlags.proc==0) {
- enable_GranSimLight(); /* set flags for GrAnSim-Light mode */
- } else if (RtsFlags.GranFlags.proc > MAX_PROC ||
- RtsFlags.GranFlags.proc < 1)
- {
- debugBelch("setupRtsFlags: no more than %u processors allowed\n",
- MAX_PROC);
- *error = rtsTrue;
- }
- }
- else
- RtsFlags.GranFlags.proc = MAX_PROC;
- break;
-
- case 'f':
- RtsFlags.GranFlags.Fishing = rtsTrue;
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.maxFishes = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.maxFishes = MAX_FISHES;
- break;
-
- case 'w':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.GranFlags.time_slice = decode(rts_argv[arg]+3);
- else
- RtsFlags.GranFlags.time_slice = GRAN_TIME_SLICE;
- break;
-
- case 'C':
- RtsFlags.GranFlags.DoAlwaysCreateThreads=rtsTrue;
- RtsFlags.GranFlags.DoThreadMigration=rtsTrue;
- break;
-
- case 'G':
- debugBelch("Bulk fetching enabled.\n");
- RtsFlags.GranFlags.DoBulkFetching=rtsTrue;
- break;
-
- case 'M':
- debugBelch("Thread migration enabled.\n");
- RtsFlags.GranFlags.DoThreadMigration=rtsTrue;
- break;
-
- case 'R':
- debugBelch("Fair Scheduling enabled.\n");
- RtsFlags.GranFlags.DoFairSchedule=rtsTrue;
- break;
-
- case 'I':
- debugBelch("Priority Scheduling enabled.\n");
- RtsFlags.GranFlags.DoPriorityScheduling=rtsTrue;
- break;
-
- case 'T':
- RtsFlags.GranFlags.DoStealThreadsFirst=rtsTrue;
- RtsFlags.GranFlags.DoThreadMigration=rtsTrue;
- break;
-
- case 'Z':
- RtsFlags.GranFlags.DoAsyncFetch=rtsTrue;
- break;
-
-/* case 'z': */
-/* RtsFlags.GranFlags.SimplifiedFetch=rtsTrue; */
-/* break; */
-
- case 'N':
- RtsFlags.GranFlags.PreferSparksOfLocalNodes=rtsTrue;
- break;
-
- case 'b':
- RtsFlags.GranFlags.GranSimStats.Binary=rtsTrue;
- break;
-
- case 'P':
- /* format is -bP<c> where <c> is one char describing kind of profile */
- RtsFlags.GranFlags.GranSimStats.Full = rtsTrue;
- switch(rts_argv[arg][3]) {
- case '\0': break; // nothing special, just an ordinary profile
- case '0': RtsFlags.GranFlags.GranSimStats.Suppressed = rtsTrue;
- break;
- case 'b': RtsFlags.GranFlags.GranSimStats.Binary = rtsTrue;
- break;
- case 's': RtsFlags.GranFlags.GranSimStats.Sparks = rtsTrue;
- break;
- case 'h': RtsFlags.GranFlags.GranSimStats.Heap = rtsTrue;
- break;
- case 'n': RtsFlags.GranFlags.GranSimStats.NewLogfile = rtsTrue;
- break;
- case 'g': RtsFlags.GranFlags.GranSimStats.Global = rtsTrue;
- break;
- default: barf("Unknown option -bP%c", rts_argv[arg][3]);
- }
- break;
-
- case 's':
- RtsFlags.GranFlags.GranSimStats.Sparks=rtsTrue;
- break;
-
- case 'h':
- RtsFlags.GranFlags.GranSimStats.Heap=rtsTrue;
- break;
-
- case 'Y': /* syntax: -bY<n>[,<n>] n ... pos int */
- if (rts_argv[arg][3] != '\0') {
- char *arg0, *tmp;
-
- arg0 = rts_argv[arg]+3;
- if ((tmp = strstr(arg0,","))==NULL) {
- RtsFlags.GranFlags.SparkPriority = decode(arg0);
- debugBelch("SparkPriority: %u.\n",RtsFlags.GranFlags.SparkPriority);
- } else {
- *(tmp++) = '\0';
- RtsFlags.GranFlags.SparkPriority = decode(arg0);
- RtsFlags.GranFlags.SparkPriority2 = decode(tmp);
- debugBelch("SparkPriority: %u.\n",
- RtsFlags.GranFlags.SparkPriority);
- debugBelch("SparkPriority2:%u.\n",
- RtsFlags.GranFlags.SparkPriority2);
- if (RtsFlags.GranFlags.SparkPriority2 <
- RtsFlags.GranFlags.SparkPriority) {
- debugBelch("WARNING: 2nd pri < main pri (%u<%u); 2nd pri has no effect\n",
- RtsFlags.GranFlags.SparkPriority2,
- RtsFlags.GranFlags.SparkPriority);
- }
- }
- } else {
- /* plain pri spark is now invoked with -bX
- RtsFlags.GranFlags.DoPrioritySparking = 1;
- debugBelch("PrioritySparking.\n");
- */
- }
- break;
-
- case 'Q':
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.GranFlags.ThunksToPack = decode(rts_argv[arg]+3);
- } else {
- RtsFlags.GranFlags.ThunksToPack = 1;
- }
- debugBelch("Thunks To Pack in one packet: %u.\n",
- RtsFlags.GranFlags.ThunksToPack);
- break;
-
- case 'e':
- RtsFlags.GranFlags.RandomSteal = rtsFalse;
- debugBelch("Deterministic mode (no random stealing)\n");
- break;
-
- /* The following class of options contains eXperimental */
- /* features in connection with exploiting granularity */
- /* information. I.e. if -bY is chosen these options */
- /* tell the RTS what to do with the supplied info --HWL */
-
- case 'W':
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.GranFlags.packBufferSize_internal = decode(rts_argv[arg]+3);
- } else {
- RtsFlags.GranFlags.packBufferSize_internal = GRANSIM_DEFAULT_PACK_BUFFER_SIZE;
- }
- debugBelch("Size of GranSim internal pack buffer: %u.\n",
- RtsFlags.GranFlags.packBufferSize_internal);
- break;
-
- case 'X':
- switch(rts_argv[arg][3]) {
-
- case '\0':
- RtsFlags.GranFlags.DoPrioritySparking = 1;
- debugBelch("Priority Sparking with Normal Priorities.\n");
- RtsFlags.GranFlags.InversePriorities = rtsFalse;
- RtsFlags.GranFlags.RandomPriorities = rtsFalse;
- RtsFlags.GranFlags.IgnorePriorities = rtsFalse;
- break;
-
- case 'I':
- RtsFlags.GranFlags.DoPrioritySparking = 1;
- debugBelch("Priority Sparking with Inverse Priorities.\n");
- RtsFlags.GranFlags.InversePriorities++;
- break;
-
- case 'R':
- RtsFlags.GranFlags.DoPrioritySparking = 1;
- debugBelch("Priority Sparking with Random Priorities.\n");
- RtsFlags.GranFlags.RandomPriorities++;
- break;
-
- case 'N':
- RtsFlags.GranFlags.DoPrioritySparking = 1;
- debugBelch("Priority Sparking with No Priorities.\n");
- RtsFlags.GranFlags.IgnorePriorities++;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
- break;
-
- case '-':
- switch(rts_argv[arg][3]) {
-
- case 'C':
- RtsFlags.GranFlags.DoAlwaysCreateThreads=rtsFalse;
- RtsFlags.GranFlags.DoThreadMigration=rtsFalse;
- break;
-
- case 'G':
- RtsFlags.GranFlags.DoBulkFetching=rtsFalse;
- break;
-
- case 'M':
- RtsFlags.GranFlags.DoThreadMigration=rtsFalse;
- break;
-
- case 'R':
- RtsFlags.GranFlags.DoFairSchedule=rtsFalse;
- break;
-
- case 'T':
- RtsFlags.GranFlags.DoStealThreadsFirst=rtsFalse;
- RtsFlags.GranFlags.DoThreadMigration=rtsFalse;
- break;
-
- case 'Z':
- RtsFlags.GranFlags.DoAsyncFetch=rtsFalse;
- break;
-
- case 'N':
- RtsFlags.GranFlags.PreferSparksOfLocalNodes=rtsFalse;
- break;
-
- case 'P':
- RtsFlags.GranFlags.GranSimStats.Suppressed=rtsTrue;
- break;
-
- case 's':
- RtsFlags.GranFlags.GranSimStats.Sparks=rtsFalse;
- break;
-
- case 'h':
- RtsFlags.GranFlags.GranSimStats.Heap=rtsFalse;
- break;
-
- case 'b':
- RtsFlags.GranFlags.GranSimStats.Binary=rtsFalse;
- break;
-
- case 'X':
- RtsFlags.GranFlags.DoPrioritySparking = rtsFalse;
- break;
-
- case 'Y':
- RtsFlags.GranFlags.DoPrioritySparking = rtsFalse;
- RtsFlags.GranFlags.SparkPriority = rtsFalse;
- break;
-
- case 'I':
- RtsFlags.GranFlags.DoPriorityScheduling = rtsFalse;
- break;
-
- case 'e':
- RtsFlags.GranFlags.RandomSteal = rtsFalse;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
- break;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- case 'D':
- switch(rts_argv[arg][3]) {
- case 'Q': /* Set pack buffer size (same as 'Q' in GUM) */
- if (rts_argv[arg][4] != '\0') {
- RtsFlags.GranFlags.packBufferSize = decode(rts_argv[arg]+4);
- debugBelch("Pack buffer size: %d\n",
- RtsFlags.GranFlags.packBufferSize);
- } else {
- debugBelch("setupRtsFlags: missing size of PackBuffer (for -Q)\n");
- *error = rtsTrue;
- }
- break;
-
- default:
- if (isdigit(rts_argv[arg][3])) {/* Set all debugging options in one */
- /* hack warning: interpret the flags as a binary number */
- nat n = decode(rts_argv[arg]+3);
- set_GranSim_debug_options(n);
- } else {
- nat i;
- for (i=0; i<=MAX_GRAN_DEBUG_OPTION; i++)
- if (rts_argv[arg][3] == gran_debug_opts_flags[i])
- break;
-
- if (i==MAX_GRAN_DEBUG_OPTION+1) {
- debugBelch("Valid GranSim debug options are:\n");
- help_GranSim_debug_options(MAX_GRAN_DEBUG_MASK);
- bad_option( rts_argv[arg] );
- } else { // flag found; now set it
- set_GranSim_debug_options(GRAN_DEBUG_MASK(i)); // 2^i
- }
- }
- break;
-
-#if 0
- case 'e': /* event trace; also -bD1 */
- debugBelch("DEBUG: event_trace; printing event trace.\n");
- RtsFlags.GranFlags.Debug.event_trace = rtsTrue;
- /* RtsFlags.GranFlags.event_trace=rtsTrue; */
- break;
-
- case 'E': /* event statistics; also -bD2 */
- debugBelch("DEBUG: event_stats; printing event statistics.\n");
- RtsFlags.GranFlags.Debug.event_stats = rtsTrue;
- /* RtsFlags.GranFlags.Debug |= 0x20; print event statistics */
- break;
-
- case 'f': /* thunkStealing; also -bD4 */
- debugBelch("DEBUG: thunkStealing; printing forwarding of FETCHNODES.\n");
- RtsFlags.GranFlags.Debug.thunkStealing = rtsTrue;
- /* RtsFlags.GranFlags.Debug |= 0x2; print fwd messages */
- break;
-
- case 'z': /* blockOnFetch; also -bD8 */
- debugBelch("DEBUG: blockOnFetch; check for blocked on fetch.\n");
- RtsFlags.GranFlags.Debug.blockOnFetch = rtsTrue;
- /* RtsFlags.GranFlags.Debug |= 0x4; debug non-reschedule-on-fetch */
- break;
-
- case 't': /* blockOnFetch_sanity; also -bD16 */
- debugBelch("DEBUG: blockOnFetch_sanity; check for TSO asleep on fetch.\n");
- RtsFlags.GranFlags.Debug.blockOnFetch_sanity = rtsTrue;
- /* RtsFlags.GranFlags.Debug |= 0x10; debug TSO asleep for fetch */
- break;
-
- case 'S': /* priSpark; also -bD32 */
- debugBelch("DEBUG: priSpark; priority sparking.\n");
- RtsFlags.GranFlags.Debug.priSpark = rtsTrue;
- break;
-
- case 's': /* priSched; also -bD64 */
- debugBelch("DEBUG: priSched; priority scheduling.\n");
- RtsFlags.GranFlags.Debug.priSched = rtsTrue;
- break;
-
- case 'F': /* findWork; also -bD128 */
- debugBelch("DEBUG: findWork; searching spark-pools (local & remote), thread queues for work.\n");
- RtsFlags.GranFlags.Debug.findWork = rtsTrue;
- break;
-
- case 'g': /* globalBlock; also -bD256 */
- debugBelch("DEBUG: globalBlock; blocking on remote closures (FETCHMEs etc in GUM).\n");
- RtsFlags.GranFlags.Debug.globalBlock = rtsTrue;
- break;
-
- case 'G': /* pack; also -bD512 */
- debugBelch("DEBUG: pack; routines for (un-)packing graph structures.\n");
- RtsFlags.GranFlags.Debug.pack = rtsTrue;
- break;
-
- case 'P': /* packBuffer; also -bD1024 */
- debugBelch("DEBUG: packBuffer; routines handling pack buffer (GranSim internal!).\n");
- RtsFlags.GranFlags.Debug.packBuffer = rtsTrue;
- break;
-
- case 'o': /* sortedQ; also -bD2048 */
- debugBelch("DEBUG: sortedQ; check whether spark/thread queues are sorted.\n");
- RtsFlags.GranFlags.Debug.sortedQ = rtsTrue;
- break;
-
- case 'r': /* randomSteal; also -bD4096 */
- debugBelch("DEBUG: randomSteal; stealing sparks/threads from random PEs.\n");
- RtsFlags.GranFlags.Debug.randomSteal = rtsTrue;
- break;
-
- case 'q': /* checkSparkQ; also -bD8192 */
- debugBelch("DEBUG: checkSparkQ; check consistency of the spark queues.\n");
- RtsFlags.GranFlags.Debug.checkSparkQ = rtsTrue;
- break;
-
- case ':': /* checkLight; also -bD16384 */
- debugBelch("DEBUG: checkLight; check GranSim-Light setup.\n");
- RtsFlags.GranFlags.Debug.checkLight = rtsTrue;
- break;
-
- case 'b': /* bq; also -bD32768 */
- debugBelch("DEBUG: bq; check blocking queues\n");
- RtsFlags.GranFlags.Debug.bq = rtsTrue;
- break;
-
- case 'd': /* all options turned on */
- debugBelch("DEBUG: all options turned on.\n");
- set_GranSim_debug_options(MAX_GRAN_DEBUG_MASK);
- /* RtsFlags.GranFlags.Debug |= 0x40; */
- break;
-
-/* case '\0': */
-/* RtsFlags.GranFlags.Debug = 1; */
-/* break; */
-#endif
-
- }
- break;
-# endif /* GRAN_CHECK */
- default:
- bad_option( rts_argv[arg] );
- break;
- }
-}
-
-/*
- Interpret n as a binary number masking GranSim debug options and set the
- correxponding option. See gran_debug_opts_strs for explanations of the flags.
-*/
-static void
-set_GranSim_debug_options(nat n) {
- nat i;
-
- for (i=0; i<=MAX_GRAN_DEBUG_OPTION; i++)
- if ((n>>i)&1) {
- errorBelch(gran_debug_opts_strs[i]);
- switch (i) {
- case 0: RtsFlags.GranFlags.Debug.event_trace = rtsTrue; break;
- case 1: RtsFlags.GranFlags.Debug.event_stats = rtsTrue; break;
- case 2: RtsFlags.GranFlags.Debug.bq = rtsTrue; break;
- case 3: RtsFlags.GranFlags.Debug.pack = rtsTrue; break;
- case 4: RtsFlags.GranFlags.Debug.checkSparkQ = rtsTrue; break;
- case 5: RtsFlags.GranFlags.Debug.thunkStealing = rtsTrue; break;
- case 6: RtsFlags.GranFlags.Debug.randomSteal = rtsTrue; break;
- case 7: RtsFlags.GranFlags.Debug.findWork = rtsTrue; break;
- case 8: RtsFlags.GranFlags.Debug.unused = rtsTrue; break;
- case 9: RtsFlags.GranFlags.Debug.pri = rtsTrue; break;
- case 10: RtsFlags.GranFlags.Debug.checkLight = rtsTrue; break;
- case 11: RtsFlags.GranFlags.Debug.sortedQ = rtsTrue; break;
- case 12: RtsFlags.GranFlags.Debug.blockOnFetch = rtsTrue; break;
- case 13: RtsFlags.GranFlags.Debug.packBuffer = rtsTrue; break;
- case 14: RtsFlags.GranFlags.Debug.blockOnFetch_sanity = rtsTrue; break;
- default: barf("set_GranSim_debug_options: only %d debug options expected");
- } /* switch */
- } /* if */
-}
-
-/*
- Print one line explanation for each of the GranSim debug options specified
- in the bitmask n.
-*/
-static void
-help_GranSim_debug_options(nat n) {
- nat i;
-
- for (i=0; i<=MAX_GRAN_DEBUG_OPTION; i++)
- if ((n>>i)&1)
- debugBelch(gran_debug_opts_strs[i]);
-}
-
-# elif defined(PAR)
-
-static void
-process_par_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error)
-{
-
- if (rts_argv[arg][1] != 'q') { /* All GUM options start with -q */
- errorBelch("Warning: GUM option does not start with -q: %s", rts_argv[arg]);
- return;
- }
-
- /* Communication and task creation cost parameters */
- switch(rts_argv[arg][2]) {
- case 'e': /* -qe<n> ... allow <n> local sparks */
- if (rts_argv[arg][3] != '\0') { /* otherwise, stick w/ the default */
- RtsFlags.ParFlags.maxLocalSparks
- = strtol(rts_argv[arg]+3, (char **) NULL, 10);
-
- if (RtsFlags.ParFlags.maxLocalSparks <= 0) {
- errorBelch("setupRtsFlags: bad value for -e\n");
- *error = rtsTrue;
- }
- }
- IF_PAR_DEBUG(verbose,
- errorBelch("-qe<n>: max %d local sparks",
- RtsFlags.ParFlags.maxLocalSparks));
- break;
-
- case 't':
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.ParFlags.maxThreads
- = strtol(rts_argv[arg]+3, (char **) NULL, 10);
- } else {
- errorBelch("missing size for -qt\n");
- *error = rtsTrue;
- }
- IF_PAR_DEBUG(verbose,
- errorBelch("-qt<n>: max %d threads",
- RtsFlags.ParFlags.maxThreads));
- break;
-
- case 'f':
- if (rts_argv[arg][3] != '\0')
- RtsFlags.ParFlags.maxFishes = decode(rts_argv[arg]+3);
- else
- RtsFlags.ParFlags.maxFishes = MAX_FISHES;
- break;
- IF_PAR_DEBUG(verbose,
- errorBelch("-qf<n>: max %d fishes sent out at one time",
- RtsFlags.ParFlags.maxFishes));
- break;
-
- case 'F':
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.ParFlags.fishDelay
- = strtol(rts_argv[arg]+3, (char **) NULL, 10);
- } else {
- errorBelch("missing fish delay time for -qF\n");
- *error = rtsTrue;
- }
- IF_PAR_DEBUG(verbose,
- errorBelch("-qF<n>: fish delay time %d us",
- RtsFlags.ParFlags.fishDelay));
- break;
-
- case 'O':
- RtsFlags.ParFlags.outputDisabled = rtsTrue;
- IF_PAR_DEBUG(verbose,
- errorBelch("-qO: output disabled"));
- break;
-
- case 'g': /* -qg<n> ... globalisation scheme */
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.ParFlags.globalising = decode(rts_argv[arg]+3);
- } else {
- errorBelch("missing identifier for globalisation scheme (for -qg)\n");
- *error = rtsTrue;
- }
- IF_PAR_DEBUG(verbose,
- debugBelch("-qg<n>: globalisation scheme set to %d",
- RtsFlags.ParFlags.globalising));
- break;
-
- case 'h': /* -qh<n> ... max number of thunks (except root) in packet */
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.ParFlags.thunksToPack = decode(rts_argv[arg]+3);
- } else {
- errorBelch("missing number of thunks per packet (for -qh)\n");
- *error = rtsTrue;
- }
- IF_PAR_DEBUG(verbose,
- debugBelch("-qh<n>: thunks per packet set to %d",
- RtsFlags.ParFlags.thunksToPack));
- break;
-
- case 'P': /* -qP for writing a log file */
- //RtsFlags.ParFlags.ParStats.Full = rtsFalse;
- /* same encoding as in GranSim after -bP */
- switch(rts_argv[arg][3]) {
- case '\0': RtsFlags.ParFlags.ParStats.Full = rtsTrue;
- break; // nothing special, just an ordinary profile
- case '0': RtsFlags.ParFlags.ParStats.Suppressed = rtsTrue;
- RtsFlags.ParFlags.ParStats.Full = rtsFalse;
- break;
- case 'b': RtsFlags.ParFlags.ParStats.Binary = rtsTrue;
- break;
- case 's': RtsFlags.ParFlags.ParStats.Sparks = rtsTrue;
- break;
- //case 'h': RtsFlags.parFlags.ParStats.Heap = rtsTrue;
- // break;
- case 'n': RtsFlags.ParFlags.ParStats.NewLogfile = rtsTrue;
- break;
- case 'g':
-# if defined(PAR_TICKY)
- RtsFlags.ParFlags.ParStats.Global = rtsTrue;
-# else
- errorBelch("-qPg is only possible for a PAR_TICKY RTS, which this is not");
- stg_exit(EXIT_FAILURE);
-# endif
- break;
- default: barf("Unknown option -qP%c", rts_argv[arg][2]);
- }
- IF_PAR_DEBUG(verbose,
- debugBelch("(-qP) writing to log-file (RtsFlags.ParFlags.ParStats.Full=%s)",
- (RtsFlags.ParFlags.ParStats.Full ? "rtsTrue" : "rtsFalse")));
- break;
-
- case 'Q': /* -qQ<n> ... set pack buffer size to <n> */
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.ParFlags.packBufferSize = decode(rts_argv[arg]+3);
- } else {
- errorBelch("missing size of PackBuffer (for -qQ)\n");
- *error = rtsTrue;
- }
- IF_PAR_DEBUG(verbose,
- debugBelch("-qQ<n>: pack buffer size set to %d",
- RtsFlags.ParFlags.packBufferSize));
- break;
-
- case 'R':
- RtsFlags.ParFlags.doFairScheduling = rtsTrue;
- IF_PAR_DEBUG(verbose,
- debugBelch("-qR: fair-ish scheduling"));
- break;
-
-# if defined(DEBUG)
- case 'w':
- if (rts_argv[arg][3] != '\0') {
- RtsFlags.ParFlags.wait
- = strtol(rts_argv[arg]+3, (char **) NULL, 10);
- } else {
- RtsFlags.ParFlags.wait = 1000;
- }
- IF_PAR_DEBUG(verbose,
- debugBelch("-qw<n>: length of wait loop after synchr before reduction: %d",
- RtsFlags.ParFlags.wait));
- break;
-
- case 'D': /* -qD ... all the debugging options */
- if (isdigit(rts_argv[arg][3])) {/* Set all debugging options in one */
- /* hack warning: interpret the flags as a binary number */
- nat n = decode(rts_argv[arg]+3);
- set_par_debug_options(n);
- } else {
- nat i;
- for (i=0; i<=MAX_PAR_DEBUG_OPTION; i++)
- if (rts_argv[arg][3] == par_debug_opts_flags[i])
- break;
-
- if (i==MAX_PAR_DEBUG_OPTION+1) {
- errorBelch("Valid GUM debug options are:\n");
- help_par_debug_options(MAX_PAR_DEBUG_MASK);
- bad_option( rts_argv[arg] );
- } else { // flag found; now set it
- set_par_debug_options(PAR_DEBUG_MASK(i)); // 2^i
- }
- }
- break;
-# endif
- default:
- errorBelch("Unknown option -q%c (%d opts in total)",
- rts_argv[arg][2], *rts_argc);
- break;
- } /* switch */
-}
-
-/*
- Interpret n as a binary number masking Par debug options and set the
- correxponding option. See par_debug_opts_strs for explanations of the flags.
-*/
-static void
-set_par_debug_options(nat n) {
- nat i;
-
- for (i=0; i<=MAX_PAR_DEBUG_OPTION; i++)
- if ((n>>i)&1) {
- debugBelch(par_debug_opts_strs[i]);
- switch (i) {
- case 0: RtsFlags.ParFlags.Debug.verbose = rtsTrue; break;
- case 1: RtsFlags.ParFlags.Debug.bq = rtsTrue; break;
- case 2: RtsFlags.ParFlags.Debug.schedule = rtsTrue; break;
- case 3: RtsFlags.ParFlags.Debug.free = rtsTrue; break;
- case 4: RtsFlags.ParFlags.Debug.resume = rtsTrue; break;
- case 5: RtsFlags.ParFlags.Debug.weight = rtsTrue; break;
- case 6: RtsFlags.ParFlags.Debug.fetch = rtsTrue; break;
- //case 7: RtsFlags.ParFlags.Debug.ack = rtsTrue; break;
- case 7: RtsFlags.ParFlags.Debug.fish = rtsTrue; break;
- case 8: RtsFlags.ParFlags.Debug.tables = rtsTrue; break;
- case 9: RtsFlags.ParFlags.Debug.packet = rtsTrue; break;
- case 10: RtsFlags.ParFlags.Debug.pack = rtsTrue; break;
- case 11: RtsFlags.ParFlags.Debug.paranoia = rtsTrue; break;
- default: barf("set_par_debug_options: only %d debug options expected",
- MAX_PAR_DEBUG_OPTION);
- } /* switch */
- } /* if */
-}
-
-/*
- Print one line explanation for each of the GranSim debug options specified
- in the bitmask n.
-*/
-static void
-help_par_debug_options(nat n) {
- nat i;
-
- for (i=0; i<=MAX_PAR_DEBUG_OPTION; i++)
- if ((n>>i)&1)
- debugBelch(par_debug_opts_strs[i]);
-}
-
-#endif /* PAR */
static void
stats_fprintf(FILE *f, char *s, ...)
# 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 <windows.h>
#endif
(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();
rts_unlock(cap);
}
-# endif /* !PAR && !GRAN */
-
/* check the status of the entire Haskell computation */
switch (status) {
case Killed:
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");
}
#ifndef RTS_SIGNALS_H
#define RTS_SIGNALS_H
-#if !defined(PAR) && !defined(mingw32_HOST_OS)
+#if !defined(mingw32_HOST_OS)
#include "posix/Signals.h"
# include "RetainerProfile.h"
#endif
-#if defined(GRAN)
-# include "GranSimRts.h"
-#endif
-
-#if defined(GRAN) || defined(PAR)
-# include "ParallelRts.h"
-#endif
-
-#if defined(PAR)
-# include "Parallel.h"
-# include "LLC.h"
-#endif
-
#if defined(mingw32_HOST_OS) && !defined(THREADED_RTS)
#include "win32/AsyncIO.h"
#endif
initAllocator();
#endif
-#ifdef PAR
- /*
- * The parallel system needs to be initialised and synchronised before
- * the program is run.
- */
- startupParallelSystem(argv);
-
- if (*argv[0] == '-') { /* Strip off mainPE flag argument */
- argv++;
- argc--;
- }
-
- argv[1] = argv[0]; /* ignore the nPEs argument */
- argv++; argc--;
-#endif
-
/* Set the RTS flags to default values. */
initRtsFlagsDefaults();
initTracing();
#endif
-#if defined(PAR)
- /* NB: this really must be done after processing the RTS flags */
- IF_PAR_DEBUG(verbose,
- debugBelch("==== Synchronising system (%d PEs)\n", nPEs));
- synchroniseSystem(); // calls initParallelSystem etc
-#endif /* PAR */
-
/* initialise scheduler data structures (needs to be done before
* initStorage()).
*/
initScheduler();
-#if defined(GRAN)
- /* And start GranSim profiling if required: */
- if (RtsFlags.GranFlags.GranSimStats.Full)
- init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv);
-#elif defined(PAR)
- /* And start GUM profiling if required: */
- if (RtsFlags.ParFlags.ParStats.Full)
- init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv);
-#endif /* PAR || GRAN */
-
/* initialize the storage manager */
initStorage();
}
#endif
-#if defined(GRAN)
- /* end_gr_simulation prints global stats if requested -- HWL */
- if (!RtsFlags.GranFlags.GranSimStats.Suppressed)
- end_gr_simulation();
-#endif
-
/* stop the ticker */
stopTimer();
exitTimer();
}
#endif
-#if defined(PAR)
- /* controlled exit; good thread! */
- shutdownParallelSystem(0);
-
- /* global statistics in parallel system */
- PAR_TICKY_PAR_END();
-#endif
-
// uninstall signal handlers
resetDefaultHandlers();
hs_exit_(rtsFalse);
if (hs_init_count == 0) {
-#if defined(PAR)
- /* really exit (stg_exit() would call shutdownParallelSystem() again) */
- exit(n);
-#else
stg_exit(n);
-#endif
}
}
* called from STG-land to exit the program
*/
-#ifdef PAR
-static int exit_started=rtsFalse;
-#endif
-
void (*exitFn)(int) = 0;
void
stg_exit(int n)
{
-#ifdef PAR
- /* HACK: avoid a loop when exiting due to a stupid error */
- if (exit_started)
- return;
- exit_started=rtsTrue;
-
- IF_PAR_DEBUG(verbose, debugBelch("==-- stg_exit %d on [%x]...", n, mytid));
- shutdownParallelSystem(n);
-#endif
if (exitFn)
(*exitFn)(n);
exit(n);
void setNonBlockingFd(int fd STG_UNUSED) {}
#endif
-#ifdef PAR
-static ullong startTime = 0;
-
-/* used in a parallel setup */
-ullong
-msTime(void)
-{
-# if defined(HAVE_GETCLOCK) && !defined(alpha_HOST_ARCH) && !defined(hppa1_1_HOST_ARCH)
- struct timespec tv;
-
- if (getclock(TIMEOFDAY, &tv) != 0) {
- fflush(stdout);
- fprintf(stderr, "Clock failed\n");
- stg_exit(EXIT_FAILURE);
- }
- return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime;
-# elif HAVE_GETTIMEOFDAY && !defined(alpha_HOST_ARCH)
- struct timeval tv;
-
- if (gettimeofday(&tv, NULL) != 0) {
- fflush(stdout);
- fprintf(stderr, "Clock failed\n");
- stg_exit(EXIT_FAILURE);
- }
- return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
-# else
- time_t t;
- if ((t = time(NULL)) == (time_t) -1) {
- fflush(stdout);
- fprintf(stderr, "Clock failed\n");
- stg_exit(EXIT_FAILURE);
- }
- return t * LL(1000) - startTime;
-# endif
-}
-#endif /* PAR */
-
/* -----------------------------------------------------------------------------
Print large numbers, with punctuation.
-------------------------------------------------------------------------- */
extern char *time_str(void);
extern char *ullong_format_string(ullong, char *, rtsBool);
-#ifdef PAR
-extern ullong msTime(void);
-#endif
-
#ifdef DEBUG
extern void heapCheckFail( void );
#endif
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
-#if 0
-#if defined(PAR)
- checkBQ((StgBlockingQueueElement *)mvar->head, p);
-#else
- checkBQ(mvar->head, p);
-#endif
-#endif
return sizeofW(StgMVar);
}
checkTSO((StgTSO *)p);
return tso_sizeW((StgTSO *)p);
-#if defined(PAR)
-
- case BLOCKED_FETCH:
- ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
- ASSERT(LOOKS_LIKE_CLOSURE_PTR((((StgBlockedFetch *)p)->node)));
- return sizeofW(StgBlockedFetch); // see size used in evacuate()
-
-#ifdef DIST
- case REMOTE_REF:
- return sizeofW(StgFetchMe);
-#endif /*DIST */
-
- case FETCH_ME:
- ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
- return sizeofW(StgFetchMe); // see size used in evacuate()
-
- case FETCH_ME_BQ:
- checkBQ(((StgFetchMeBlockingQueue *)p)->blocking_queue, (StgClosure *)p);
- return sizeofW(StgFetchMeBlockingQueue); // see size used in evacuate()
-
- case RBH:
- /* In an RBH the BQ may be empty (ie END_BQ_QUEUE) but not NULL */
- ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
- if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
- checkBQ(((StgRBH *)p)->blocking_queue, p);
- ASSERT(LOOKS_LIKE_INFO_PTR(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
- return BLACKHOLE_sizeW(); // see size used in evacuate()
- // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
-
-#endif
-
case TVAR_WATCH_QUEUE:
{
StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
}
}
-#if defined(PAR)
-
-#define PVM_PE_MASK 0xfffc0000
-#define MAX_PVM_PES MAX_PES
-#define MAX_PVM_TIDS MAX_PES
-#define MAX_SLOTS 100000
-
-rtsBool
-looks_like_tid(StgInt tid)
-{
- StgInt hi = (tid & PVM_PE_MASK) >> 18;
- StgInt lo = (tid & ~PVM_PE_MASK);
- rtsBool ok = (hi != 0) && (lo < MAX_PVM_TIDS) && (hi < MAX_PVM_TIDS);
- return ok;
-}
-
-rtsBool
-looks_like_slot(StgInt slot)
-{
- /* if tid is known better use looks_like_ga!! */
- rtsBool ok = slot<MAX_SLOTS;
- // This refers only to the no. of slots on the current PE
- // rtsBool ok = slot<=highest_slot();
- return ok;
-}
-
-rtsBool
-looks_like_ga(globalAddr *ga)
-{
- rtsBool is_tid = looks_like_tid((ga)->payload.gc.gtid);
- rtsBool is_slot = ((ga)->payload.gc.gtid==mytid) ?
- (ga)->payload.gc.slot<=highest_slot() :
- (ga)->payload.gc.slot<MAX_SLOTS;
- rtsBool ok = is_tid && is_slot;
- return ok;
-}
-
-#endif
-
/* -----------------------------------------------------------------------------
Check Heap Sanity
}
}
-#if defined(PAR)
-/*
- Check heap between start and end. Used after unpacking graphs.
-*/
-void
-checkHeapChunk(StgPtr start, StgPtr end)
-{
- extern globalAddr *LAGAlookup(StgClosure *addr);
- StgPtr p;
- nat size;
-
- for (p=start; p<end; p+=size) {
- ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
- if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
- *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
- /* if it's a FM created during unpack and commoned up, it's not global */
- ASSERT(LAGAlookup((StgClosure*)p)==NULL);
- size = sizeofW(StgFetchMe);
- } else if (get_itbl((StgClosure*)p)->type == IND) {
- *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
- size = sizeofW(StgInd);
- } else {
- size = checkClosure((StgClosure *)p);
- /* This is the smallest size of closure that can live in the heap. */
- ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
- }
- }
-}
-#else /* !PAR */
void
checkHeapChunk(StgPtr start, StgPtr end)
{
ASSERT( size >= MIN_PAYLOAD_SIZE + sizeofW(StgHeader) );
}
}
-#endif
void
checkLargeObjects(bdescr *bd)
ASSERT(stack <= sp && sp < stack_end);
-#if defined(PAR)
- ASSERT(tso->par.magic==TSO_MAGIC);
-
- switch (tso->why_blocked) {
- case BlockedOnGA:
- checkClosureShallow(tso->block_info.closure);
- ASSERT(/* Can't be a FETCH_ME because *this* closure is on its BQ */
- get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
- break;
- case BlockedOnGA_NoSend:
- checkClosureShallow(tso->block_info.closure);
- ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
- break;
- case BlockedOnBlackHole:
- checkClosureShallow(tso->block_info.closure);
- ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE ||
- get_itbl(tso->block_info.closure)->type==RBH);
- break;
- case BlockedOnRead:
- case BlockedOnWrite:
- case BlockedOnDelay:
-#if defined(mingw32_HOST_OS)
- case BlockedOnDoProc:
-#endif
- /* isOnBQ(blocked_queue) */
- break;
- case BlockedOnException:
- /* isOnSomeBQ(tso) */
- ASSERT(get_itbl(tso->block_info.tso)->type==TSO);
- break;
- case BlockedOnMVar:
- ASSERT(get_itbl(tso->block_info.closure)->type==MVAR);
- break;
- case BlockedOnSTM:
- ASSERT(tso->block_info.closure == END_TSO_QUEUE);
- break;
- default:
- /*
- Could check other values of why_blocked but I am more
- lazy than paranoid (bad combination) -- HWL
- */
- }
-
- /* if the link field is non-nil it most point to one of these
- three closure types */
- ASSERT(tso->link == END_TSO_QUEUE ||
- get_itbl(tso->link)->type == TSO ||
- get_itbl(tso->link)->type == BLOCKED_FETCH ||
- get_itbl(tso->link)->type == CONSTR);
-#endif
-
checkStackChunk(sp, stack_end);
}
-#if defined(GRAN)
-void
-checkTSOsSanity(void) {
- nat i, tsos;
- StgTSO *tso;
-
- debugBelch("Checking sanity of all runnable TSOs:");
-
- for (i=0, tsos=0; i<RtsFlags.GranFlags.proc; i++) {
- for (tso=run_queue_hds[i]; tso!=END_TSO_QUEUE; tso=tso->link) {
- debugBelch("TSO %p on PE %d ...", tso, i);
- checkTSO(tso);
- debugBelch("OK, ");
- tsos++;
- }
- }
-
- debugBelch(" checked %d TSOs on %d PEs; ok\n", tsos, RtsFlags.GranFlags.proc);
-}
-
-
-// still GRAN only
-
-rtsBool
-checkThreadQSanity (PEs proc, rtsBool check_TSO_too)
-{
- StgTSO *tso, *prev;
-
- /* the NIL value for TSOs is END_TSO_QUEUE; thus, finding NULL is an error */
- ASSERT(run_queue_hds[proc]!=NULL);
- ASSERT(run_queue_tls[proc]!=NULL);
- /* if either head or tail is NIL then the other one must be NIL, too */
- ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE || run_queue_tls[proc]==END_TSO_QUEUE);
- ASSERT(run_queue_tls[proc]!=END_TSO_QUEUE || run_queue_hds[proc]==END_TSO_QUEUE);
- for (tso=run_queue_hds[proc], prev=END_TSO_QUEUE;
- tso!=END_TSO_QUEUE;
- prev=tso, tso=tso->link) {
- ASSERT((prev!=END_TSO_QUEUE || tso==run_queue_hds[proc]) &&
- (prev==END_TSO_QUEUE || prev->link==tso));
- if (check_TSO_too)
- checkTSO(tso);
- }
- ASSERT(prev==run_queue_tls[proc]);
-}
-
-rtsBool
-checkThreadQsSanity (rtsBool check_TSO_too)
-{
- PEs p;
-
- for (p=0; p<RtsFlags.GranFlags.proc; p++)
- checkThreadQSanity(p, check_TSO_too);
-}
-#endif /* GRAN */
-
/*
Check that all TSOs have been evacuated.
Optionally also check the sanity of the TSOs.
}
}
-/*
- Check the sanity of a blocking queue starting at bqe with closure being
- the closure holding the blocking queue.
- Note that in GUM we can have several different closure types in a
- blocking queue
-*/
-#if defined(PAR)
-void
-checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
-{
- rtsBool end = rtsFalse;
- StgInfoTable *info = get_itbl(closure);
-
- ASSERT(info->type == MVAR || info->type == FETCH_ME_BQ || info->type == RBH);
-
- do {
- switch (get_itbl(bqe)->type) {
- case BLOCKED_FETCH:
- case TSO:
- checkClosure((StgClosure *)bqe);
- bqe = bqe->link;
- end = (bqe==END_BQ_QUEUE);
- break;
-
- case CONSTR:
- checkClosure((StgClosure *)bqe);
- end = rtsTrue;
- break;
-
- default:
- barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
- get_itbl(bqe)->type, closure, info_type(closure));
- }
- } while (!end);
-}
-#elif defined(GRAN)
-void
-checkBQ (StgTSO *bqe, StgClosure *closure)
-{
- rtsBool end = rtsFalse;
- StgInfoTable *info = get_itbl(closure);
-
- ASSERT(info->type == MVAR);
-
- do {
- switch (get_itbl(bqe)->type) {
- case BLOCKED_FETCH:
- case TSO:
- checkClosure((StgClosure *)bqe);
- bqe = bqe->link;
- end = (bqe==END_BQ_QUEUE);
- break;
-
- default:
- barf("checkBQ: strange closure %d in blocking queue for closure %p (%s)\n",
- get_itbl(bqe)->type, closure, info_type(closure));
- }
- } while (!end);
-}
-#endif
-
-
-
-/*
- This routine checks the sanity of the LAGA and GALA tables. They are
- implemented as lists through one hash table, LAtoGALAtable, because entries
- in both tables have the same structure:
- - the LAGA table maps local addresses to global addresses; it starts
- with liveIndirections
- - the GALA table maps global addresses to local addresses; it starts
- with liveRemoteGAs
-*/
-
-#if defined(PAR)
-#include "Hash.h"
-
-/* hidden in parallel/Global.c; only accessed for testing here */
-extern GALA *liveIndirections;
-extern GALA *liveRemoteGAs;
-extern HashTable *LAtoGALAtable;
-
-void
-checkLAGAtable(rtsBool check_closures)
-{
- GALA *gala, *gala0;
- nat n=0, m=0; // debugging
-
- for (gala = liveIndirections; gala != NULL; gala = gala->next) {
- n++;
- gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
- ASSERT(!gala->preferred || gala == gala0);
- ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
- ASSERT(gala->next!=gala); // detect direct loops
- if ( check_closures ) {
- checkClosure((StgClosure *)gala->la);
- }
- }
-
- for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
- m++;
- gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
- ASSERT(!gala->preferred || gala == gala0);
- ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
- ASSERT(gala->next!=gala); // detect direct loops
- /*
- if ( check_closures ) {
- checkClosure((StgClosure *)gala->la);
- }
- */
- }
-}
-#endif
-
#endif /* DEBUG */
extern void checkMutableList ( bdescr *bd, nat gen );
extern void checkMutableLists ( rtsBool checkTSOs );
-#if defined(GRAN)
-extern void checkTSOsSanity(void);
-extern rtsBool checkThreadQSanity (PEs proc, rtsBool check_TSO_too);
-extern rtsBool checkThreadQsSanity (rtsBool check_TSO_too);
-#endif
-
-#if defined(PAR)
-extern void checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure);
-#else
extern void checkBQ (StgTSO *bqe, StgClosure *closure);
-#endif
-
-#if defined(PAR)
-extern void checkLAGAtable(rtsBool check_closures);
-extern void checkHeapChunk(StgPtr start, StgPtr end);
-#endif
/* test whether an object is already on update list */
extern rtsBool isBlackhole( StgTSO* tso, StgClosure* p );
static void scheduleCheckBlackHoles (Capability *cap);
static void scheduleDetectDeadlock (Capability *cap, Task *task);
static void schedulePushWork(Capability *cap, Task *task);
-#if defined(PARALLEL_HASKELL)
-static rtsBool scheduleGetRemoteWork(Capability *cap);
-static void scheduleSendPendingMessages(void);
-#endif
-#if defined(PARALLEL_HASKELL) || defined(THREADED_RTS)
+#if defined(THREADED_RTS)
static void scheduleActivateSpark(Capability *cap);
#endif
static void schedulePostRunThread(Capability *cap, StgTSO *t);
STATIC_INLINE void
addToRunQueue( Capability *cap, StgTSO *t )
{
-#if defined(PARALLEL_HASKELL)
- if (RtsFlags.ParFlags.doFairScheduling) {
- // this does round-robin scheduling; good for concurrency
- appendToRunQueue(cap,t);
- } else {
- // this does unfair scheduling; good for parallelism
- pushOnRunQueue(cap,t);
- }
-#else
// this does round-robin scheduling; good for concurrency
appendToRunQueue(cap,t);
-#endif
}
/* ---------------------------------------------------------------------------
StgTSO *t;
Capability *cap;
StgThreadReturnCode ret;
-#if defined(PARALLEL_HASKELL)
- rtsBool receivedFinish = rtsFalse;
-#endif
nat prev_what_next;
rtsBool ready_to_gc;
#if defined(THREADED_RTS)
// -----------------------------------------------------------
// Scheduler loop starts here:
-#if defined(PARALLEL_HASKELL)
-#define TERMINATION_CONDITION (!receivedFinish)
-#else
-#define TERMINATION_CONDITION rtsTrue
-#endif
-
- while (TERMINATION_CONDITION) {
+ while (1) {
// Check whether we have re-entered the RTS from Haskell without
// going via suspendThread()/resumeThread (i.e. a 'safe' foreign
(pushes threads, wakes up idle capabilities for stealing) */
schedulePushWork(cap,task);
-#if defined(PARALLEL_HASKELL)
- /* since we perform a blocking receive and continue otherwise,
- either we never reach here or we definitely have work! */
- // from here: non-empty run queue
- ASSERT(!emptyRunQueue(cap));
-
- if (PacketsWaiting()) { /* now process incoming messages, if any
- pending...
-
- CAUTION: scheduleGetRemoteWork called
- above, waits for messages as well! */
- processMessages(cap, &receivedFinish);
- }
-#endif // PARALLEL_HASKELL: non-empty run queue!
-
scheduleDetectDeadlock(cap,task);
#if defined(THREADED_RTS)
scheduleCheckBlockedThreads(cap);
-#if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
+#if defined(THREADED_RTS)
if (emptyRunQueue(cap)) { scheduleActivateSpark(cap); }
#endif
-
-#if defined(PARALLEL_HASKELL)
- // if messages have been buffered...
- scheduleSendPendingMessages();
-#endif
-
-#if defined(PARALLEL_HASKELL)
- if (emptyRunQueue(cap)) {
- receivedFinish = scheduleGetRemoteWork(cap);
- continue; // a new round, (hopefully) with new work
- /*
- in GUM, this a) sends out a FISH and returns IF no fish is
- out already
- b) (blocking) awaits and receives messages
-
- in Eden, this is only the blocking receive, as b) in GUM.
- */
- }
-#endif
}
#if defined(THREADED_RTS)
static void
scheduleDetectDeadlock (Capability *cap, Task *task)
{
-
-#if defined(PARALLEL_HASKELL)
- // ToDo: add deadlock detection in GUM (similar to THREADED_RTS) -- HWL
- return;
-#endif
-
/*
* Detect deadlock: when we have no threads to run, there are no
* threads blocked, waiting for I/O, or sleeping, and all the
* Activate spark threads (PARALLEL_HASKELL and THREADED_RTS)
* ------------------------------------------------------------------------- */
-#if defined(PARALLEL_HASKELL) || defined(THREADED_RTS)
+#if defined(THREADED_RTS)
static void
scheduleActivateSpark(Capability *cap)
{
#endif // PARALLEL_HASKELL || THREADED_RTS
/* ----------------------------------------------------------------------------
- * Get work from a remote node (PARALLEL_HASKELL only)
- * ------------------------------------------------------------------------- */
-
-#if defined(PARALLEL_HASKELL)
-static rtsBool /* return value used in PARALLEL_HASKELL only */
-scheduleGetRemoteWork (Capability *cap STG_UNUSED)
-{
-#if defined(PARALLEL_HASKELL)
- rtsBool receivedFinish = rtsFalse;
-
- // idle() , i.e. send all buffers, wait for work
- if (RtsFlags.ParFlags.BufferTime) {
- IF_PAR_DEBUG(verbose,
- debugBelch("...send all pending data,"));
- {
- nat i;
- for (i=1; i<=nPEs; i++)
- sendImmediately(i); // send all messages away immediately
- }
- }
-
- /* this would be the place for fishing in GUM...
-
- if (no-earlier-fish-around)
- sendFish(choosePe());
- */
-
- // Eden:just look for incoming messages (blocking receive)
- IF_PAR_DEBUG(verbose,
- debugBelch("...wait for incoming messages...\n"));
- processMessages(cap, &receivedFinish); // blocking receive...
-
-
- return receivedFinish;
- // reenter scheduling look after having received something
-
-#else /* !PARALLEL_HASKELL, i.e. THREADED_RTS */
-
- return rtsFalse; /* return value unused in THREADED_RTS */
-
-#endif /* PARALLEL_HASKELL */
-}
-#endif // PARALLEL_HASKELL || THREADED_RTS
-
-/* ----------------------------------------------------------------------------
* After running a thread...
* ------------------------------------------------------------------------- */
static void
scheduleHandleThreadBlocked( StgTSO *t
-#if !defined(GRAN) && !defined(DEBUG)
+#if !defined(DEBUG)
STG_UNUSED
#endif
)
initTaskManager();
-#if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
+#if defined(THREADED_RTS)
initSparkPools();
#endif
tso->sp = (P_)&(tso->stack[tso->stack_size]);
tso->why_blocked = NotBlocked;
- IF_PAR_DEBUG(verbose,
- debugBelch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld\n",
- tso->id, tso, tso->stack_size);
- /* If we're debugging, just print out the top of the stack */
- printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
- tso->sp+64)));
-
unlockTSO(dest);
unlockTSO(tso);
* Called from STG : yes
* Locks assumed : none
*/
-#if defined(GRAN)
-void awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node);
-#elif defined(PAR)
-void awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node);
-#else
void awakenBlockedQueue (Capability *cap, StgTSO *tso);
-#endif
/* wakeUpRts()
*
void OSThreadProcAttr workerStart(Task *task);
#endif
-#if defined(GRAN)
-void awaken_blocked_queue(StgBlockingQueueElement *q, StgClosure *node);
-void unlink_from_bq(StgTSO* tso, StgClosure* node);
-void initThread(StgTSO *tso, nat stack_size, StgInt pri);
-#elif defined(PAR)
-nat run_queue_len(void);
-void awaken_blocked_queue(StgBlockingQueueElement *q, StgClosure *node);
-void initThread(StgTSO *tso, nat stack_size);
-#else
char *info_type(StgClosure *closure); // dummy
char *info_type_by_ip(StgInfoTable *ip); // dummy
void awaken_blocked_queue(StgTSO *q);
void initThread(StgTSO *tso, nat stack_size);
-#endif
/* The state of the scheduler. This is used to control the sequence
* of events during shutdown, and when the runtime is interrupted
*
* In GranSim we have one run/blocked_queue per PE.
*/
-#if defined(GRAN)
-// run_queue_hds defined in GranSim.h
-#else
extern StgTSO *RTS_VAR(blackhole_queue);
#if !defined(THREADED_RTS)
extern StgTSO *RTS_VAR(blocked_queue_hd), *RTS_VAR(blocked_queue_tl);
extern StgTSO *RTS_VAR(sleeping_queue);
#endif
-#endif
/* Set to rtsTrue if there are threads on the blackhole_queue, and
* it is possible that one or more of them may be available to run.
#ifdef DEBUG
void print_bq (StgClosure *node);
#endif
-#if defined(PAR)
-void print_bqe (StgBlockingQueueElement *bqe);
-#endif
/* -----------------------------------------------------------------------------
* Some convenient macros/inline functions...
#include "Sparks.h"
-#if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
+#if defined(THREADED_RTS)
void
initSparkPools( void )
{
-#ifdef THREADED_RTS
/* walk over the capabilities, allocating a spark pool for each one */
nat i;
for (i = 0; i < n_capabilities; i++) {
capabilities[i].sparks = newWSDeque(RtsFlags.ParFlags.maxLocalSparks);
}
-#else
- /* allocate a single spark pool */
- MainCapability->sparks = newWSDeque(RtsFlags.ParFlags.maxLocalSparks);
-#endif
}
void
return 1;
}
-
-#endif /* PARALLEL_HASKELL || THREADED_RTS */
-
-
-/* -----------------------------------------------------------------------------
- *
- * GRAN & PARALLEL_HASKELL stuff beyond here.
- *
- * TODO "nuke" this!
- *
- * -------------------------------------------------------------------------- */
-
-#if defined(PARALLEL_HASKELL) || defined(GRAN)
-
-static void slide_spark_pool( StgSparkPool *pool );
-
-rtsBool
-add_to_spark_queue( StgClosure *closure, StgSparkPool *pool )
-{
- if (pool->tl == pool->lim)
- slide_spark_pool(pool);
-
- if (closure_SHOULD_SPARK(closure) &&
- pool->tl < pool->lim) {
- *(pool->tl++) = closure;
-
-#if defined(PARALLEL_HASKELL)
- // collect parallel global statistics (currently done together with GC stats)
- if (RtsFlags.ParFlags.ParStats.Global &&
- RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
- // debugBelch("Creating spark for %x @ %11.2f\n", closure, usertime());
- globalParStats.tot_sparks_created++;
- }
-#endif
- return rtsTrue;
- } else {
-#if defined(PARALLEL_HASKELL)
- // collect parallel global statistics (currently done together with GC stats)
- if (RtsFlags.ParFlags.ParStats.Global &&
- RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
- //debugBelch("Ignoring spark for %x @ %11.2f\n", closure, usertime());
- globalParStats.tot_sparks_ignored++;
- }
-#endif
- return rtsFalse;
- }
-}
-
-static void
-slide_spark_pool( StgSparkPool *pool )
-{
- StgClosure **sparkp, **to_sparkp;
-
- sparkp = pool->hd;
- to_sparkp = pool->base;
- while (sparkp < pool->tl) {
- ASSERT(to_sparkp<=sparkp);
- ASSERT(*sparkp!=NULL);
- ASSERT(LOOKS_LIKE_GHC_INFO((*sparkp)->header.info));
-
- if (closure_SHOULD_SPARK(*sparkp)) {
- *to_sparkp++ = *sparkp++;
- } else {
- sparkp++;
- }
- }
- pool->hd = pool->base;
- pool->tl = to_sparkp;
-}
-
-void
-disposeSpark(spark)
-StgClosure *spark;
-{
-#if !defined(THREADED_RTS)
- Capability *cap;
- StgSparkPool *pool;
-
- cap = &MainRegTable;
- pool = &(cap->rSparks);
- ASSERT(pool->hd <= pool->tl && pool->tl <= pool->lim);
-#endif
- ASSERT(spark != (StgClosure *)NULL);
- /* Do nothing */
-}
-
-
-#elif defined(GRAN)
-
-/*
- Search the spark queue of the proc in event for a spark that's worth
- turning into a thread
- (was gimme_spark in the old RTS)
-*/
-void
-findLocalSpark (rtsEvent *event, rtsBool *found_res, rtsSparkQ *spark_res)
-{
- PEs proc = event->proc, /* proc to search for work */
- creator = event->creator; /* proc that requested work */
- StgClosure* node;
- rtsBool found;
- rtsSparkQ spark_of_non_local_node = NULL,
- spark_of_non_local_node_prev = NULL,
- low_priority_spark = NULL,
- low_priority_spark_prev = NULL,
- spark = NULL, prev = NULL;
-
- /* Choose a spark from the local spark queue */
- prev = (rtsSpark*)NULL;
- spark = pending_sparks_hds[proc];
- found = rtsFalse;
-
- // ToDo: check this code & implement local sparking !! -- HWL
- while (!found && spark != (rtsSpark*)NULL)
- {
- ASSERT((prev!=(rtsSpark*)NULL || spark==pending_sparks_hds[proc]) &&
- (prev==(rtsSpark*)NULL || prev->next==spark) &&
- (spark->prev==prev));
- node = spark->node;
- if (!closure_SHOULD_SPARK(node))
- {
- IF_GRAN_DEBUG(checkSparkQ,
- debugBelch("^^ pruning spark %p (node %p) in gimme_spark",
- spark, node));
-
- if (RtsFlags.GranFlags.GranSimStats.Sparks)
- DumpRawGranEvent(proc, (PEs)0, SP_PRUNED,(StgTSO*)NULL,
- spark->node, spark->name, spark_queue_len(proc));
-
- ASSERT(spark != (rtsSpark*)NULL);
- ASSERT(SparksAvail>0);
- --SparksAvail;
-
- ASSERT(prev==(rtsSpark*)NULL || prev->next==spark);
- spark = delete_from_sparkq (spark, proc, rtsTrue);
- if (spark != (rtsSpark*)NULL)
- prev = spark->prev;
- continue;
- }
- /* -- node should eventually be sparked */
- else if (RtsFlags.GranFlags.PreferSparksOfLocalNodes &&
- !IS_LOCAL_TO(PROCS(node),CurrentProc))
- {
- barf("Local sparking not yet implemented");
-
- /* Remember first low priority spark */
- if (spark_of_non_local_node==(rtsSpark*)NULL) {
- spark_of_non_local_node_prev = prev;
- spark_of_non_local_node = spark;
- }
-
- if (spark->next == (rtsSpark*)NULL) {
- /* ASSERT(spark==SparkQueueTl); just for testing */
- prev = spark_of_non_local_node_prev;
- spark = spark_of_non_local_node;
- found = rtsTrue;
- break;
- }
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- /* Should never happen; just for testing
- if (spark==pending_sparks_tl) {
- debugBelch("ReSchedule: Last spark != SparkQueueTl\n");
- stg_exit(EXIT_FAILURE);
- } */
-# endif
- prev = spark;
- spark = spark->next;
- ASSERT(SparksAvail>0);
- --SparksAvail;
- continue;
- }
- else if ( RtsFlags.GranFlags.DoPrioritySparking ||
- (spark->gran_info >= RtsFlags.GranFlags.SparkPriority2) )
- {
- if (RtsFlags.GranFlags.DoPrioritySparking)
- barf("Priority sparking not yet implemented");
-
- found = rtsTrue;
- }
-#if 0
- else /* only used if SparkPriority2 is defined */
- {
- /* ToDo: fix the code below and re-integrate it */
- /* Remember first low priority spark */
- if (low_priority_spark==(rtsSpark*)NULL) {
- low_priority_spark_prev = prev;
- low_priority_spark = spark;
- }
-
- if (spark->next == (rtsSpark*)NULL) {
- /* ASSERT(spark==spark_queue_tl); just for testing */
- prev = low_priority_spark_prev;
- spark = low_priority_spark;
- found = rtsTrue; /* take low pri spark => rc is 2 */
- break;
- }
-
- /* Should never happen; just for testing
- if (spark==pending_sparks_tl) {
- debugBelch("ReSchedule: Last spark != SparkQueueTl\n");
- stg_exit(EXIT_FAILURE);
- break;
- } */
- prev = spark;
- spark = spark->next;
-
- IF_GRAN_DEBUG(pri,
- debugBelch("++ Ignoring spark of priority %u (SparkPriority=%u); node=%p; name=%u\n",
- spark->gran_info, RtsFlags.GranFlags.SparkPriority,
- spark->node, spark->name);)
- }
-#endif
- } /* while (spark!=NULL && !found) */
-
- *spark_res = spark;
- *found_res = found;
-}
-
-/*
- Turn the spark into a thread.
- In GranSim this basically means scheduling a StartThread event for the
- node pointed to by the spark at some point in the future.
- (was munch_spark in the old RTS)
-*/
-rtsBool
-activateSpark (rtsEvent *event, rtsSparkQ spark)
-{
- PEs proc = event->proc, /* proc to search for work */
- creator = event->creator; /* proc that requested work */
- StgTSO* tso;
- StgClosure* node;
- rtsTime spark_arrival_time;
-
- /*
- We've found a node on PE proc requested by PE creator.
- If proc==creator we can turn the spark into a thread immediately;
- otherwise we schedule a MoveSpark event on the requesting PE
- */
-
- /* DaH Qu' yIchen */
- if (proc!=creator) {
-
- /* only possible if we simulate GUM style fishing */
- ASSERT(RtsFlags.GranFlags.Fishing);
-
- /* Message packing costs for sending a Fish; qeq jabbI'ID */
- CurrentTime[proc] += RtsFlags.GranFlags.Costs.mpacktime;
-
- if (RtsFlags.GranFlags.GranSimStats.Sparks)
- DumpRawGranEvent(proc, (PEs)0, SP_EXPORTED,
- (StgTSO*)NULL, spark->node,
- spark->name, spark_queue_len(proc));
-
- /* time of the spark arrival on the remote PE */
- spark_arrival_time = CurrentTime[proc] + RtsFlags.GranFlags.Costs.latency;
-
- new_event(creator, proc, spark_arrival_time,
- MoveSpark,
- (StgTSO*)NULL, spark->node, spark);
-
- CurrentTime[proc] += RtsFlags.GranFlags.Costs.mtidytime;
-
- } else { /* proc==creator i.e. turn the spark into a thread */
-
- if ( RtsFlags.GranFlags.GranSimStats.Global &&
- spark->gran_info < RtsFlags.GranFlags.SparkPriority2 ) {
-
- globalGranStats.tot_low_pri_sparks++;
- IF_GRAN_DEBUG(pri,
- debugBelch("++ No high priority spark available; low priority (%u) spark chosen: node=%p; name=%u\n",
- spark->gran_info,
- spark->node, spark->name));
- }
-
- CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadcreatetime;
-
- node = spark->node;
-
-# if 0
- /* ToDo: fix the GC interface and move to StartThread handling-- HWL */
- if (GARBAGE COLLECTION IS NECESSARY) {
- /* Some kind of backoff needed here in case there's too little heap */
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RtsFlags.GcFlags.giveStats)
- fprintf(RtsFlags.GcFlags.statsFile,"***** vIS Qu' chen veQ boSwI'; spark=%p, node=%p; name=%u\n",
- /* (found==2 ? "no hi pri spark" : "hi pri spark"), */
- spark, node, spark->name);
-# endif
- new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc]+1,
- FindWork,
- (StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
- barf("//// activateSpark: out of heap ; ToDo: call GarbageCollect()");
- GarbageCollect(GetRoots, rtsFalse);
- // HWL old: ReallyPerformThreadGC(TSO_HS+TSO_CTS_SIZE,rtsFalse);
- // HWL old: SAVE_Hp -= TSO_HS+TSO_CTS_SIZE;
- spark = NULL;
- return; /* was: continue; */ /* to the next event, eventually */
- }
-# endif
-
- if (RtsFlags.GranFlags.GranSimStats.Sparks)
- DumpRawGranEvent(CurrentProc,(PEs)0,SP_USED,(StgTSO*)NULL,
- spark->node, spark->name,
- spark_queue_len(CurrentProc));
-
- new_event(proc, proc, CurrentTime[proc],
- StartThread,
- END_TSO_QUEUE, node, spark); // (rtsSpark*)NULL);
-
- procStatus[proc] = Starting;
- }
-}
-
-/* -------------------------------------------------------------------------
- This is the main point where handling granularity information comes into
- play.
- ------------------------------------------------------------------------- */
-
-#define MAX_RAND_PRI 100
-
-/*
- Granularity info transformers.
- Applied to the GRAN_INFO field of a spark.
-*/
-STATIC_INLINE nat ID(nat x) { return(x); };
-STATIC_INLINE nat INV(nat x) { return(-x); };
-STATIC_INLINE nat IGNORE(nat x) { return (0); };
-STATIC_INLINE nat RAND(nat x) { return ((random() % MAX_RAND_PRI) + 1); }
-
-/* NB: size_info and par_info are currently unused (what a shame!) -- HWL */
-rtsSpark *
-newSpark(node,name,gran_info,size_info,par_info,local)
-StgClosure *node;
-nat name, gran_info, size_info, par_info, local;
-{
- nat pri;
- rtsSpark *newspark;
-
- pri = RtsFlags.GranFlags.RandomPriorities ? RAND(gran_info) :
- RtsFlags.GranFlags.InversePriorities ? INV(gran_info) :
- RtsFlags.GranFlags.IgnorePriorities ? IGNORE(gran_info) :
- ID(gran_info);
-
- if ( RtsFlags.GranFlags.SparkPriority!=0 &&
- pri<RtsFlags.GranFlags.SparkPriority ) {
- IF_GRAN_DEBUG(pri,
- debugBelch(",, NewSpark: Ignoring spark of priority %u (SparkPriority=%u); node=%#x; name=%u\n",
- pri, RtsFlags.GranFlags.SparkPriority, node, name));
- return ((rtsSpark*)NULL);
- }
-
- newspark = (rtsSpark*) stgMallocBytes(sizeof(rtsSpark), "NewSpark");
- newspark->prev = newspark->next = (rtsSpark*)NULL;
- newspark->node = node;
- newspark->name = (name==1) ? CurrentTSO->gran.sparkname : name;
- newspark->gran_info = pri;
- newspark->global = !local; /* Check that with parAt, parAtAbs !!*/
-
- if (RtsFlags.GranFlags.GranSimStats.Global) {
- globalGranStats.tot_sparks_created++;
- globalGranStats.sparks_created_on_PE[CurrentProc]++;
- }
-
- return(newspark);
-}
-
-void
-disposeSpark(spark)
-rtsSpark *spark;
-{
- ASSERT(spark!=NULL);
- stgFree(spark);
-}
-
-void
-disposeSparkQ(spark)
-rtsSparkQ spark;
-{
- if (spark==NULL)
- return;
-
- disposeSparkQ(spark->next);
-
-# ifdef GRAN_CHECK
- if (SparksAvail < 0) {
- debugBelch("disposeSparkQ: SparksAvail<0 after disposing sparkq @ %p\n", &spark);
- print_spark(spark);
- }
-# endif
-
- stgFree(spark);
-}
-
-/*
- With PrioritySparking add_to_spark_queue performs an insert sort to keep
- the spark queue sorted. Otherwise the spark is just added to the end of
- the queue.
-*/
-
-void
-add_to_spark_queue(spark)
-rtsSpark *spark;
-{
- rtsSpark *prev = NULL, *next = NULL;
- nat count = 0;
- rtsBool found = rtsFalse;
-
- if ( spark == (rtsSpark *)NULL ) {
- return;
- }
-
- if (RtsFlags.GranFlags.DoPrioritySparking && (spark->gran_info != 0) ) {
- /* Priority sparking is enabled i.e. spark queues must be sorted */
-
- for (prev = NULL, next = pending_sparks_hd, count=0;
- (next != NULL) &&
- !(found = (spark->gran_info >= next->gran_info));
- prev = next, next = next->next, count++)
- {}
-
- } else { /* 'utQo' */
- /* Priority sparking is disabled */
-
- found = rtsFalse; /* to add it at the end */
-
- }
-
- if (found) {
- /* next points to the first spark with a gran_info smaller than that
- of spark; therefore, add spark before next into the spark queue */
- spark->next = next;
- if ( next == NULL ) {
- pending_sparks_tl = spark;
- } else {
- next->prev = spark;
- }
- spark->prev = prev;
- if ( prev == NULL ) {
- pending_sparks_hd = spark;
- } else {
- prev->next = spark;
- }
- } else { /* (RtsFlags.GranFlags.DoPrioritySparking && !found) || !DoPrioritySparking */
- /* add the spark at the end of the spark queue */
- spark->next = NULL;
- spark->prev = pending_sparks_tl;
- if (pending_sparks_hd == NULL)
- pending_sparks_hd = spark;
- else
- pending_sparks_tl->next = spark;
- pending_sparks_tl = spark;
- }
- ++SparksAvail;
-
- /* add costs for search in priority sparking */
- if (RtsFlags.GranFlags.DoPrioritySparking) {
- CurrentTime[CurrentProc] += count * RtsFlags.GranFlags.Costs.pri_spark_overhead;
- }
-
- IF_GRAN_DEBUG(checkSparkQ,
- debugBelch("++ Spark stats after adding spark %p (node %p) to queue on PE %d",
- spark, spark->node, CurrentProc);
- print_sparkq_stats());
-
-# if defined(GRAN_CHECK)
- if (RtsFlags.GranFlags.Debug.checkSparkQ) {
- for (prev = NULL, next = pending_sparks_hd;
- (next != NULL);
- prev = next, next = next->next)
- {}
- if ( (prev!=NULL) && (prev!=pending_sparks_tl) )
- debugBelch("SparkQ inconsistency after adding spark %p: (PE %u) pending_sparks_tl (%p) not end of queue (%p)\n",
- spark,CurrentProc,
- pending_sparks_tl, prev);
- }
-# endif
-
-# if defined(GRAN_CHECK)
- /* Check if the sparkq is still sorted. Just for testing, really! */
- if ( RtsFlags.GranFlags.Debug.checkSparkQ &&
- RtsFlags.GranFlags.Debug.pri ) {
- rtsBool sorted = rtsTrue;
- rtsSpark *prev, *next;
-
- if (pending_sparks_hd == NULL ||
- pending_sparks_hd->next == NULL ) {
- /* just 1 elem => ok */
- } else {
- for (prev = pending_sparks_hd,
- next = pending_sparks_hd->next;
- (next != NULL) ;
- prev = next, next = next->next) {
- sorted = sorted &&
- (prev->gran_info >= next->gran_info);
- }
- }
- if (!sorted) {
- debugBelch("ghuH: SPARKQ on PE %d is not sorted:\n",
- CurrentProc);
- print_sparkq(CurrentProc);
- }
- }
-# endif
-}
-
-nat
-spark_queue_len(proc)
-PEs proc;
-{
- rtsSpark *prev, *spark; /* prev only for testing !! */
- nat len;
-
- for (len = 0, prev = NULL, spark = pending_sparks_hds[proc];
- spark != NULL;
- len++, prev = spark, spark = spark->next)
- {}
-
-# if defined(GRAN_CHECK)
- if ( RtsFlags.GranFlags.Debug.checkSparkQ )
- if ( (prev!=NULL) && (prev!=pending_sparks_tls[proc]) )
- debugBelch("ERROR in spark_queue_len: (PE %u) pending_sparks_tl (%p) not end of queue (%p)\n",
- proc, pending_sparks_tls[proc], prev);
-# endif
-
- return (len);
-}
-
-/*
- Take spark out of the spark queue on PE p and nuke the spark. Adjusts
- hd and tl pointers of the spark queue. Returns a pointer to the next
- spark in the queue.
-*/
-rtsSpark *
-delete_from_sparkq (spark, p, dispose_too) /* unlink and dispose spark */
-rtsSpark *spark;
-PEs p;
-rtsBool dispose_too;
-{
- rtsSpark *new_spark;
-
- if (spark==NULL)
- barf("delete_from_sparkq: trying to delete NULL spark\n");
-
-# if defined(GRAN_CHECK)
- if ( RtsFlags.GranFlags.Debug.checkSparkQ ) {
- debugBelch("## |%p:%p| (%p)<-spark=%p->(%p) <-(%p)\n",
- pending_sparks_hd, pending_sparks_tl,
- spark->prev, spark, spark->next,
- (spark->next==NULL ? 0 : spark->next->prev));
- }
-# endif
-
- if (spark->prev==NULL) {
- /* spark is first spark of queue => adjust hd pointer */
- ASSERT(pending_sparks_hds[p]==spark);
- pending_sparks_hds[p] = spark->next;
- } else {
- spark->prev->next = spark->next;
- }
- if (spark->next==NULL) {
- ASSERT(pending_sparks_tls[p]==spark);
- /* spark is first spark of queue => adjust tl pointer */
- pending_sparks_tls[p] = spark->prev;
- } else {
- spark->next->prev = spark->prev;
- }
- new_spark = spark->next;
-
-# if defined(GRAN_CHECK)
- if ( RtsFlags.GranFlags.Debug.checkSparkQ ) {
- debugBelch("## |%p:%p| (%p)<-spark=%p->(%p) <-(%p); spark=%p will be deleted NOW \n",
- pending_sparks_hd, pending_sparks_tl,
- spark->prev, spark, spark->next,
- (spark->next==NULL ? 0 : spark->next->prev), spark);
- }
-# endif
-
- if (dispose_too)
- disposeSpark(spark);
-
- return new_spark;
-}
-
-/* Mark all nodes pointed to by sparks in the spark queues (for GC) */
-void
-markSparkQueue(void)
-{
- StgClosure *MarkRoot(StgClosure *root); // prototype
- PEs p;
- rtsSpark *sp;
-
- for (p=0; p<RtsFlags.GranFlags.proc; p++)
- for (sp=pending_sparks_hds[p]; sp!=NULL; sp=sp->next) {
- ASSERT(sp->node!=NULL);
- ASSERT(LOOKS_LIKE_GHC_INFO(sp->node->header.info));
- // ToDo?: statistics gathering here (also for GUM!)
- sp->node = (StgClosure *)MarkRoot(sp->node);
- }
-
- IF_DEBUG(gc,
- debugBelch("markSparkQueue: spark statistics at start of GC:");
- print_sparkq_stats());
-}
-
-void
-print_spark(spark)
-rtsSpark *spark;
-{
- char str[16];
-
- if (spark==NULL) {
- debugBelch("Spark: NIL\n");
- return;
- } else {
- sprintf(str,
- ((spark->node==NULL) ? "______" : "%#6lx"),
- stgCast(StgPtr,spark->node));
-
- debugBelch("Spark: Node %8s, Name %#6x, Global %5s, Creator %5x, Prev %6p, Next %6p\n",
- str, spark->name,
- ((spark->global)==rtsTrue?"True":"False"), spark->creator,
- spark->prev, spark->next);
- }
-}
-
-void
-print_sparkq(proc)
-PEs proc;
-// rtsSpark *hd;
-{
- rtsSpark *x = pending_sparks_hds[proc];
-
- debugBelch("Spark Queue of PE %d with root at %p:\n", proc, x);
- for (; x!=(rtsSpark*)NULL; x=x->next) {
- print_spark(x);
- }
-}
-
-/*
- Print a statistics of all spark queues.
-*/
-void
-print_sparkq_stats(void)
-{
- PEs p;
-
- debugBelch("SparkQs: [");
- for (p=0; p<RtsFlags.GranFlags.proc; p++)
- debugBelch(", PE %d: %d", p, spark_queue_len(p));
- debugBelch("\n");
-}
-
-#endif
+#endif /* THREADED_RTS */
#include "WSDeque.h"
-#if defined(PARALLEL_HASKELL)
-#error Sparks.c using new internal structure, needs major overhaul!
-#endif
-
/* typedef for SparkPool in RtsTypes.h */
#if defined(THREADED_RTS)
*/
INFO_TABLE(stg_BLACKHOLE,0,1,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
{
-#if defined(GRAN)
- /* Before overwriting TSO_LINK */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
-#endif
-
TICK_ENT_BH();
#ifdef THREADED_RTS
jump stg_block_blackhole;
}
-#if defined(PAR) || defined(GRAN)
-
-INFO_TABLE(stg_RBH,1,1,RBH,"RBH","RBH")
-{
-# if defined(GRAN)
- /* mainly statistics gathering for GranSim simulation */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
-# endif
-
- /* exactly the same as a BLACKHOLE_BQ_entry -- HWL */
- /* Put ourselves on the blocking queue for this black hole */
- TSO_link(CurrentTSO) = StgBlockingQueue_blocking_queue(R1);
- StgBlockingQueue_blocking_queue(R1) = CurrentTSO;
- /* jot down why and on what closure we are blocked */
- TSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
- TSO_block_info(CurrentTSO) = R1;
-
- /* PAR: dumping of event now done in blockThread -- HWL */
-
- /* stg_gen_block is too heavyweight, use a specialised one */
- jump stg_block_1;
-}
-
-INFO_TABLE(stg_RBH_Save_0,0,2,CONSTR,"RBH_Save_0","RBH_Save_0")
-{ foreign "C" barf("RBH_Save_0 object entered!") never returns; }
-
-INFO_TABLE(stg_RBH_Save_1,1,1,CONSTR,"RBH_Save_1","RBH_Save_1");
-{ foreign "C" barf("RBH_Save_1 object entered!") never returns; }
-
-INFO_TABLE(stg_RBH_Save_2,2,0,CONSTR,"RBH_Save_2","RBH_Save_2");
-{ foreign "C" barf("RBH_Save_2 object entered!") never returns; }
-
-#endif /* defined(PAR) || defined(GRAN) */
-
/* identical to BLACKHOLEs except for the infotag */
INFO_TABLE(stg_CAF_BLACKHOLE,0,1,CAF_BLACKHOLE,"CAF_BLACKHOLE","CAF_BLACKHOLE")
{
-#if defined(GRAN)
- /* mainly statistics gathering for GranSim simulation */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
-#endif
-
TICK_ENT_BH();
LDV_ENTER(R1);
currently pri (priority) is only used in a GRAN setup -- HWL
------------------------------------------------------------------------ */
-#if defined(GRAN)
-/* currently pri (priority) is only used in a GRAN setup -- HWL */
-StgTSO *
-createThread(nat size, StgInt pri)
-#else
StgTSO *
createThread(Capability *cap, nat size)
-#endif
{
StgTSO *tso;
nat stack_size;
/* sched_mutex is *not* required */
/* First check whether we should create a thread at all */
-#if defined(PARALLEL_HASKELL)
- /* check that no more than RtsFlags.ParFlags.maxThreads threads are created */
- if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads) {
- threadsIgnored++;
- debugBelch("{createThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)\n",
- RtsFlags.ParFlags.maxThreads, advisory_thread_count);
- return END_TSO_QUEUE;
- }
- threadsCreated++;
-#endif
-
-#if defined(GRAN)
- ASSERT(!RtsFlags.GranFlags.Light || CurrentProc==0);
-#endif
// ToDo: check whether size = stack_size - TSO_STRUCT_SIZEW
TICK_ALLOC_TSO(stack_size, 0);
SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
-#if defined(GRAN)
- SET_GRAN_HDR(tso, ThisPE);
-#endif
// Always start with the compiled code evaluator
tso->what_next = ThreadRunGHC;
SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
tso->_link = END_TSO_QUEUE;
- // ToDo: check this
-#if defined(GRAN)
- /* uses more flexible routine in GranSim */
- insertThread(tso, CurrentProc);
-#else
- /* In a non-GranSim setup the pushing of a TSO onto the runq is separated
- * from its creation
- */
-#endif
-
-#if defined(GRAN)
- if (RtsFlags.GranFlags.GranSimStats.Full)
- DumpGranEvent(GR_START,tso);
-#elif defined(PARALLEL_HASKELL)
- if (RtsFlags.ParFlags.ParStats.Full)
- DumpGranEvent(GR_STARTQ,tso);
- /* HACk to avoid SCHEDULE
- LastTSO = tso; */
-#endif
-
/* Link the new thread on the global thread list.
*/
ACQUIRE_LOCK(&sched_mutex);
g0s0->threads = tso;
RELEASE_LOCK(&sched_mutex);
-#if defined(DIST)
- tso->dist.priority = MandatoryPriority; //by default that is...
-#endif
-
-#if defined(GRAN)
- tso->gran.pri = pri;
-# if defined(DEBUG)
- tso->gran.magic = TSO_MAGIC; // debugging only
-# endif
- tso->gran.sparkname = 0;
- tso->gran.startedat = CURRENT_TIME;
- tso->gran.exported = 0;
- tso->gran.basicblocks = 0;
- tso->gran.allocs = 0;
- tso->gran.exectime = 0;
- tso->gran.fetchtime = 0;
- tso->gran.fetchcount = 0;
- tso->gran.blocktime = 0;
- tso->gran.blockcount = 0;
- tso->gran.blockedat = 0;
- tso->gran.globalsparks = 0;
- tso->gran.localsparks = 0;
- if (RtsFlags.GranFlags.Light)
- tso->gran.clock = Now; /* local clock */
- else
- tso->gran.clock = 0;
-
- IF_DEBUG(gran,printTSO(tso));
-#elif defined(PARALLEL_HASKELL)
-# if defined(DEBUG)
- tso->par.magic = TSO_MAGIC; // debugging only
-# endif
- tso->par.sparkname = 0;
- tso->par.startedat = CURRENT_TIME;
- tso->par.exported = 0;
- tso->par.basicblocks = 0;
- tso->par.allocs = 0;
- tso->par.exectime = 0;
- tso->par.fetchtime = 0;
- tso->par.fetchcount = 0;
- tso->par.blocktime = 0;
- tso->par.blockcount = 0;
- tso->par.blockedat = 0;
- tso->par.globalsparks = 0;
- tso->par.localsparks = 0;
-#endif
-
-#if defined(GRAN)
- globalGranStats.tot_threads_created++;
- globalGranStats.threads_created_on_PE[CurrentProc]++;
- globalGranStats.tot_sq_len += spark_queue_len(CurrentProc);
- globalGranStats.tot_sq_probes++;
-#elif defined(PARALLEL_HASKELL)
- // collect parallel global statistics (currently done together with GC stats)
- if (RtsFlags.ParFlags.ParStats.Global &&
- RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
- //debugBelch("Creating thread %d @ %11.2f\n", tso->id, usertime());
- globalParStats.tot_threads_created++;
- }
-#endif
-
postEvent (cap, EVENT_CREATE_THREAD, tso->id, 0);
-#if defined(GRAN)
- debugTrace(GRAN_DEBUG_pri,
- "==__ schedule: Created TSO %d (%p);",
- CurrentProc, tso, tso->id);
-#elif defined(PARALLEL_HASKELL)
- debugTrace(PAR_DEBUG_verbose,
- "==__ schedule: Created TSO %d (%p); %d threads active",
- (long)tso->id, tso, advisory_thread_count);
-#else
debugTrace(DEBUG_sched,
"created thread %ld, stack size = %lx words",
(long)tso->id, (long)tso->stack_size);
-#endif
return tso;
}
-#if defined(PAR)
-/* RFP:
- all parallel thread creation calls should fall through the following routine.
-*/
-StgTSO *
-createThreadFromSpark(rtsSpark spark)
-{ StgTSO *tso;
- ASSERT(spark != (rtsSpark)NULL);
-// JB: TAKE CARE OF THIS COUNTER! BUGGY
- if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads)
- { threadsIgnored++;
- barf("{createSparkThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
- RtsFlags.ParFlags.maxThreads, advisory_thread_count);
- return END_TSO_QUEUE;
- }
- else
- { threadsCreated++;
- tso = createThread(RtsFlags.GcFlags.initialStkSize);
- if (tso==END_TSO_QUEUE)
- barf("createSparkThread: Cannot create TSO");
-#if defined(DIST)
- tso->priority = AdvisoryPriority;
-#endif
- pushClosure(tso,spark);
- addToRunQueue(tso);
- advisory_thread_count++; // JB: TAKE CARE OF THIS COUNTER! BUGGY
- }
- return tso;
-}
-#endif
-
/* ---------------------------------------------------------------------------
* Comparing Thread ids.
*
unblock a single thread.
------------------------------------------------------------------------- */
-#if defined(GRAN)
-STATIC_INLINE void
-unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
-{
-}
-#elif defined(PARALLEL_HASKELL)
-STATIC_INLINE void
-unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
-{
- /* write RESUME events to log file and
- update blocked and fetch time (depending on type of the orig closure) */
- if (RtsFlags.ParFlags.ParStats.Full) {
- DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
- GR_RESUMEQ, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
- 0, 0 /* spark_queue_len(ADVISORY_POOL) */);
- if (emptyRunQueue())
- emitSchedule = rtsTrue;
-
- switch (get_itbl(node)->type) {
- case FETCH_ME_BQ:
- ((StgTSO *)bqe)->par.fetchtime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
- break;
- case RBH:
- case FETCH_ME:
- case BLACKHOLE_BQ:
- ((StgTSO *)bqe)->par.blocktime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
- break;
-#ifdef DIST
- case MVAR:
- break;
-#endif
- default:
- barf("{unblockOne}Daq Qagh: unexpected closure in blocking queue");
- }
- }
-}
-#endif
-
-#if defined(GRAN)
-StgBlockingQueueElement *
-unblockOne(StgBlockingQueueElement *bqe, StgClosure *node)
-{
- StgTSO *tso;
- PEs node_loc, tso_loc;
-
- node_loc = where_is(node); // should be lifted out of loop
- tso = (StgTSO *)bqe; // wastes an assignment to get the type right
- tso_loc = where_is((StgClosure *)tso);
- if (IS_LOCAL_TO(PROCS(node),tso_loc)) { // TSO is local
- /* !fake_fetch => TSO is on CurrentProc is same as IS_LOCAL_TO */
- ASSERT(CurrentProc!=node_loc || tso_loc==CurrentProc);
- CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.lunblocktime;
- // insertThread(tso, node_loc);
- new_event(tso_loc, tso_loc, CurrentTime[CurrentProc],
- ResumeThread,
- tso, node, (rtsSpark*)NULL);
- tso->link = END_TSO_QUEUE; // overwrite link just to be sure
- // len_local++;
- // len++;
- } else { // TSO is remote (actually should be FMBQ)
- CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mpacktime +
- RtsFlags.GranFlags.Costs.gunblocktime +
- RtsFlags.GranFlags.Costs.latency;
- new_event(tso_loc, CurrentProc, CurrentTime[CurrentProc],
- UnblockThread,
- tso, node, (rtsSpark*)NULL);
- tso->link = END_TSO_QUEUE; // overwrite link just to be sure
- // len++;
- }
- /* the thread-queue-overhead is accounted for in either Resume or UnblockThread */
- IF_GRAN_DEBUG(bq,
- debugBelch(" %s TSO %d (%p) [PE %d] (block_info.closure=%p) (next=%p) ,",
- (node_loc==tso_loc ? "Local" : "Global"),
- tso->id, tso, CurrentProc, tso->block_info.closure, tso->link));
- tso->block_info.closure = NULL;
- debugTrace(DEBUG_sched, "-- waking up thread %ld (%p)",
- tso->id, tso));
-}
-#elif defined(PARALLEL_HASKELL)
-StgBlockingQueueElement *
-unblockOne(StgBlockingQueueElement *bqe, StgClosure *node)
-{
- StgBlockingQueueElement *next;
-
- switch (get_itbl(bqe)->type) {
- case TSO:
- ASSERT(((StgTSO *)bqe)->why_blocked != NotBlocked);
- /* if it's a TSO just push it onto the run_queue */
- next = bqe->link;
- ((StgTSO *)bqe)->link = END_TSO_QUEUE; // debugging?
- APPEND_TO_RUN_QUEUE((StgTSO *)bqe);
- threadRunnable();
- unblockCount(bqe, node);
- /* reset blocking status after dumping event */
- ((StgTSO *)bqe)->why_blocked = NotBlocked;
- break;
-
- case BLOCKED_FETCH:
- /* if it's a BLOCKED_FETCH put it on the PendingFetches list */
- next = bqe->link;
- bqe->link = (StgBlockingQueueElement *)PendingFetches;
- PendingFetches = (StgBlockedFetch *)bqe;
- break;
-
-# if defined(DEBUG)
- /* can ignore this case in a non-debugging setup;
- see comments on RBHSave closures above */
- case CONSTR:
- /* check that the closure is an RBHSave closure */
- ASSERT(get_itbl((StgClosure *)bqe) == &stg_RBH_Save_0_info ||
- get_itbl((StgClosure *)bqe) == &stg_RBH_Save_1_info ||
- get_itbl((StgClosure *)bqe) == &stg_RBH_Save_2_info);
- break;
-
- default:
- barf("{unblockOne}Daq Qagh: Unexpected IP (%#lx; %s) in blocking queue at %#lx\n",
- get_itbl((StgClosure *)bqe), info_type((StgClosure *)bqe),
- (StgClosure *)bqe);
-# endif
- }
- IF_PAR_DEBUG(bq, debugBelch(", %p (%s)\n", bqe, info_type((StgClosure*)bqe)));
- return next;
-}
-#endif
-
StgTSO *
unblockOne (Capability *cap, StgTSO *tso)
{
wakes up all the threads on the specified queue.
------------------------------------------------------------------------- */
-#if defined(GRAN)
-void
-awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
-{
- StgBlockingQueueElement *bqe;
- PEs node_loc;
- nat len = 0;
-
- IF_GRAN_DEBUG(bq,
- debugBelch("##-_ AwBQ for node %p on PE %d @ %ld by TSO %d (%p): \n", \
- node, CurrentProc, CurrentTime[CurrentProc],
- CurrentTSO->id, CurrentTSO));
-
- node_loc = where_is(node);
-
- ASSERT(q == END_BQ_QUEUE ||
- get_itbl(q)->type == TSO || // q is either a TSO or an RBHSave
- get_itbl(q)->type == CONSTR); // closure (type constructor)
- ASSERT(is_unique(node));
-
- /* FAKE FETCH: magically copy the node to the tso's proc;
- no Fetch necessary because in reality the node should not have been
- moved to the other PE in the first place
- */
- if (CurrentProc!=node_loc) {
- IF_GRAN_DEBUG(bq,
- debugBelch("## node %p is on PE %d but CurrentProc is %d (TSO %d); assuming fake fetch and adjusting bitmask (old: %#x)\n",
- node, node_loc, CurrentProc, CurrentTSO->id,
- // CurrentTSO, where_is(CurrentTSO),
- node->header.gran.procs));
- node->header.gran.procs = (node->header.gran.procs) | PE_NUMBER(CurrentProc);
- IF_GRAN_DEBUG(bq,
- debugBelch("## new bitmask of node %p is %#x\n",
- node, node->header.gran.procs));
- if (RtsFlags.GranFlags.GranSimStats.Global) {
- globalGranStats.tot_fake_fetches++;
- }
- }
-
- bqe = q;
- // ToDo: check: ASSERT(CurrentProc==node_loc);
- while (get_itbl(bqe)->type==TSO) { // q != END_TSO_QUEUE) {
- //next = bqe->link;
- /*
- bqe points to the current element in the queue
- next points to the next element in the queue
- */
- //tso = (StgTSO *)bqe; // wastes an assignment to get the type right
- //tso_loc = where_is(tso);
- len++;
- bqe = unblockOne(bqe, node);
- }
-
- /* if this is the BQ of an RBH, we have to put back the info ripped out of
- the closure to make room for the anchor of the BQ */
- if (bqe!=END_BQ_QUEUE) {
- ASSERT(get_itbl(node)->type == RBH && get_itbl(bqe)->type == CONSTR);
- /*
- ASSERT((info_ptr==&RBH_Save_0_info) ||
- (info_ptr==&RBH_Save_1_info) ||
- (info_ptr==&RBH_Save_2_info));
- */
- /* cf. convertToRBH in RBH.c for writing the RBHSave closure */
- ((StgRBH *)node)->blocking_queue = (StgBlockingQueueElement *)((StgRBHSave *)bqe)->payload[0];
- ((StgRBH *)node)->mut_link = (StgMutClosure *)((StgRBHSave *)bqe)->payload[1];
-
- IF_GRAN_DEBUG(bq,
- debugBelch("## Filled in RBH_Save for %p (%s) at end of AwBQ\n",
- node, info_type(node)));
- }
-
- /* statistics gathering */
- if (RtsFlags.GranFlags.GranSimStats.Global) {
- // globalGranStats.tot_bq_processing_time += bq_processing_time;
- globalGranStats.tot_bq_len += len; // total length of all bqs awakened
- // globalGranStats.tot_bq_len_local += len_local; // same for local TSOs only
- globalGranStats.tot_awbq++; // total no. of bqs awakened
- }
- IF_GRAN_DEBUG(bq,
- debugBelch("## BQ Stats of %p: [%d entries] %s\n",
- node, len, (bqe!=END_BQ_QUEUE) ? "RBH" : ""));
-}
-#elif defined(PARALLEL_HASKELL)
-void
-awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
-{
- StgBlockingQueueElement *bqe;
-
- IF_PAR_DEBUG(verbose,
- debugBelch("##-_ AwBQ for node %p on [%x]: \n",
- node, mytid));
-#ifdef DIST
- //RFP
- if(get_itbl(q)->type == CONSTR || q==END_BQ_QUEUE) {
- IF_PAR_DEBUG(verbose, debugBelch("## ... nothing to unblock so lets just return. RFP (BUG?)\n"));
- return;
- }
-#endif
-
- ASSERT(q == END_BQ_QUEUE ||
- get_itbl(q)->type == TSO ||
- get_itbl(q)->type == BLOCKED_FETCH ||
- get_itbl(q)->type == CONSTR);
-
- bqe = q;
- while (get_itbl(bqe)->type==TSO ||
- get_itbl(bqe)->type==BLOCKED_FETCH) {
- bqe = unblockOne(bqe, node);
- }
-}
-
-#else /* !GRAN && !PARALLEL_HASKELL */
-
void
awakenBlockedQueue(Capability *cap, StgTSO *tso)
{
tso = unblockOne(cap,tso);
}
}
-#endif
-
/* ---------------------------------------------------------------------------
* rtsSupportsBoundThreads(): is the RTS built to support bound threads?
case NotBlocked:
debugBelch("is not blocked");
break;
-#if defined(PARALLEL_HASKELL)
- case BlockedOnGA:
- debugBelch("is blocked on global address; local FM_BQ is %p (%s)",
- tso->block_info.closure, info_type(tso->block_info.closure));
- break;
- case BlockedOnGA_NoSend:
- debugBelch("is blocked on global address (no send); local FM_BQ is %p (%s)",
- tso->block_info.closure, info_type(tso->block_info.closure));
- break;
-#endif
case BlockedOnCCall:
debugBelch("is blocked on an external call");
break;
debugBelch("%d threads on queue\n", i);
}
-/*
- Print a whole blocking queue attached to node (debugging only).
-*/
-# if defined(PARALLEL_HASKELL)
-void
-print_bq (StgClosure *node)
-{
- StgBlockingQueueElement *bqe;
- StgTSO *tso;
- rtsBool end;
-
- debugBelch("## BQ of closure %p (%s): ",
- node, info_type(node));
-
- /* should cover all closures that may have a blocking queue */
- ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
- get_itbl(node)->type == FETCH_ME_BQ ||
- get_itbl(node)->type == RBH ||
- get_itbl(node)->type == MVAR);
-
- ASSERT(node!=(StgClosure*)NULL); // sanity check
-
- print_bqe(((StgBlockingQueue*)node)->blocking_queue);
-}
-
-/*
- Print a whole blocking queue starting with the element bqe.
-*/
-void
-print_bqe (StgBlockingQueueElement *bqe)
-{
- rtsBool end;
-
- /*
- NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
- */
- for (end = (bqe==END_BQ_QUEUE);
- !end; // iterate until bqe points to a CONSTR
- end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE),
- bqe = end ? END_BQ_QUEUE : bqe->link) {
- ASSERT(bqe != END_BQ_QUEUE); // sanity check
- ASSERT(bqe != (StgBlockingQueueElement *)NULL); // sanity check
- /* types of closures that may appear in a blocking queue */
- ASSERT(get_itbl(bqe)->type == TSO ||
- get_itbl(bqe)->type == BLOCKED_FETCH ||
- get_itbl(bqe)->type == CONSTR);
- /* only BQs of an RBH end with an RBH_Save closure */
- //ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
-
- switch (get_itbl(bqe)->type) {
- case TSO:
- debugBelch(" TSO %u (%x),",
- ((StgTSO *)bqe)->id, ((StgTSO *)bqe));
- break;
- case BLOCKED_FETCH:
- debugBelch(" BF (node=%p, ga=((%x, %d, %x)),",
- ((StgBlockedFetch *)bqe)->node,
- ((StgBlockedFetch *)bqe)->ga.payload.gc.gtid,
- ((StgBlockedFetch *)bqe)->ga.payload.gc.slot,
- ((StgBlockedFetch *)bqe)->ga.weight);
- break;
- case CONSTR:
- debugBelch(" %s (IP %p),",
- (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
- get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
- get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
- "RBH_Save_?"), get_itbl(bqe));
- break;
- default:
- barf("Unexpected closure type %s in blocking queue", // of %p (%s)",
- info_type((StgClosure *)bqe)); // , node, info_type(node));
- break;
- }
- } /* for */
- debugBelch("\n");
-}
-# elif defined(GRAN)
-void
-print_bq (StgClosure *node)
-{
- StgBlockingQueueElement *bqe;
- PEs node_loc, tso_loc;
- rtsBool end;
-
- /* should cover all closures that may have a blocking queue */
- ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
- get_itbl(node)->type == FETCH_ME_BQ ||
- get_itbl(node)->type == RBH);
-
- ASSERT(node!=(StgClosure*)NULL); // sanity check
- node_loc = where_is(node);
-
- debugBelch("## BQ of closure %p (%s) on [PE %d]: ",
- node, info_type(node), node_loc);
-
- /*
- NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
- */
- for (bqe = ((StgBlockingQueue*)node)->blocking_queue, end = (bqe==END_BQ_QUEUE);
- !end; // iterate until bqe points to a CONSTR
- end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE), bqe = end ? END_BQ_QUEUE : bqe->link) {
- ASSERT(bqe != END_BQ_QUEUE); // sanity check
- ASSERT(bqe != (StgBlockingQueueElement *)NULL); // sanity check
- /* types of closures that may appear in a blocking queue */
- ASSERT(get_itbl(bqe)->type == TSO ||
- get_itbl(bqe)->type == CONSTR);
- /* only BQs of an RBH end with an RBH_Save closure */
- ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
-
- tso_loc = where_is((StgClosure *)bqe);
- switch (get_itbl(bqe)->type) {
- case TSO:
- debugBelch(" TSO %d (%p) on [PE %d],",
- ((StgTSO *)bqe)->id, (StgTSO *)bqe, tso_loc);
- break;
- case CONSTR:
- debugBelch(" %s (IP %p),",
- (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
- get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
- get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
- "RBH_Save_?"), get_itbl(bqe));
- break;
- default:
- barf("Unexpected closure type %s in blocking queue of %p (%s)",
- info_type((StgClosure *)bqe), node, info_type(node));
- break;
- }
- } /* for */
- debugBelch("\n");
-}
-# endif
-
-#if defined(PARALLEL_HASKELL)
-nat
-run_queue_len(void)
-{
- nat i;
- StgTSO *tso;
-
- for (i=0, tso=run_queue_hd;
- tso != END_TSO_QUEUE;
- i++, tso=tso->link) {
- /* nothing */
- }
-
- return i;
-}
-#endif
-
#endif /* DEBUG */
#ifndef THREADS_H
#define THREADS_H
-#if defined(GRAN) || defined(PARALLEL_HASKELL)
-StgBlockingQueueElement * unblockOne (StgBlockingQueueElement *bqe,
- StgClosure *node);
-#else
StgTSO * unblockOne (Capability *cap, StgTSO *tso);
StgTSO * unblockOne_ (Capability *cap, StgTSO *tso, rtsBool allow_migrate);
-#endif
-#if defined(GRAN) || defined(PARALLEL_HASKELL)
-void awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node);
-#else
void awakenBlockedQueue (Capability *cap, StgTSO *tso);
-#endif
void removeThreadFromMVarQueue (Capability *cap, StgMVar *mvar, StgTSO *tso);
void removeThreadFromQueue (Capability *cap, StgTSO **queue, StgTSO *tso);
unsigned long tot_allocs = /* total number of things allocated */
ALLOC_FUN_ctr + ALLOC_SE_THK_ctr + ALLOC_UP_THK_ctr + ALLOC_CON_ctr + ALLOC_TUP_ctr +
+ ALLOC_TSO_ctr + ALLOC_BH_ctr + ALLOC_PAP_ctr + ALLOC_PRIM_ctr
-#ifdef PAR
- + ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr
-#endif
;
unsigned long tot_adm_wds = /* total number of admin words allocated */
ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm
+ ALLOC_TSO_adm + ALLOC_BH_adm + ALLOC_PAP_adm + ALLOC_PRIM_adm
-#ifdef PAR
- + ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm
-#endif
;
unsigned long tot_gds_wds = /* total number of words of ``good stuff'' allocated */
ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds
+ ALLOC_TSO_gds + ALLOC_BH_gds + ALLOC_PAP_gds + ALLOC_PRIM_gds
-#ifdef PAR
- + ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds
-#endif
;
unsigned long tot_slp_wds = /* total number of ``slop'' words allocated */
ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp
+ ALLOC_TSO_slp + ALLOC_BH_slp + ALLOC_PAP_slp + ALLOC_PRIM_slp
-#ifdef PAR
- + ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp
-#endif
;
unsigned long tot_wds = /* total words */
PC(INTAVG(ALLOC_TSO_ctr, tot_allocs)));
if (ALLOC_TSO_ctr != 0)
fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TSO));
-#ifdef PAR
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_FMBQ_ctr,
- PC(INTAVG(ALLOC_FMBQ_ctr, tot_allocs)));
- if (ALLOC_FMBQ_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FMBQ));
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_FME_ctr,
- PC(INTAVG(ALLOC_FME_ctr, tot_allocs)));
- if (ALLOC_FME_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FME));
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_BF_ctr,
- PC(INTAVG(ALLOC_BF_ctr, tot_allocs)));
- if (ALLOC_BF_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BF));
-#endif
fprintf(tf,"\n");
PR_HST(ALLOC_TSO_hst,2);
PR_HST(ALLOC_TSO_hst,3);
PR_HST(ALLOC_TSO_hst,4);
-
-#ifdef PAR
- PR_CTR(ALLOC_FMBQ_ctr);
- PR_CTR(ALLOC_FMBQ_adm);
- PR_CTR(ALLOC_FMBQ_gds);
- PR_CTR(ALLOC_FMBQ_slp);
- PR_HST(ALLOC_FMBQ_hst,0);
- PR_HST(ALLOC_FMBQ_hst,1);
- PR_HST(ALLOC_FMBQ_hst,2);
- PR_HST(ALLOC_FMBQ_hst,3);
- PR_HST(ALLOC_FMBQ_hst,4);
- PR_CTR(ALLOC_FME_ctr);
- PR_CTR(ALLOC_FME_adm);
- PR_CTR(ALLOC_FME_gds);
- PR_CTR(ALLOC_FME_slp);
- PR_HST(ALLOC_FME_hst,0);
- PR_HST(ALLOC_FME_hst,1);
- PR_HST(ALLOC_FME_hst,2);
- PR_HST(ALLOC_FME_hst,3);
- PR_HST(ALLOC_FME_hst,4);
- PR_CTR(ALLOC_BF_ctr);
- PR_CTR(ALLOC_BF_adm);
- PR_CTR(ALLOC_BF_gds);
- PR_CTR(ALLOC_BF_slp);
- PR_HST(ALLOC_BF_hst,0);
- PR_HST(ALLOC_BF_hst,1);
- PR_HST(ALLOC_BF_hst,2);
- PR_HST(ALLOC_BF_hst,3);
- PR_HST(ALLOC_BF_hst,4);
-#endif
*/
PR_CTR(ENT_VIA_NODE_ctr);
DEBUG_FLAG(stm, DEBUG_stm);
DEBUG_FLAG(prof, DEBUG_prof);
DEBUG_FLAG(eventlog, DEBUG_eventlog);
- DEBUG_FLAG(gran, DEBUG_gran);
- DEBUG_FLAG(par, DEBUG_par);
DEBUG_FLAG(linker, DEBUG_linker);
DEBUG_FLAG(squeeze, DEBUG_squeeze);
DEBUG_FLAG(hpc, DEBUG_hpc);
Awaken any threads waiting on a blocking queue (BLACKHOLE_BQ).
-------------------------------------------------------------------------- */
-#if defined(PAR)
-
-/*
- In a parallel setup several types of closures might have a blocking queue:
- BLACKHOLE_BQ ... same as in the default concurrent setup; it will be
- reawakened via calling UPD_IND on that closure after
- having finished the computation of the graph
- FETCH_ME_BQ ... a global indirection (FETCH_ME) may be entered by a
- local TSO, turning it into a FETCH_ME_BQ; it will be
- reawakened via calling processResume
- RBH ... a revertible black hole may be entered by another
- local TSO, putting it onto its blocking queue; since
- RBHs only exist while the corresponding closure is in
- transit, they will be reawakened via calling
- convertToFetchMe (upon processing an ACK message)
-
- In a parallel setup a blocking queue may contain 3 types of closures:
- TSO ... as in the default concurrent setup
- BLOCKED_FETCH ... indicating that a TSO on another PE is waiting for
- the result of the current computation
- CONSTR ... an RBHSave closure (which contains data ripped out of
- the closure to make room for a blocking queue; since
- it only contains data we use the exisiting type of
- a CONSTR closure); this closure is the end of a
- blocking queue for an RBH closure; it only exists in
- this kind of blocking queue and must be at the end
- of the queue
-*/
-extern void awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node);
-#define DO_AWAKEN_BQ(bqe, node) STGCALL2(awakenBlockedQueue, bqe, node);
-
-#define AWAKEN_BQ(info,closure) \
- if (info == &stg_BLACKHOLE_BQ_info || \
- info == &stg_FETCH_ME_BQ_info || \
- get_itbl(closure)->type == RBH) { \
- DO_AWAKEN_BQ(((StgBlockingQueue *)closure)->blocking_queue, closure); \
- }
-
-#elif defined(GRAN)
-
-extern void awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node);
-#define DO_AWAKEN_BQ(bq, node) STGCALL2(awakenBlockedQueue, bq, node);
-
-/* In GranSim we don't have FETCH_ME or FETCH_ME_BQ closures, so they are
- not checked. The rest of the code is the same as for GUM.
-*/
-#define AWAKEN_BQ(info,closure) \
- if (info == &stg_BLACKHOLE_BQ_info || \
- get_itbl(closure)->type == RBH) { \
- DO_AWAKEN_BQ(((StgBlockingQueue *)closure)->blocking_queue, closure); \
- }
-
-#endif /* GRAN || PAR */
-
-
/* -----------------------------------------------------------------------------
Updates: lower-level macros which update a closure with an
indirection to another closure.
+++ /dev/null
-/* -----------------------------------------------------------------------------
- *
- * User-overridable RTS hooks.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Rts.h"
-
-#ifdef PAR
-void
-InitEachPEHook (void)
-{ /* In a GUM setup this is called on each
- PE immediately before SynchroniseSystem.
- It can be used to read in static data
- to each PE which has to be available to
- each PE. See GPH-Maple as an example how to
- use this in combination with foreign language
- code:
- http://www.risc.uni-linz.ac.at/software/ghc-maple/
- -- HWL
- */
-}
-#endif
+++ /dev/null
-/* -----------------------------------------------------------------------------
- *
- * User-overridable RTS hooks.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Rts.h"
-
-#ifdef PAR
-void
-ShutdownEachPEHook (void)
-{ /* In a GUM setup this routine is called at the end of
- shutdownParallelSystem on each PE. Useful for
- cleaning up stuff, especially when interfacing
- with foreign language code.
- -- HWL
- */
-}
-#endif
projects / ghc-hetmet.git / commitdiff