# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.72 2000/03/23 17:45:17 simonpj Exp $
+# $Id: Makefile,v 1.73 2000/03/31 03:09:35 hwloidl Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
rename/RnMonad_HC_OPTS =
specialise/Specialise_HC_OPTS = -Onot -H12m
simplCore/Simplify_HC_OPTS = -H15m
+simplCore/OccurAnal_HC_OPTS = -H10m
typecheck/TcGenDeriv_HC_OPTS = -H10m
# tmp, -- SDM
/* ----------------------------------------------------------------------------
- * $Id: Closures.h,v 1.16 2000/01/18 12:36:38 simonmar Exp $
+ * $Id: Closures.h,v 1.17 2000/03/31 03:09:35 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
StgMutClosure *mut_link;
} StgMutVar;
+/*
+ A collective typedef for all linkable stack frames i.e.
+ StgUpdateFrame, StgSeqFrame, StgCatchFrame
+*/
+typedef struct _StgFrame {
+ StgHeader header;
+ struct _StgFrame *link;
+} StgFrame;
+
typedef struct _StgUpdateFrame {
StgHeader header;
struct _StgUpdateFrame *link;
#if defined(PAR) || defined(GRAN)
/*
- StgBlockingQueueElement represents 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 (same as for StgMutClosures).
+ 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 (same as for
+ StgMutClosures).
+ 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;
- StgMutClosure *mut_link;
- struct StgClosure_ *payload[0];
+ struct StgBlockingQueueElement_ *link; /* next elem in BQ */
+ StgMutClosure *mut_link; /* next elem in mutable list */
+ struct StgClosure_ *payload[0];/* 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;
- StgMutClosure *mut_link;
+ struct StgBlockingQueueElement_ *blocking_queue; /* start of the BQ */
+ StgMutClosure *mut_link; /* next elem in mutable list */
} StgBlockingQueue;
-/* this closure is hanging at the end of a blocking queue in (par setup only) */
+/* this closure is hanging at the end of a blocking queue in (see RBH.c) */
typedef struct StgRBHSave_ {
StgHeader header;
- StgPtr payload[0];
-} StgRBHSave;
-
+ StgPtr payload[0]; /* 2 words ripped out of the guts of the */
+} StgRBHSave; /* closure holding the blocking queue */
+
typedef struct StgRBH_ {
- StgHeader header;
- struct StgBlockingQueueElement_ *blocking_queue;
- StgMutClosure *mut_link;
+ StgHeader header;
+ struct StgBlockingQueueElement_ *blocking_queue; /* start of the BQ */
+ StgMutClosure *mut_link; /* next elem in mutable list */
} StgRBH;
#else
/* global indirections aka FETCH_ME closures */
typedef struct StgFetchMe_ {
StgHeader header;
- globalAddr *ga; /* type globalAddr is abstract here */
- StgMutClosure *mut_link;
+ globalAddr *ga; /* ptr to unique id for a closure */
+ StgMutClosure *mut_link; /* next elem in mutable list */
} StgFetchMe;
/* same contents as an ordinary StgBlockingQueue */
typedef struct StgFetchMeBlockingQueue_ {
StgHeader header;
- struct StgBlockingQueueElement_ *blocking_queue;
- StgMutClosure *mut_link;
+ struct StgBlockingQueueElement_ *blocking_queue; /* start of the BQ */
+ StgMutClosure *mut_link; /* next elem in mutable list */
} StgFetchMeBlockingQueue;
-/* entry in a blocking queue, indicating a request from a TSO on another PE */
+/* 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;
- StgMutClosure *mut_link;
- StgClosure *node;
- globalAddr ga;
-} StgBlockedFetch;
+ struct StgBlockingQueueElement_ *link; /* next elem in the BQ */
+ StgMutClosure *mut_link; /* next elem in mutable list */
+ 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 */
/*
- Time-stamp: <Tue Jan 11 2000 11:29:41 Stardate: [-30]4188.43 hwloidl>
- $Id: GranSim.h,v 1.2 2000/01/13 14:34:00 hwloidl Exp $
+ Time-stamp: <Fri Mar 24 2000 23:55:42 Stardate: [-30]4554.98 hwloidl>
+ $Id: GranSim.h,v 1.3 2000/03/31 03:09:35 hwloidl Exp $
Headers for GranSim specific objects.
run_queue_hd to be relative to CurrentProc. The main arrays of runnable
and blocking queues are defined in Schedule.c. The important STG-called
GranSim macros (e.g. for fetching nodes) are at the end of this
- file. Usually they are just wrappers to proper C functions in GranSim.c. */
+ file. Usually they are just wrappers to proper C functions in GranSim.c.
+*/
#ifndef GRANSIM_H
#define GRANSIM_H
#if !defined(GRAN)
-//Dummy definitions for basic GranSim macros (see GranSim.h)
+/* Dummy definitions for basic GranSim macros called from STG land */
#define DO_GRAN_ALLOCATE(n) /* nothing */
#define DO_GRAN_UNALLOCATE(n) /* nothing */
#define DO_GRAN_FETCH(node) /* nothing */
#if defined(GRAN) /* whole file */
-extern StgTSO *CurrentTSOs[];
+extern StgTSO *CurrentTSO;
//@node Headers for GranSim specific objects, , ,
//@section Headers for GranSim specific objects
//@menu
-//* Includes::
//* Externs and prototypes::
//* Run and blocking queues::
//* Spark queues::
//* STG-called routines::
//@end menu
-//@node Includes, Externs and prototypes, Headers for GranSim specific objects, Headers for GranSim specific objects
-//@subsection Includes
-
-/*
-#include "Closures.h"
-#include "TSO.h"
-#include "Rts.h"
-*/
-
//@node Externs and prototypes, Run and blocking queues, Includes, Headers for GranSim specific objects
//@subsection Externs and prototypes
//@subsection Spark queues
/*
-In GranSim we use a double linked list to represent spark queues.
-
-This is more flexible, but slower, than the array of pointers
-representation used in GUM. We use the flexibility to define new fields in
-the rtsSpark structure, representing e.g. granularity info (see HWL's PhD
-thesis), or info about the parent of a spark.
+ In GranSim we use a double linked list to represent spark queues.
+
+ This is more flexible, but slower, than the array of pointers
+ representation used in GUM. We use the flexibility to define new fields in
+ the rtsSpark structure, representing e.g. granularity info (see HWL's PhD
+ thesis), or info about the parent of a spark.
*/
/* Sparks and spark queues */
typedef struct rtsSpark_
{
StgClosure *node;
- StgInt name, global;
- StgInt gran_info; /* for granularity improvement mechanisms */
+ nat name, global;
+ nat gran_info; /* for granularity improvement mechanisms */
PEs creator; /* PE that created this spark (unused) */
struct rtsSpark_ *prev, *next;
} rtsSpark;
/* Prototypes of those spark routines visible to compiler generated .hc */
/* Routines only used inside the RTS are defined in rts/parallel GranSimRts.h */
rtsSpark *newSpark(StgClosure *node,
- StgInt name, StgInt gran_info, StgInt size_info,
- StgInt par_info, StgInt local);
-void add_to_spark_queue(rtsSpark *spark);
+ nat name, nat gran_info, nat size_info,
+ nat par_info, nat local);
+// void add_to_spark_queue(rtsSpark *spark);
//@node Processor related stuff, GranSim costs, Spark queues, Headers for GranSim specific objects
//@subsection Processor related stuff
//#error MAX_PROC should be 32 on this architecture
//#endif
-#define CurrentTSO CurrentTSOs[CurrentProc]
+// #define CurrentTSO CurrentTSOs[CurrentProc]
/* Processor numbers to bitmasks and vice-versa */
#define MainProc 0 /* Id of main processor */
/* ----------------------------------------------------------------------------
- * $Id: InfoMacros.h,v 1.9 2000/01/13 14:34:00 hwloidl Exp $
+ * $Id: InfoMacros.h,v 1.10 2000/03/31 03:09:35 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif
/*
- On the GRAN/PAR specific parts of the InfoTables:
+ On the GranSim/GUM specific parts of the InfoTables (GRAN/PAR):
In both GranSim and GUM we use revertible black holes (RBH) when putting
an updatable closure into a packet for communication. The entry code for
prof_descr, prof_type) /* profiling info */ \
entry_class(RBH_##entry); \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info; \
+ ED_RO_ StgInfoTable info; \
info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
prof_descr, prof_type) \
entry_class(RBH_##entry); \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info; \
+ ED_RO_ StgInfoTable info; \
info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
layout : { bitmap : (StgWord32)bitmap_ }, \
SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
entry_class, prof_descr, prof_type) \
entry_class(RBH_##entry); \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info; \
+ ED_RO_ StgInfoTable info; \
info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
STD_INFO(RBH), \
entry_class, prof_descr, prof_type) \
entry_class(RBH_##entry); \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info; \
+ ED_RO_ StgInfoTable info; \
info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
layout : { selector_offset : offset }, \
STD_INFO(RBH), \
/*
- Time-stamp: <Fri Dec 10 1999 17:15:01 Stardate: [-30]4028.38 software>
+ Time-stamp: <Tue Mar 28 2000 23:50:54 Stardate: [-30]4574.76 hwloidl>
+ $Id: Parallel.h,v 1.3 2000/03/31 03:09:35 hwloidl Exp $
- Definitions for parallel machines.
+ Definitions for GUM i.e. running on a parallel machine.
This section contains definitions applicable only to programs compiled
to run on a parallel machine, i.e. on GUM. Some of these definitions
are also used when simulating parallel execution, i.e. on GranSim.
*/
-/*
- ToDo: Check the PAR specfic part of this file
- Move stuff into Closures.h and ClosureMacros.h
- Clean-up GRAN specific code
- -- HWL
-*/
-
#ifndef PARALLEL_H
#define PARALLEL_H
//@node Basic definitions, GUM, Parallel definitions, Parallel definitions
//@subsection Basic definitions
+/* This clashes with TICKY, but currently TICKY and PAR hate each other anyway */
+#define _HS sizeofW(StgHeader)
+
/* SET_PAR_HDR and SET_STATIC_PAR_HDR now live in ClosureMacros.h */
/* Needed for dumping routines */
# define NODE_STR_LEN 20
# define TIME_STR_LEN 120
# define TIME rtsTime
-# define CURRENT_TIME msTime()
-# define TIME_ON_PROC(p) msTime()
+# define CURRENT_TIME (msTime() - startTime)
+# define TIME_ON_PROC(p) (msTime() - startTime)
# define CURRENT_PROC thisPE
# define BINARY_STATS RtsFlags.ParFlags.ParStats.Binary
#elif defined(GRAN)
#if defined(PAR)
/*
-Symbolic constants for the packing code.
-
-This constant defines how many words of data we can pack into a single
-packet in the parallel (GUM) system.
+ Symbolic constants for the packing code.
+
+ This constant defines how many words of data we can pack into a single
+ packet in the parallel (GUM) system.
*/
//@menu
extern nat spark_limit[];
extern rtsPackBuffer *PackBuffer; /* size: can be set via option */
-extern rtsPackBuffer *buffer; /* HWL_ */
-extern rtsPackBuffer *freeBuffer; /* HWL_ */
-extern rtsPackBuffer *packBuffer; /* HWL_ */
+extern rtsPackBuffer *buffer;
+extern rtsPackBuffer *freeBuffer;
+extern rtsPackBuffer *packBuffer;
extern rtsPackBuffer *gumPackBuffer;
-extern int thisPE;
+extern nat thisPE;
-/* From Global.c */
+/* From Global.c
extern GALA *freeGALAList;
extern GALA *freeIndirections;
extern GALA *liveIndirections;
extern GALA *liveRemoteGAs;
-
-/*
-extern HashTable *taskIDtoPEtable;
-extern HashTable *LAtoGALAtable;
-extern HashTable *pGAtoGALAtable;
*/
//@node Prototypes, Macros, Externs, GUM
void RebuildLAGAtable (void);
StgWord PackGA (StgWord pe, int slot);
+# if defined(DEBUG)
+/* from Global.c */
+/* highest_slot breaks the abstraction of the slot counter for GAs; it is
+ only used for sanity checking and should used nowhere else */
+StgInt highest_slot (void);
+# endif
+
//@node Macros, , Prototypes, GUM
//@subsubsection Macros
// ToDo: check which of these is actually needed!
-# define PACK_HEAP_REQUIRED ((RtsFlags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (MIN_UPD_SIZE + 2))
+# define PACK_HEAP_REQUIRED ((RtsFlags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _HS) * (MIN_UPD_SIZE + 2))
# define MAX_GAS (RtsFlags.ParFlags.packBufferSize / PACK_GA_SIZE)
# define PACK_GA_SIZE 3 /* Size of a packed GA in words */
/* Size of a packed fetch-me in words */
-# define PACK_FETCHME_SIZE (PACK_GA_SIZE + FIXED_HS)
+# define PACK_FETCHME_SIZE (PACK_GA_SIZE + _HS)
# define PACK_HDR_SIZE 1 /* Words of header in a packet */
/* At the moment, there is no activity profiling for GUM. This may change. */
# define SET_TASK_ACTIVITY(act) /* nothing */
+/*
+ The following macros are only needed for sanity checking (see Sanity.c).
+*/
+
+/* NB: this is PVM specific and should be updated for MPI etc
+ in PVM a task id (tid) is split into 2 parts: the id for the
+ physical processor it is running on and an index of tasks running
+ on a processor; PVM_PE_MASK indicates which part of a tid holds the
+ id of the physical processor (the other part of the word holds the
+ index on that processor)
+ MAX_PVM_PES and MAX_PVM_TIDS are maximal values for these 2 components
+ in GUM we have an upper bound for the total number of PVM PEs allowed:
+ it's MAX_PE defined in Parallel.h
+ to check the slot field of a GA we call a fct highest_slot which just
+ returns the internal counter
+*/
+#define PVM_PE_MASK 0xfffc0000
+#define MAX_PVM_PES MAX_PES
+#define MAX_PVM_TIDS MAX_PES
+
+#if 0
+#define LOOKS_LIKE_TID(tid) (((tid & PVM_PE_MASK) != 0) && \
+ (((tid & PVM_PE_MASK) + (tid & ~PVM_PE_MASK)) < MAX_PVM_TIDS))
+#define LOOKS_LIKE_SLOT(slot) (slot<=highest_slot())
+
+#define LOOKS_LIKE_GA(ga) (LOOKS_LIKE_TID((ga)->payload.gc.gtid) && \
+ LOOKS_LIKE_SLOT((ga)->payload.gc.slot))
+#else
+rtsBool looks_like_tid(StgInt tid);
+rtsBool looks_like_slot(StgInt slot);
+rtsBool looks_like_ga(globalAddr *ga);
+#define LOOKS_LIKE_TID(tid) looks_like_tid(tid)
+#define LOOKS_LIKE_GA(ga) looks_like_ga(ga)
+#endif /* 0 */
+
#endif /* PAR */
//@node GranSim, , GUM, Parallel definitions
//@node Types, Prototypes, GranSim, GranSim
//@subsubsection Types
+typedef StgWord *StgBuffer;
typedef struct rtsPackBuffer_ {
StgInt /* nat */ id;
StgInt /* nat */ size;
StgInt /* nat */ unpacked_size;
StgTSO *tso;
- StgClosure **buffer;
+ StgBuffer *buffer;
} rtsPackBuffer;
-//@node Prototypes, Macros, Types, GranSim
-//@subsubsection Prototypes
-
-
-/* main packing functions */
-/*
-rtsPackBuffer *PackNearbyGraph(StgClosure* closure, StgTSO* tso, nat *packbuffersize);
-rtsPackBuffer *PackOneNode(StgClosure* closure, StgTSO* tso, nat *packbuffersize);
-void PrintPacket(rtsPackBuffer *buffer);
-StgClosure *UnpackGraph(rtsPackBuffer* buffer);
-*/
-/* important auxiliary functions */
-
-/*
-OLD CODE -- HWL
-void InitPackBuffer(void);
-P_ AllocateHeap (W_ size);
-P_ PackNearbyGraph (P_ closure, P_ tso, W_ *packbuffersize);
-P_ PackOneNode (P_ closure, P_ tso, W_ *packbuffersize);
-P_ UnpackGraph (P_ buffer);
-
-void InitClosureQueue (void);
-P_ DeQueueClosure(void);
-void QueueClosure (P_ closure);
-// rtsBool QueueEmpty();
-void PrintPacket (P_ buffer);
-*/
-
-// StgInfoTable *get_closure_info(StgClosure* node, unsigned int /* nat */ *size, unsigned int /* nat */ *ptrs, unsigned int /* nat */ *nonptrs, unsigned int /* nat */ *vhs, char *info_hdr_ty);
-// int /* rtsBool */ IS_BLACK_HOLE(StgClosure* node) ;
-
//@node Macros, , Prototypes, GranSim
//@subsubsection Macros
# define MAX_GAS (RtsFlags.GranFlags.packBufferSize / PACK_GA_SIZE)
# define PACK_GA_SIZE 3 /* Size of a packed GA in words */
/* Size of a packed fetch-me in words */
-# define PACK_FETCHME_SIZE (PACK_GA_SIZE + FIXED_HS)
+# define PACK_FETCHME_SIZE (PACK_GA_SIZE + _HS)
# define PACK_HDR_SIZE 4 /* Words of header in a packet */
# define PACK_HEAP_REQUIRED \
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.47 2000/03/17 12:40:03 simonmar Exp $
+ * $Id: PrimOps.h,v 1.48 2000/03/31 03:09:35 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
A par in the Haskell code is ultimately translated to a parzh macro
(with a case wrapped around it to guarantee that the macro is actually
executed; see compiler/prelude/PrimOps.lhs)
+ In GUM and SMP we only add a pointer to the spark pool.
+ In GranSim we call an RTS fct, forwarding additional parameters which
+ supply info on granularity of the computation, size of the result value
+ and the degree of parallelism in the sparked expression.
---------------------------------------------------------------------- */
#if defined(GRAN)
-// hash coding changed from 2.10 to 4.00
-#define parzh(r,node) parZh(r,node)
-
-#define parZh(r,node) \
- PARZh(r,node,1,0,0,0,0,0)
+//@cindex _par_
+#define parzh(r,node) PAR(r,node,1,0,0,0,0,0)
+//@cindex _parAt_
#define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
- parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
+ parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
+//@cindex _parAtAbs_
#define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
- parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
+ parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
+//@cindex _parAtRel_
#define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
- parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
+ parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
+//@cindex _parAtForNow_
#define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
- parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
+ parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
-#define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
-{ \
- rtsSparkQ result; \
- if (closure_SHOULD_SPARK((StgClosure*)node)) { \
+#define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
+{ \
+ if (closure_SHOULD_SPARK((StgClosure*)node)) { \
rtsSparkQ result; \
- STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
- if (local==2) { /* special case for parAtAbs */ \
- STGCALL3(GranSimSparkAtAbs, result,(I_)where,identifier);\
- } else if (local==3) { /* special case for parAtRel */ \
- STGCALL3(GranSimSparkAtAbs, result,(I_)(CurrentProc+where),identifier); \
- } else { \
- STGCALL3(GranSimSparkAt, result,where,identifier); \
- } \
- } \
+ PEs p; \
+ \
+ STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
+ switch (local) { \
+ case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
+ break; \
+ case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
+ break; \
+ default: p = where_is(where); /* parAt means closure expected */ \
+ break; \
+ } \
+ /* update GranSim state according to this spark */ \
+ STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
+ } \
}
+//@cindex _parLocal_
#define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
- PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
+ PAR(r,node,rest,identifier,gran_info,size_info,par_info,1)
+//@cindex _parGlobal_
#define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
- PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
+ PAR(r,node,rest,identifier,gran_info,size_info,par_info,0)
-#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
+#define PAR(r,node,rest,identifier,gran_info,size_info,par_info,local) \
{ \
if (closure_SHOULD_SPARK((StgClosure*)node)) { \
rtsSpark *result; \
#define noFollowzh(r,node) \
/* noFollow not yet implemented!! */
-#endif /* GRAN */
+#elif defined(SMP) || defined(PAR)
-#if defined(SMP) || defined(PAR)
#define parzh(r,node) \
{ \
extern unsigned int context_switch; \
} \
r = context_switch = 1; \
}
-#else
+#else /* !GRAN && !SMP && !PAR */
#define parzh(r,node) r = 1
#endif
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.10 2000/03/30 12:03:31 simonmar Exp $
+ * $Id: RtsAPI.h,v 1.11 2000/03/31 03:09:35 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
SchedulerStatus
rts_evalLazyIO ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
+#if defined(PAR) || defined(SMP)
+SchedulerStatus
+rts_evalNothing(unsigned int stack_size);
+#endif
+
void
rts_checkSchedStatus ( char* site, SchedulerStatus rc);
/* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.14 2000/03/20 09:42:49 andy Exp $
+ * $Id: TSO.h,v 1.15 2000/03/31 03:09:35 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#define TSO_H
#if defined(GRAN) || defined(PAR)
+
+#if DEBUG // && PARANOIA_LEVEL>999
// magic marker for TSOs; debugging only
#define TSO_MAGIC 4321
+#endif
typedef struct {
StgInt pri;
BlockedOnWrite,
BlockedOnDelay
#if defined(PAR)
- , BlockedOnGA // blocked on a remote closure represented by a Global Address
+ , BlockedOnGA // blocked on a remote closure represented by a Global Address
+ , BlockedOnGA_NoSend // same as above but without sending a Fetch message
#endif
} StgTSOBlockReason;
#else
unsigned int delay;
#endif
-#if defined(PAR)
- globalAddr ga;
-#endif
} StgTSOBlockInfo;
/*
(a) smaller than a block, or
(b) a multiple of BLOCK_SIZE
- tso->block_reason tso->block_info location
+ tso->why_blocked tso->block_info location
----------------------------------------------------------------------
NotBlocked NULL runnable_queue, or running
BlockedOnRead NULL blocked_queue
BlockedOnWrite NULL blocked_queue
BlockedOnDelay NULL blocked_queue
+ BlockedOnGA closure TSO blocks on BQ of that closure
+ BlockedOnGA_NoSend closure TSO blocks on BQ of that closure
tso->link == END_TSO_QUEUE, if the thread is currently running.
(StgTSO *)tso if threads are currently awaiting delivery of
exceptions to this thread.
+ The 2 cases BlockedOnGA and BlockedOnGA_NoSend are needed in a GUM
+ setup only. They mark a TSO that has entered a FETCH_ME or
+ FETCH_ME_BQ closure, respectively; only the first TSO hitting the
+ closure will send a Fetch message.
+ Currently we have no separate code for blocking on an RBH; we use the
+ BlockedOnBlackHole case for that. -- HWL
+
---------------------------------------------------------------------------- */
/* Workaround for a bug/quirk in gcc on certain architectures.
isWritable _ = False
-#ifndef __PARALLEL_HASKELL__
-getBMode__ :: ForeignObj -> IO (BufferMode, Int)
-#else
-getBMode__ :: Addr -> IO (BufferMode, Int)
-#endif
+getBMode__ :: FILE_OBJECT -> IO (BufferMode, Int)
getBMode__ fo = do
rc <- getBufferMode fo -- ConcHask: SAFE, won't block
case (rc::Int) of
wantRWHandle "hConnectTo" hW $ \ hW_ ->
wantRWHandle "hConnectTo" hR $ \ hR_ -> do
setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
-#else
-#define FILE_OBJECT Addr
-#endif
-
\end{code}
As an extension, we also allow characters to be pushed back.
of IO:
\begin{code}
-#ifndef __PARALLEL_HASKELL__
-mayBlock :: ForeignObj -> IO Int -> IO Int
-#else
-mayBlock :: Addr -> IO Int -> IO Int
-#endif
-
+mayBlock :: FILE_OBJECT -> IO Int -> IO Int
mayBlock fo act = do
rc <- act
case rc of
| BlockWrite Int
| NoBlock Int
-mayBlockRead :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int
+mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
mayBlockRead fname handle fn = do
r <- wantReadableHandle fname handle $ \ handle_ -> do
let fo = haFO__ handle_
mayBlockRead fname handle fn
NoBlock c -> return c
-mayBlockWrite :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int
+mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
mayBlockWrite fname handle fn = do
r <- wantWriteableHandle fname handle $ \ handle_ -> do
let fo = haFO__ handle_
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-#ifndef __PARALLEL_HASKELL__
-
module PrelWeak where
import PrelGHC
import PrelIOBase
import PrelForeign
+#ifndef __PARALLEL_HASKELL__
+
data Weak v = Weak (Weak# v)
mkWeak :: k -- key
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.76 2000/03/30 16:07:53 simonmar Exp $
+ * $Id: GC.c,v 1.77 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team 1998-1999
*
#if defined(DEBUG) && defined(GRAN)
IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
- Now, Now))
+ Now, Now));
#endif
/* tell the stats department that we've started a GC */
#if defined(GRAN)
// ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
#endif
- IF_DEBUG(sanity, checkFreeListSanity());
+ IF_DEBUG(sanity, checkFreeListSanity());
/* Initialise the static object lists
*/
/* scavenge static objects */
if (major_gc && static_objects != END_OF_STATIC_LIST) {
+ IF_DEBUG(sanity,
+ checkStaticObjects());
scavenge_static();
}
/* revert dead CAFs and update enteredCAFs list */
revert_dead_CAFs();
+#if defined(PAR)
+ /* Reconstruct the Global Address tables used in GUM */
+ rebuildGAtables(major_gc);
+ IF_DEBUG(sanity, checkGlobalTSOList(rtsTrue/*check TSOs, too*/));
+ IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
+#endif
+
/* Set the maximum blocks for the oldest generation, based on twice
* the amount of live data now, adjusted to fit the maximum heap
* size if necessary.
*/
resetNurseries();
-#if defined(PAR)
- /* Reconstruct the Global Address tables used in GUM */
- RebuildGAtables(major_gc);
-#endif
-
/* start any pending finalizers */
scheduleFinalizers(old_weak_ptr_list);
* for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
*/
-#if 1 || !defined(PAR)
/* ignore closures in generations that we're not collecting. */
- /* In GUM we use this routine when rebuilding GA tables; for some
- reason it has problems with the LOOKS_LIKE_STATIC macro -- HWL */
if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
return p;
}
-#endif
switch (info->type) {
StgClosure *
MarkRoot(StgClosure *root)
{
+# if 0 && defined(PAR) && defined(DEBUG)
+ StgClosure *foo = evacuate(root);
+ // ASSERT(closure_STATIC(foo) || maybeLarge(foo) || Bdescr(foo)->evacuated);
+ ASSERT(isAlive(foo)); // must be in to-space
+ return foo;
+# else
return evacuate(root);
+# endif
}
//@cindex addBlock
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
if ( tso->why_blocked == BlockedOnMVar
|| tso->why_blocked == BlockedOnBlackHole
- || tso->why_blocked == BlockedOnException) {
+ || tso->why_blocked == BlockedOnException
+#if defined(PAR)
+ || tso->why_blocked == BlockedOnGA
+ || tso->why_blocked == BlockedOnGA_NoSend
+#endif
+ ) {
tso->block_info.closure = evacuate(tso->block_info.closure);
}
if ( tso->blocked_exceptions != NULL ) {
#endif
case EVACUATED:
- barf("scavenge: unimplemented/strange closure type\n");
+ barf("scavenge: unimplemented/strange closure type %d @ %p",
+ info->type, p);
default:
- barf("scavenge");
+ barf("scavenge: unimplemented/strange closure type %d @ %p",
+ info->type, p);
}
/* If we didn't manage to promote all the objects pointed to by
break;
default:
- barf("scavenge_one: strange object");
+ barf("scavenge_one: strange object %d", (int)(info->type));
}
no_luck = failed_to_evac;
{
StgPtr end, q;
- IF_DEBUG(gc,
- belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS_FROZEN %p; size: %#x ; next: %p",
- p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
-
end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
evac_gen = gen->no;
for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
{
StgPtr end, q;
- IF_DEBUG(gc,
- belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS %p; size: %#x ; next: %p",
- p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
-
end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
(StgClosure *)*q = evacuate((StgClosure *)*q);
* it from the mutable list if possible by promoting whatever it
* points to.
*/
- IF_DEBUG(gc,
- belch("@@ scavenge_mut_list: scavenging MUT_VAR %p; var: %p ; next: %p",
- p, ((StgMutVar *)p)->var, p->mut_link));
-
ASSERT(p->header.info != &MUT_CONS_info);
((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
p->mut_link = gen->mut_list;
case MVAR:
{
StgMVar *mvar = (StgMVar *)p;
-
- IF_DEBUG(gc,
- belch("@@ scavenge_mut_list: scavenging MAVR %p; head: %p; tail: %p; value: %p ; next: %p",
- mvar, mvar->head, mvar->tail, mvar->value, p->mut_link));
-
(StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
(StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
(StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
case BLACKHOLE_BQ:
{
StgBlockingQueue *bh = (StgBlockingQueue *)p;
-
- IF_DEBUG(gc,
- belch("@@ scavenge_mut_list: scavenging BLACKHOLE_BQ (%p); next: %p",
- p, p->mut_link));
-
(StgClosure *)bh->blocking_queue =
evacuate((StgClosure *)bh->blocking_queue);
p->mut_link = gen->mut_list;
}
continue;
- // HWL: old PAR code deleted here
+#if defined(PAR)
+ // HWL: check whether all of these are necessary
+
+ case RBH: // cf. BLACKHOLE_BQ
+ {
+ // nat size, ptrs, nonptrs, vhs;
+ // char str[80];
+ // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
+ StgRBH *rbh = (StgRBH *)p;
+ (StgClosure *)rbh->blocking_queue =
+ evacuate((StgClosure *)rbh->blocking_queue);
+ if (failed_to_evac) {
+ failed_to_evac = rtsFalse;
+ recordMutable((StgMutClosure *)rbh);
+ }
+ // ToDo: use size of reverted closure here!
+ p += BLACKHOLE_sizeW();
+ break;
+ }
+
+ case BLOCKED_FETCH:
+ {
+ StgBlockedFetch *bf = (StgBlockedFetch *)p;
+ /* follow the pointer to the node which is being demanded */
+ (StgClosure *)bf->node =
+ evacuate((StgClosure *)bf->node);
+ /* follow the link to the rest of the blocking queue */
+ (StgClosure *)bf->link =
+ evacuate((StgClosure *)bf->link);
+ if (failed_to_evac) {
+ failed_to_evac = rtsFalse;
+ recordMutable((StgMutClosure *)bf);
+ }
+ p += sizeofW(StgBlockedFetch);
+ break;
+ }
+
+ case FETCH_ME:
+ p += sizeofW(StgFetchMe);
+ break; // nothing to do in this case
+
+ case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
+ {
+ StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
+ (StgClosure *)fmbq->blocking_queue =
+ evacuate((StgClosure *)fmbq->blocking_queue);
+ if (failed_to_evac) {
+ failed_to_evac = rtsFalse;
+ recordMutable((StgMutClosure *)fmbq);
+ }
+ p += sizeofW(StgFetchMeBlockingQueue);
+ break;
+ }
+#endif
default:
/* shouldn't have anything else on the mutables list */
}
default:
- barf("scavenge_static");
+ barf("scavenge_static: strange closure %d", (int)(info->type));
}
ASSERT(failed_to_evac == rtsFalse);
- /* get the next static object from the list. Remeber, there might
+ /* get the next static object from the list. Remember, there might
* be more stuff on this list now that we've done some evacuating!
* (static_objects is a global)
*/
}
default:
- barf("scavenge_stack: weird activation record found on stack.\n");
+ barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
}
}
}
}
default:
- barf("scavenge_large: unknown/strange object");
+ barf("scavenge_large: unknown/strange object %d", (int)(info->type));
}
}
}
* turned on.
* -------------------------------------------------------------------------- */
//@cindex threadPaused
-
void
threadPaused(StgTSO *tso)
{
{
StgMutClosure *p, *next;
- p = gen->saved_mut_list;
+ p = gen->mut_list;
next = p->mut_link;
- fprintf(stderr, "@@ Mutable list %p: ", gen->saved_mut_list);
+ fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
fprintf(stderr, "%p (%s), ",
p, info_type((StgClosure *)p));
}
fputc('\n', stderr);
}
+
+//@cindex maybeLarge
+static inline rtsBool
+maybeLarge(StgClosure *closure)
+{
+ StgInfoTable *info = get_itbl(closure);
+
+ /* closure types that may be found on the new_large_objects list;
+ see scavenge_large */
+ return (info->type == MUT_ARR_PTRS ||
+ info->type == MUT_ARR_PTRS_FROZEN ||
+ info->type == TSO ||
+ info->type == ARR_WORDS ||
+ info->type == BCO);
+}
+
+
#endif /* DEBUG */
//@node Index, , Pausing a thread
//* evacuate_large:: @cindex\s-+evacuate_large
//* gcCAFs:: @cindex\s-+gcCAFs
//* isAlive:: @cindex\s-+isAlive
+//* maybeLarge:: @cindex\s-+maybeLarge
//* mkMutCons:: @cindex\s-+mkMutCons
+//* printMutOnceList:: @cindex\s-+printMutOnceList
+//* printMutableList:: @cindex\s-+printMutableList
//* relocate_TSO:: @cindex\s-+relocate_TSO
//* revert_dead_CAFs:: @cindex\s-+revert_dead_CAFs
//* scavenge:: @cindex\s-+scavenge
/* -----------------------------------------------------------------------------
- * $Id: HeapStackCheck.hc,v 1.13 2000/03/17 13:30:24 simonmar Exp $
+ * $Id: HeapStackCheck.hc,v 1.14 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
R1.i = ThreadBlocked; \
JMP_(StgReturn);
+
/* -----------------------------------------------------------------------------
Heap Checks
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.19 2000/03/30 12:03:30 simonmar Exp $
+ * $Id: Main.c,v 1.20 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team 1998-2000
*
# if defined(PAR)
-# if DEBUG
+# if defined(DEBUG)
{ /* a wait loop to allow attachment of gdb to UNIX threads */
nat i, j, s;
fprintf(stderr, "Main Thread Started ...\n");
/* ToDo: Dump event for the main thread */
- status = rts_evalIO(mainIO_closure, NULL);
+ status = rts_evalIO((HaskellObj)mainIO_closure, NULL);
} else {
/* Just to show we're alive */
IF_PAR_DEBUG(verbose,
- fprintf(stderr, "== [%x] Non-Main PE enters scheduler without work ...\n",
+ fprintf(stderr, "== [%x] Non-Main PE enters scheduler via taskStart() without work ...\n",
mytid));
/* all non-main threads enter the scheduler without work */
- status = schedule( /* nothing */ );
+ status = rts_evalNothing((StgClosure*)NULL);
}
# elif defined(GRAN)
# else /* !PAR && !GRAN */
/* ToDo: want to start with a larger stack size */
- status = rts_evalIO((StgClosure *)mainIO_closure, NULL);
+ status = rts_evalIO(mainIO_closure, NULL);
# endif /* !PAR && !GRAN */
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.22 2000/03/17 14:37:21 simonmar Exp $
+ * $Id: Printer.c,v 1.23 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1994-2000.
*
fprintf(stderr,")\n");
break;
+ case TSO:
+ fprintf(stderr,"TSO(");
+ fprintf(stderr,"%d (%x)",
+ stgCast(StgTSO*,obj)->id, stgCast(StgTSO*,obj));
+ fprintf(stderr,")\n");
+ break;
+
+#if defined(PAR)
+ case BLOCKED_FETCH:
+ fprintf(stderr,"BLOCKED_FETCH(");
+ printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
+ printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
+ fprintf(stderr,")\n");
+ break;
+
+ case FETCH_ME:
+ fprintf(stderr,"FETCH_ME(");
+ printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
+ fprintf(stderr,")\n");
+ break;
+
+ case FETCH_ME_BQ:
+ fprintf(stderr,"FETCH_ME_BQ(");
+ // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
+ printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
+ fprintf(stderr,")\n");
+ break;
+#endif
#if defined(GRAN) || defined(PAR)
case RBH:
fprintf(stderr,"RBH(");
printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
fprintf(stderr,")\n");
break;
+
#endif
case CONSTR:
/* ToDo: will this work for THUNK_STATIC too? */
printStdObject(obj,"THUNK");
break;
-#if 0
+
+ case THUNK_SELECTOR:
+ printStdObject(obj,"THUNK_SELECTOR");
+ break;
+
case ARR_WORDS:
{
StgWord i;
fprintf(stderr,"ARR_WORDS(\"");
- /* ToDo: we can't safely assume that this is a string! */
+ /* ToDo: we can't safely assume that this is a string!
for (i = 0; arrWordsGetChar(obj,i); ++i) {
putchar(arrWordsGetChar(obj,i));
- }
+ } */
+ for (i=0; i<((StgArrWords *)obj)->words; i++)
+ fprintf(stderr, "%d", ((StgArrWords *)obj)->payload[i]);
fprintf(stderr,"\")\n");
break;
}
-#endif
+
case UPDATE_FRAME:
{
StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
"STABLE_NAME", /* 58 */
"TSO", /* 59 */
"BLOCKED_FETCH", /* 60 */
- "FETCH_ME", /* 61 */
- "EVACUATED", /* 62 */
- "N_CLOSURE_TYPES", /* 63 */
- "FETCH_ME_BQ", /* 64 */
- "RBH" /* 65 */
+ "FETCH_ME", /* 61 */
+ "FETCH_ME_BQ", /* 62 */
+ "RBH", /* 63 */
+ "EVACUATED", /* 64 */
+ "N_CLOSURE_TYPES" /* 65 */
};
char *
/* Causing linking trouble on Win32 plats, so I'm
disabling this for now.
*/
-#if defined(HAVE_BFD_H) && !defined(_WIN32)
+/* For now, BFD support is unconditionally disabled -- HWL */
+#if 0 /* HWL */ && defined(HAVE_BFD_H) && !defined(_WIN32)
#include <bfd.h>
/* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.8 2000/03/23 16:01:16 simonmar Exp $
+ * $Id: ProfHeap.c,v 1.9 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
clear_table_data();
break;
case HEAP_BY_CLOSURE_TYPE:
+#if 0
+# error fix me
memset(closure_types, 0, N_CLOSURE_TYPES * sizeof(nat));
+#endif
break;
default:
return;
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.12 2000/03/14 09:55:05 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.13 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
return waitThread(tso, ret);
}
+#if defined(PAR) || defined(SMP)
+/*
+ Needed in the parallel world for non-Main PEs, which do not get a piece
+ of work to start with --- they have to humbly ask for it
+*/
+
+SchedulerStatus
+rts_evalNothing(unsigned int stack_size)
+{
+ /* ToDo: propagate real SchedulerStatus back to caller */
+ scheduleThread(END_TSO_QUEUE);
+ return Success;
+}
+#endif
+
/* Convenience function for decoding the returned status. */
void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.27 2000/03/08 17:48:24 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.28 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
#define RTS 1
#define PGM 0
+char *debug_opts_strs[] = {
+ "DEBUG (-D1): scheduler\n",
+ "DEBUG (-D2): evaluator\n",
+ "DEBUG (-D4): codegen\n",
+ "DEBUG (-D8): weak\n",
+ "DEBUG (-D16): gccafs\n",
+ "DEBUG (-D32): gc\n",
+ "DEBUG (-D64): block\n",
+ "DEBUG (-D128): sanity\n",
+ "DEBUG (-D256): stable\n",
+ "DEBUG (-D512): prof\n",
+ "DEBUG (-D1024): gran\n",
+ "DEBUG (-D2048): par\n"
+};
+
+char *debug_opts_prefix[] = {
+ "_-", /* scheduler */
+ "_.", /* evaluator */
+ "_,", /* codegen */
+ "_;", /* weak */
+ "_~", /* gccafs */
+ "_@", /* gc */
+ "_#", /* block */
+ "_&", /* sanity */
+ "_:", /* stable */
+ "_!", /* prof */
+ "_=", /* gran */
+ "_=" /* par */
+};
+
#if defined(GRAN)
char *gran_debug_opts_strs[] = {
"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 for GC.\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, -qD256): fish; fish messages.\n",
- "DEBUG (-qDo, -qD512): forward; forwarding messages to other PEs.\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"
};
/* one character codes for the available debug options */
char par_debug_opts_flags[] = {
- 'v', 't', 's', 'e', 'r', 'w', 'F', 'a', 'f', 'o', 'p'
+ 'v', 't', 's', 'e', 'r', 'w', 'F', 'f', 'l', 'o', 'p'
};
/* prefix strings printed with the debug messages of the corresponding type */
"[]", /* resume */
";;", /* weight */
"%%", /* fetch */
- ",,", /* ack */
+ //",,", /* ack */
"$$", /* fish */
- "", /* forward */
+ "", /* tables */
+ "**", /* packet */
"**" /* pack */
};
static void set_par_debug_options(nat n);
static void help_par_debug_options(nat n);
#endif
+static void set_debug_options(nat n);
+static void help_debug_options(nat n);
//@node Command-line option parsing routines, GranSim specific options, Static function decls
//@subsection Command-line option parsing routines
#if defined(GRAN)
/* ToDo: check defaults for GranSim and GUM */
RtsFlags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
- RtsFlags.ConcFlags.maxThreads = 65536; // refers to mandatory threads
RtsFlags.GcFlags.maxStkSize = (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;
#ifdef DEBUG
case 'D':
- /* hack warning: interpret the flags as a binary number */
- {
- I_ n = decode(rts_argv[arg]+2);
- if (n &1) RtsFlags.DebugFlags.scheduler = rtsTrue;
- if ((n>>1)&1) RtsFlags.DebugFlags.evaluator = rtsTrue;
- if ((n>>2)&1) RtsFlags.DebugFlags.codegen = rtsTrue;
- if ((n>>3)&1) RtsFlags.DebugFlags.weak = rtsTrue;
- if ((n>>4)&1) RtsFlags.DebugFlags.gccafs = rtsTrue;
- if ((n>>5)&1) RtsFlags.DebugFlags.gc = rtsTrue;
- if ((n>>6)&1) RtsFlags.DebugFlags.block_alloc = rtsTrue;
- if ((n>>7)&1) RtsFlags.DebugFlags.sanity = rtsTrue;
- if ((n>>8)&1) RtsFlags.DebugFlags.stable = rtsTrue;
- if ((n>>9)&1) RtsFlags.DebugFlags.prof = rtsTrue;
- if ((n>>10)&1) RtsFlags.DebugFlags.gran = rtsTrue;
- if ((n>>11)&1) RtsFlags.DebugFlags.par = rtsTrue;
- }
+ if (isdigit(rts_argv[arg][2])) {/* Set all debugging options in one */
+ /* hack warning: interpret the flags as a binary number */
+ nat n = decode(rts_argv[arg]+2);
+ set_debug_options(n);
+ }
break;
#endif
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 8: RtsFlags.ParFlags.Debug.fish = rtsTrue; break;
- case 9: RtsFlags.ParFlags.Debug.forward = 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;
default: barf("set_par_debug_options: only %d debug options expected");
} /* switch */
#endif /* GRAN */
+static void
+set_debug_options(nat n) {
+ nat i;
+
+ for (i=0; i<=MAX_DEBUG_OPTION; i++)
+ if ((n>>i)&1) {
+ fprintf(stderr, debug_opts_strs[i]);
+ switch (i) {
+ case 0: RtsFlags.DebugFlags.scheduler = rtsTrue; break;
+ case 1: RtsFlags.DebugFlags.evaluator = rtsTrue; break;
+ case 2: RtsFlags.DebugFlags.codegen = rtsTrue; break;
+ case 3: RtsFlags.DebugFlags.weak = rtsTrue; break;
+ case 4: RtsFlags.DebugFlags.gccafs = rtsTrue; break;
+ case 5: RtsFlags.DebugFlags.gc = rtsTrue; break;
+ case 6: RtsFlags.DebugFlags.block_alloc = rtsTrue; break;
+ case 7: RtsFlags.DebugFlags.sanity = rtsTrue; break;
+ case 8: RtsFlags.DebugFlags.stable = rtsTrue; break;
+ case 9: RtsFlags.DebugFlags.prof = rtsTrue; break;
+ case 10: RtsFlags.DebugFlags.gran = rtsTrue; break;
+ case 11: RtsFlags.DebugFlags.par = rtsTrue; break;
+ } /* switch */
+ } /* if */
+}
+
+static void
+help_debug_options(nat n) {
+ nat i;
+
+ for (i=0; i<=MAX_DEBUG_OPTION; i++)
+ if ((n>>i)&1)
+ fprintf(stderr, debug_opts_strs[i]);
+}
+
//@node Aux fcts, , GranSim specific options
//@subsection Aux fcts
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.22 2000/03/08 17:48:24 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.23 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
rtsBool par : 1; /* 2048 */
};
+#define MAX_DEBUG_OPTION 11
+#define DEBUG_MASK(n) ((nat)(ldexp(1,n)))
+#define MAX_DEBUG_MASK ((nat)(ldexp(1,(MAX_DEBUG_OPTION+1))-1))
+
#if defined(PROFILING) || defined(PAR)
/* with PROFILING, full cost-centre stuff (also PROFILING_FLAGS);
with PAR, just the four fixed cost-centres.
rtsBool resume : 1; /* 16 */
rtsBool weight : 1; /* 32 */
rtsBool fetch : 1; /* 64 */
- rtsBool ack : 1; /* 128 */
- rtsBool fish : 1; /* 256 */
- rtsBool forward : 1; /* 512 */
+ rtsBool fish : 1; /* 128 */
+ rtsBool tables : 1; /* 256 */
+ rtsBool packet : 1; /* 512 */
rtsBool pack : 1; /* 1024 */
};
struct GRAN_COST_FLAGS Costs; /* cost metric for simulation */
struct GRAN_DEBUG_FLAGS Debug; /* debugging options */
+ nat maxThreads; // ToDo: share with SMP and GUM
// rtsBool labelling;
nat packBufferSize;
nat packBufferSize_internal;
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.36 2000/03/30 12:03:30 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.37 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
resetNonBlockingFd(1);
resetNonBlockingFd(2);
+#if defined(PAR)
+ shutdownParallelSystem(0);
+#endif
+
/* stop timing the shutdown, we're about to print stats */
stat_endExit();
rts_has_started_up=0;
-#if defined(PAR)
- shutdownParallelSystem(0);
-#endif
-
}
/*
/* -----------------------------------------------------------------------------
- * $Id: RtsUtils.c,v 1.13 2000/01/13 14:34:04 hwloidl Exp $
+ * $Id: RtsUtils.c,v 1.14 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif
}
-#if 0
static ullong startTime = 0;
/* used in a parallel setup */
return t * LL(1000) - startTime;
# endif
}
-#endif
-
/* -----------------------------------------------------------------------------
Print large numbers, with punctuation.
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.18 2000/03/17 14:37:21 simonmar Exp $
+ * $Id: Sanity.c,v 1.19 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "RtsUtils.h"
#include "BlockAlloc.h"
#include "Sanity.h"
+#include "StoragePriv.h" // for END_OF_STATIC_LIST
//@node Macros, Stack sanity, Includes
//@subsection Macros
-#define LOOKS_LIKE_PTR(r) (LOOKS_LIKE_STATIC_CLOSURE(r) || ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1)))
+#define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
+ ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
+ ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
//@node Stack sanity, Heap Sanity, Macros
//@subsection Stack sanity
return 1 + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
case UPDATE_FRAME:
+ ASSERT(LOOKS_LIKE_PTR(((StgUpdateFrame*)c)->updatee));
case CATCH_FRAME:
- case STOP_FRAME:
case SEQ_FRAME:
+ /* check that the link field points to another stack frame */
+ ASSERT(get_itbl(((StgFrame*)c)->link)->type == UPDATE_FRAME ||
+ get_itbl(((StgFrame*)c)->link)->type == CATCH_FRAME ||
+ get_itbl(((StgFrame*)c)->link)->type == STOP_FRAME ||
+ get_itbl(((StgFrame*)c)->link)->type == SEQ_FRAME);
+ /* fall through */
+ case STOP_FRAME:
#if defined(GRAN)
return 2 +
#else
ASSERT(LOOKS_LIKE_PTR(mvar->head));
ASSERT(LOOKS_LIKE_PTR(mvar->tail));
ASSERT(LOOKS_LIKE_PTR(mvar->value));
+#if 0
+#if defined(PAR)
+ checkBQ((StgBlockingQueueElement *)mvar->head, p);
+#else
+ checkBQ(mvar->head, p);
+#endif
+#endif
return sizeofW(StgMVar);
}
return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
}
+ case BLACKHOLE_BQ:
+ checkBQ(((StgBlockingQueue *)p)->blocking_queue, p);
+ /* fall through to basic ptr check */
case FUN:
case FUN_1_0:
case FUN_0_1:
case SE_BLACKHOLE:
#endif
case BLACKHOLE:
- case BLACKHOLE_BQ:
case FOREIGN:
case STABLE_NAME:
case MUT_VAR:
case CONSTR_NOCAF_STATIC:
case THUNK_STATIC:
case FUN_STATIC:
- case IND_STATIC:
{
nat i;
for (i = 0; i < info->layout.payload.ptrs; i++) {
return sizeW_fromITBL(info);
}
+ case IND_STATIC: /* (1, 0) closure */
+ ASSERT(LOOKS_LIKE_PTR(((StgIndStatic*)p)->indirectee));
+ return sizeW_fromITBL(info);
+
case WEAK:
/* deal with these specially - the info table isn't
* representative of the actual layout.
checkTSO((StgTSO *)p);
return tso_sizeW((StgTSO *)p);
+#if defined(PAR)
+
case BLOCKED_FETCH:
+ ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
+ ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
+ return sizeofW(StgBlockedFetch); // see size used in evacuate()
+
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_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
+ return BLACKHOLE_sizeW(); // see size used in evacuate()
+ // sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
+
+#endif
+
case EVACUATED:
- barf("checkClosure: unimplemented/strange closure type %d",
+ barf("checkClosure: found EVACUATED closure %d",
info->type);
default:
barf("checkClosure (closure type %d)", info->type);
}
-#undef LOOKS_LIKE_PTR
}
+#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
+
//@node Heap Sanity, TSO Sanity, Stack sanity
//@subsection Heap Sanity
checkHeap(bdescr *bd, StgPtr start)
{
StgPtr p;
+ nat xxx = 0; // tmp -- HWL
if (start == NULL) {
p = bd->start;
nat size = checkClosure(stgCast(StgClosure*,p));
/* This is the smallest size of closure that can live in the heap. */
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ if (get_itbl(stgCast(StgClosure*,p))->type == IND_STATIC)
+ xxx++;
p += size;
/* skip over slop */
p = bd->start;
}
}
+ fprintf(stderr,"@@@@ checkHeap: Heap ok; %d IND_STATIC closures checked\n",
+ xxx);
+}
+
+/*
+ Check heap between start and end. Used after unpacking graphs.
+*/
+extern void
+checkHeapChunk(StgPtr start, StgPtr end)
+{
+ StgPtr p;
+ nat size;
+
+ for (p=start; p<end; p+=size) {
+ ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
+ size = checkClosure(stgCast(StgClosure*,p));
+ /* This is the smallest size of closure that can live in the heap. */
+ ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ }
}
//@cindex checkChain
ASSERT(stack <= sp && sp < stack_end);
ASSERT(sp <= stgCast(StgPtr,su));
+#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(/* Can't be a BLACKHOLE because *this* closure is on its BQ */
+ get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
+ get_itbl(tso->block_info.closure)->type==RBH);
+ break;
+ case BlockedOnRead:
+ case BlockedOnWrite:
+ case BlockedOnDelay:
+ /* 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;
+ 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
+
checkStack(sp, stack_end, su);
}
}
#endif /* GRAN */
-//@node Blackhole Sanity, Index, Thread Queue Sanity
+/*
+ Check that all TSOs have been evacuated.
+ Optionally also check the sanity of the TSOs.
+*/
+void
+checkGlobalTSOList (rtsBool checkTSOs)
+{
+ extern StgTSO *all_threads;
+ StgTSO *tso;
+ for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
+ ASSERT(Bdescr((P_)tso)->evacuated == 1);
+ if (checkTSOs)
+ checkTSO(tso);
+ }
+}
+
+//@node Blackhole Sanity, GALA table sanity, Thread Queue Sanity
//@subsection Blackhole Sanity
/* -----------------------------------------------------------------------------
} while (1);
}
-//@node Index, , Blackhole Sanity
+/*
+ Check the static objects list.
+*/
+extern void
+checkStaticObjects ( void ) {
+ extern StgClosure* static_objects;
+ StgClosure *p = static_objects;
+ StgInfoTable *info;
+
+ while (p != END_OF_STATIC_LIST) {
+ checkClosure(p);
+ info = get_itbl(p);
+ switch (info->type) {
+ case IND_STATIC:
+ {
+ StgClosure *indirectee = stgCast(StgIndStatic*,p)->indirectee;
+
+ ASSERT(LOOKS_LIKE_PTR(indirectee));
+ ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
+ p = IND_STATIC_LINK((StgClosure *)p);
+ break;
+ }
+
+ case THUNK_STATIC:
+ p = THUNK_STATIC_LINK((StgClosure *)p);
+ break;
+
+ case FUN_STATIC:
+ p = FUN_STATIC_LINK((StgClosure *)p);
+ break;
+
+ case CONSTR_STATIC:
+ p = STATIC_LINK(info,(StgClosure *)p);
+ break;
+
+ default:
+ barf("checkStaticObjetcs: strange closure %p (%s)",
+ p, info_type(p));
+ }
+ }
+}
+
+/*
+ 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
+*/
+//@cindex checkBQ
+#if defined(PAR)
+void
+checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure)
+{
+ rtsBool end = rtsFalse;
+ StgInfoTable *info = get_itbl(closure);
+
+ ASSERT(info->type == BLACKHOLE_BQ || 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 == BLACKHOLE_BQ || 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);
+}
+#else
+void
+checkBQ (StgTSO *bqe, StgClosure *closure)
+{
+ rtsBool end = rtsFalse;
+ StgInfoTable *info = get_itbl(closure);
+
+ ASSERT(info->type == BLACKHOLE_BQ || info->type == MVAR);
+
+ do {
+ switch (get_itbl(bqe)->type) {
+ case TSO:
+ checkClosure((StgClosure *)bqe);
+ bqe = bqe->link;
+ end = (bqe==END_TSO_QUEUE);
+ break;
+
+ default:
+ barf("checkBQ: strange closure %d in blocking queue for closure %p\n",
+ get_itbl(bqe)->type, closure, info->type);
+ }
+ } while (!end);
+}
+
+#endif
+
+
+//@node GALA table sanity, Index, Blackhole Sanity
+//@subsection GALA table sanity
+
+/*
+ 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;
+
+//@cindex checkLAGAtable
+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_GHC_INFO(((StgClosure *)gala->la)->header.info));
+ ASSERT(gala->next!=gala); // detect direct loops
+ /*
+ if ( check_closures ) {
+ checkClosure(stgCast(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_GHC_INFO(((StgClosure *)gala->la)->header.info));
+ ASSERT(gala->next!=gala); // detect direct loops
+ /*
+ if ( check_closures ) {
+ checkClosure(stgCast(StgClosure*,gala->la));
+ }
+ */
+ }
+}
+#endif
+
+//@node Index, , GALA table sanity
//@subsection Index
+#endif /* DEBUG */
+
//@index
+//* checkBQ:: @cindex\s-+checkBQ
//* checkChain:: @cindex\s-+checkChain
//* checkClosureShallow:: @cindex\s-+checkClosureShallow
//* checkHeap:: @cindex\s-+checkHeap
//* checkThreadQsSanity:: @cindex\s-+checkThreadQsSanity
//* isBlackhole:: @cindex\s-+isBlackhole
//@end index
-
-#endif /* DEBUG */
-
/* -----------------------------------------------------------------------------
- * $Id: Sanity.h,v 1.5 2000/01/13 14:34:04 hwloidl Exp $
+ * $Id: Sanity.h,v 1.6 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void checkChain ( bdescr *bd );
extern void checkStack ( StgPtr sp, StgPtr stack_end, StgUpdateFrame* su );
extern void checkTSO ( StgTSO* tso );
+extern void checkGlobalTSOList (rtsBool checkTSOs);
+extern void checkStaticObjects ( void );
#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);
+extern void checkLAGAtable(rtsBool check_closures);
+extern void checkHeapChunk(StgPtr start, StgPtr end);
+#else
+extern void checkBQ (StgTSO *bqe, StgClosure *closure);
+#endif
extern StgOffset checkClosure( StgClosure* p );
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.59 2000/03/30 16:07:53 simonmar Exp $
+ * $Id: Schedule.c,v 1.60 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
//@menu
//* Includes::
//* Variables and Data structures::
-//* Prototypes::
//* Main scheduling loop::
//* Suspend and Resume::
//* Run queue code::
#include "Profiling.h"
#include "Sanity.h"
#include "Stats.h"
-#include "Sparks.h"
#include "Itimer.h"
#include "Prelude.h"
#if defined(GRAN) || defined(PAR)
# include "FetchMe.h"
# include "HLC.h"
#endif
+#include "Sparks.h"
#include <stdarg.h>
StgTSO *run_queue_hds[MAX_PROC], *run_queue_tls[MAX_PROC];
StgTSO *blocked_queue_hds[MAX_PROC], *blocked_queue_tls[MAX_PROC];
StgTSO *ccalling_threadss[MAX_PROC];
-StgTSO *all_threadss[MAX_PROC];
+/* We use the same global list of threads (all_threads) in GranSim as in
+ the std RTS (i.e. we are cheating). However, we don't use this list in
+ the GranSim specific code at the moment (so we are only potentially
+ cheating). */
#else /* !GRAN */
StgTSO *run_queue_hd, *run_queue_tl;
StgTSO *blocked_queue_hd, *blocked_queue_tl;
+#endif
+
/* Linked list of all threads.
* Used for detecting garbage collected threads.
*/
static void GetRoots(void);
static StgTSO *threadStackOverflow(StgTSO *tso);
-#endif
/* KH: The following two flags are shared memory locations. There is no need
to lock them, since they are only unset at the end of a scheduler
#endif
#if defined(GRAN)
-StgTSO *CurrentTSOs[MAX_PROC];
-#else
-StgTSO *CurrentTSO;
+StgTSO *CurrentTSO;
#endif
rtsBool ready_to_gc;
static void schedule ( void );
void interruptStgRts ( void );
+#if defined(GRAN)
+static StgTSO * createThread_ ( nat size, rtsBool have_lock, StgInt pri );
+#else
static StgTSO * createThread_ ( nat size, rtsBool have_lock );
+#endif
#ifdef DEBUG
static void sched_belch(char *s, ...);
rtsTime TimeOfLastYield;
#endif
+#if DEBUG
+char *whatNext_strs[] = {
+ "ThreadEnterGHC",
+ "ThreadRunGHC",
+ "ThreadEnterHugs",
+ "ThreadKilled",
+ "ThreadComplete"
+};
+
+char *threadReturnCode_strs[] = {
+ "HeapOverflow", /* might also be StackOverflow */
+ "StackOverflow",
+ "ThreadYielding",
+ "ThreadBlocked",
+ "ThreadFinished"
+};
+#endif
+
/*
* The thread state for the main thread.
// ToDo: check whether not needed any more
StgTSO *MainTSO;
*/
-
-//@node Prototypes, Main scheduling loop, Variables and Data structures, Main scheduling code
-//@subsection Prototypes
-
//@node Main scheduling loop, Suspend and Resume, Prototypes, Main scheduling code
//@subsection Main scheduling loop
* waiting for work, or
* waiting for a GC to complete.
+ GRAN version:
+ In a GranSim setup this loop iterates over the global event queue.
+ This revolves around the global event queue, which determines what
+ to do next. Therefore, it's more complicated than either the
+ concurrent or the parallel (GUM) setup.
+
+ GUM version:
+ GUM iterates over incoming messages.
+ It starts with nothing to do (thus CurrentTSO == END_TSO_QUEUE),
+ and sends out a fish whenever it has nothing to do; in-between
+ doing the actual reductions (shared code below) it processes the
+ incoming messages and deals with delayed operations
+ (see PendingFetches).
+ This is not the ugliest code you could imagine, but it's bloody close.
+
------------------------------------------------------------------------ */
//@cindex schedule
static void
#if defined(GRAN)
rtsEvent *event;
#elif defined(PAR)
+ StgSparkPool *pool;
rtsSpark spark;
StgTSO *tso;
GlobalTaskId pe;
ACQUIRE_LOCK(&sched_mutex);
#if defined(GRAN)
-# error ToDo: implement GranSim scheduler
+
+ /* set up first event to get things going */
+ /* ToDo: assign costs for system setup and init MainTSO ! */
+ new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
+ ContinueThread,
+ CurrentTSO, (StgClosure*)NULL, (rtsSpark*)NULL);
+
+ IF_DEBUG(gran,
+ fprintf(stderr, "GRAN: Init CurrentTSO (in schedule) = %p\n", CurrentTSO);
+ G_TSO(CurrentTSO, 5));
+
+ if (RtsFlags.GranFlags.Light) {
+ /* Save current time; GranSim Light only */
+ CurrentTSO->gran.clock = CurrentTime[CurrentProc];
+ }
+
+ event = get_next_event();
+
+ while (event!=(rtsEvent*)NULL) {
+ /* Choose the processor with the next event */
+ CurrentProc = event->proc;
+ CurrentTSO = event->tso;
+
#elif defined(PAR)
+
while (!GlobalStopPending) { /* GlobalStopPending set in par_exit */
- if (PendingFetches != END_BF_QUEUE) {
- processFetches();
- }
#else
+
while (1) {
+
#endif
IF_DEBUG(scheduler, printAllThreads());
}
}
}
+
#else
+# if defined(PAR)
+ /* in GUM do this only on the Main PE */
+ if (IAmMainThread)
+# endif
/* If our main thread has finished or been killed, return.
*/
{
main_threads = NULL;
}
#else /* ! SMP */
+ /*
+ In GUM all non-main PEs come in here with no work;
+ we ignore multiple main threads for now
+
if (blocked_queue_hd == END_TSO_QUEUE
&& run_queue_hd == END_TSO_QUEUE) {
StgMainThread *m = main_threads;
main_threads = m->link;
return;
}
+ */
#endif
#ifdef SMP
#endif
#if defined(GRAN)
-# error ToDo: implement GranSim scheduler
+
+ if (RtsFlags.GranFlags.Light)
+ GranSimLight_enter_system(event, &ActiveTSO); // adjust ActiveTSO etc
+
+ /* adjust time based on time-stamp */
+ if (event->time > CurrentTime[CurrentProc] &&
+ event->evttype != ContinueThread)
+ CurrentTime[CurrentProc] = event->time;
+
+ /* Deal with the idle PEs (may issue FindWork or MoveSpark events) */
+ if (!RtsFlags.GranFlags.Light)
+ handleIdlePEs();
+
+ IF_DEBUG(gran, fprintf(stderr, "GRAN: switch by event-type\n"))
+
+ /* main event dispatcher in GranSim */
+ switch (event->evttype) {
+ /* Should just be continuing execution */
+ case ContinueThread:
+ IF_DEBUG(gran, fprintf(stderr, "GRAN: doing ContinueThread\n"));
+ /* ToDo: check assertion
+ ASSERT(run_queue_hd != (StgTSO*)NULL &&
+ run_queue_hd != END_TSO_QUEUE);
+ */
+ /* Ignore ContinueThreads for fetching threads (if synchr comm) */
+ if (!RtsFlags.GranFlags.DoAsyncFetch &&
+ procStatus[CurrentProc]==Fetching) {
+ belch("ghuH: Spurious ContinueThread while Fetching ignored; TSO %d (%p) [PE %d]",
+ CurrentTSO->id, CurrentTSO, CurrentProc);
+ goto next_thread;
+ }
+ /* Ignore ContinueThreads for completed threads */
+ if (CurrentTSO->what_next == ThreadComplete) {
+ belch("ghuH: found a ContinueThread event for completed thread %d (%p) [PE %d] (ignoring ContinueThread)",
+ CurrentTSO->id, CurrentTSO, CurrentProc);
+ goto next_thread;
+ }
+ /* Ignore ContinueThreads for threads that are being migrated */
+ if (PROCS(CurrentTSO)==Nowhere) {
+ belch("ghuH: trying to run the migrating TSO %d (%p) [PE %d] (ignoring ContinueThread)",
+ CurrentTSO->id, CurrentTSO, CurrentProc);
+ goto next_thread;
+ }
+ /* The thread should be at the beginning of the run queue */
+ if (CurrentTSO!=run_queue_hds[CurrentProc]) {
+ belch("ghuH: TSO %d (%p) [PE %d] is not at the start of the run_queue when doing a ContinueThread",
+ CurrentTSO->id, CurrentTSO, CurrentProc);
+ break; // run the thread anyway
+ }
+ /*
+ new_event(proc, proc, CurrentTime[proc],
+ FindWork,
+ (StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
+ goto next_thread;
+ */ /* Catches superfluous CONTINUEs -- should be unnecessary */
+ break; // now actually run the thread; DaH Qu'vam yImuHbej
+
+ case FetchNode:
+ do_the_fetchnode(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case GlobalBlock:
+ do_the_globalblock(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case FetchReply:
+ do_the_fetchreply(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case UnblockThread: /* Move from the blocked queue to the tail of */
+ do_the_unblock(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case ResumeThread: /* Move from the blocked queue to the tail of */
+ /* the runnable queue ( i.e. Qu' SImqa'lu') */
+ event->tso->gran.blocktime +=
+ CurrentTime[CurrentProc] - event->tso->gran.blockedat;
+ do_the_startthread(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case StartThread:
+ do_the_startthread(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case MoveThread:
+ do_the_movethread(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case MoveSpark:
+ do_the_movespark(event);
+ goto next_thread; /* handle next event in event queue */
+
+ case FindWork:
+ do_the_findwork(event);
+ goto next_thread; /* handle next event in event queue */
+
+ default:
+ barf("Illegal event type %u\n", event->evttype);
+ } /* switch */
+
+ /* This point was scheduler_loop in the old RTS */
+
+ IF_DEBUG(gran, belch("GRAN: after main switch"));
+
+ TimeOfLastEvent = CurrentTime[CurrentProc];
+ TimeOfNextEvent = get_time_of_next_event();
+ IgnoreEvents=(TimeOfNextEvent==0); // HWL HACK
+ // CurrentTSO = ThreadQueueHd;
+
+ IF_DEBUG(gran, belch("GRAN: time of next event is: %ld",
+ TimeOfNextEvent));
+
+ if (RtsFlags.GranFlags.Light)
+ GranSimLight_leave_system(event, &ActiveTSO);
+
+ EndOfTimeSlice = CurrentTime[CurrentProc]+RtsFlags.GranFlags.time_slice;
+
+ IF_DEBUG(gran,
+ belch("GRAN: end of time-slice is %#lx", EndOfTimeSlice));
+
+ /* in a GranSim setup the TSO stays on the run queue */
+ t = CurrentTSO;
+ /* Take a thread from the run queue. */
+ t = POP_RUN_QUEUE(); // take_off_run_queue(t);
+
+ IF_DEBUG(gran,
+ fprintf(stderr, "GRAN: About to run current thread, which is\n");
+ G_TSO(t,5))
+
+ context_switch = 0; // turned on via GranYield, checking events and time slice
+
+ IF_DEBUG(gran,
+ DumpGranEvent(GR_SCHEDULE, t));
+
+ procStatus[CurrentProc] = Busy;
+
#elif defined(PAR)
+
+ if (PendingFetches != END_BF_QUEUE) {
+ processFetches();
+ }
+
/* ToDo: phps merge with spark activation above */
/* check whether we have local work and send requests if we have none */
if (run_queue_hd == END_TSO_QUEUE) { /* no runnable threads */
/* :-[ no local threads => look out for local sparks */
+ /* the spark pool for the current PE */
+ pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
if (advisory_thread_count < RtsFlags.ParFlags.maxThreads &&
- (pending_sparks_hd[REQUIRED_POOL] < pending_sparks_tl[REQUIRED_POOL] ||
- pending_sparks_hd[ADVISORY_POOL] < pending_sparks_tl[ADVISORY_POOL])) {
+ pool->hd < pool->tl) {
/*
* ToDo: add GC code check that we really have enough heap afterwards!!
* Old comment:
spark = findSpark(); /* get a spark */
if (spark != (rtsSpark) NULL) {
tso = activateSpark(spark); /* turn the spark into a thread */
- IF_PAR_DEBUG(verbose,
- belch("== [%x] schedule: Created TSO %p (%d); %d threads active",
- mytid, tso, tso->id, advisory_thread_count));
+ IF_PAR_DEBUG(schedule,
+ belch("==== schedule: Created TSO %d (%p); %d threads active",
+ tso->id, tso, advisory_thread_count));
if (tso==END_TSO_QUEUE) { /* failed to activate spark->back to loop */
- belch("^^ failed to activate spark");
+ belch("==^^ failed to activate spark");
goto next_thread;
} /* otherwise fall through & pick-up new tso */
} else {
IF_PAR_DEBUG(verbose,
- belch("^^ no local sparks (spark pool contains only NFs: %d)",
- spark_queue_len(ADVISORY_POOL)));
+ belch("==^^ no local sparks (spark pool contains only NFs: %d)",
+ spark_queue_len(pool)));
goto next_thread;
}
} else
/* Now we are sure that we have some work available */
ASSERT(run_queue_hd != END_TSO_QUEUE);
/* Take a thread from the run queue, if we have work */
- t = take_off_run_queue(END_TSO_QUEUE);
+ t = POP_RUN_QUEUE(); // take_off_run_queue(END_TSO_QUEUE);
/* ToDo: write something to the log-file
if (RTSflags.ParFlags.granSimStats && !sameThread)
DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
- */
CurrentTSO = t;
+ */
+ /* the spark pool for the current PE */
+ pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
- IF_DEBUG(scheduler, belch("--^^ %d sparks on [%#x] (hd=%x; tl=%x; lim=%x)",
- spark_queue_len(ADVISORY_POOL), CURRENT_PROC,
- pending_sparks_hd[ADVISORY_POOL],
- pending_sparks_tl[ADVISORY_POOL],
- pending_sparks_lim[ADVISORY_POOL]));
+ IF_DEBUG(scheduler, belch("--^^ %d sparks on [%#x] (hd=%x; tl=%x; base=%x, lim=%x)",
+ spark_queue_len(pool),
+ CURRENT_PROC,
+ pool->hd, pool->tl, pool->base, pool->lim));
IF_DEBUG(scheduler, belch("--== %d threads on [%#x] (hd=%x; tl=%x)",
run_queue_len(), CURRENT_PROC,
run_queue_hd, run_queue_tl));
+#if 0
if (t != LastTSO) {
/*
we are running a different TSO, so write a schedule event to log file
GR_SCHEDULE, t, (StgClosure *)NULL, 0, 0);
}
-
+#endif
#else /* !GRAN && !PAR */
/* grab a thread from the run queue
context_switch = 1;
RELEASE_LOCK(&sched_mutex);
-
+
+#if defined(GRAN) || defined(PAR)
+ IF_DEBUG(scheduler, belch("-->> Running TSO %ld (%p) %s ...",
+ t->id, t, whatNext_strs[t->what_next]));
+#else
IF_DEBUG(scheduler,sched_belch("running thread %d", t->id));
+#endif
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* Run the current thread
#ifdef SMP
IF_DEBUG(scheduler,fprintf(stderr,"scheduler (task %ld): ", pthread_self()););
-#else
+#elif !defined(GRAN) && !defined(PAR)
IF_DEBUG(scheduler,fprintf(stderr,"scheduler: "););
#endif
t = cap->rCurrentTSO;
+#if defined(PAR)
+ /* HACK 675: if the last thread didn't yield, make sure to print a
+ SCHEDULE event to the log file when StgRunning the next thread, even
+ if it is the same one as before */
+ LastTSO = t; //(ret == ThreadBlocked) ? END_TSO_QUEUE : t;
+ TimeOfLastYield = CURRENT_TIME;
+#endif
+
switch (ret) {
case HeapOverflow:
/* make all the running tasks block on a condition variable,
* maybe set context_switch and wait till they all pile in,
* then have them wait on a GC condition variable.
*/
- IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
+#if defined(GRAN) || defined(PAR)
+ IF_DEBUG(scheduler,belch("--<< TSO %ld (%p; %s) stopped: HeapOverflow",
+ t->id, t, whatNext_strs[t->what_next]));
+#endif
threadPaused(t);
+#if defined(GRAN)
+ ASSERT(!is_on_queue(t,CurrentProc));
+#endif
ready_to_gc = rtsTrue;
context_switch = 1; /* stop other threads ASAP */
PUSH_ON_RUN_QUEUE(t);
+ /* actual GC is done at the end of the while loop */
break;
case StackOverflow:
+#if defined(GRAN) || defined(PAR)
+ IF_DEBUG(scheduler,belch("--<< TSO %ld (%p; %s) stopped, StackOverflow",
+ t->id, t, whatNext_strs[t->what_next]));
+#endif
/* just adjust the stack for this thread, then pop it back
* on the run queue.
*/
- IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
threadPaused(t);
{
StgMainThread *m;
* up the GC thread. getThread will block during a GC until the
* GC is finished.
*/
+#if defined(GRAN) || defined(PAR)
+ IF_DEBUG(scheduler,
+ if (t->what_next == ThreadEnterHugs) {
+ /* ToDo: or maybe a timer expired when we were in Hugs?
+ * or maybe someone hit ctrl-C
+ */
+ belch("--<< TSO %ld (%p; %s) stopped to switch to Hugs",
+ t->id, t, whatNext_strs[t->what_next]);
+ } else {
+ belch("--<< TSO %ld (%p; %s) stopped, yielding",
+ t->id, t, whatNext_strs[t->what_next]);
+ }
+ );
+#else
IF_DEBUG(scheduler,
if (t->what_next == ThreadEnterHugs) {
/* ToDo: or maybe a timer expired when we were in Hugs?
belch("thread %ld stopped, yielding", t->id);
}
);
+#endif
threadPaused(t);
+ IF_DEBUG(sanity,
+ //belch("&& Doing sanity check on yielding TSO %ld.", t->id);
+ checkTSO(t));
+ ASSERT(t->link == END_TSO_QUEUE);
+#if defined(GRAN)
+ ASSERT(!is_on_queue(t,CurrentProc));
+
+ IF_DEBUG(sanity,
+ //belch("&& Doing sanity check on all ThreadQueues (and their TSOs).");
+ checkThreadQsSanity(rtsTrue));
+#endif
APPEND_TO_RUN_QUEUE(t);
+#if defined(GRAN)
+ /* add a ContinueThread event to actually process the thread */
+ new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
+ ContinueThread,
+ t, (StgClosure*)NULL, (rtsSpark*)NULL);
+ IF_GRAN_DEBUG(bq,
+ belch("GRAN: eventq and runnableq after adding yielded thread to queue again:");
+ G_EVENTQ(0);
+ G_CURR_THREADQ(0))
+#endif /* GRAN */
break;
case ThreadBlocked:
#if defined(GRAN)
-# error ToDo: implement GranSim scheduler
+ IF_DEBUG(scheduler,
+ belch("--<< TSO %ld (%p; %s) stopped, blocking on node %p [PE %d] with BQ: ",
+ t->id, t, whatNext_strs[t->what_next], t->block_info.closure, (t->block_info.closure==(StgClosure*)NULL ? 99 : where_is(t->block_info.closure)));
+ if (t->block_info.closure!=(StgClosure*)NULL) print_bq(t->block_info.closure));
+
+ // ??? needed; should emit block before
+ IF_DEBUG(gran,
+ DumpGranEvent(GR_DESCHEDULE, t));
+ prune_eventq(t, (StgClosure *)NULL); // prune ContinueThreads for t
+ /*
+ ngoq Dogh!
+ ASSERT(procStatus[CurrentProc]==Busy ||
+ ((procStatus[CurrentProc]==Fetching) &&
+ (t->block_info.closure!=(StgClosure*)NULL)));
+ if (run_queue_hds[CurrentProc] == END_TSO_QUEUE &&
+ !(!RtsFlags.GranFlags.DoAsyncFetch &&
+ procStatus[CurrentProc]==Fetching))
+ procStatus[CurrentProc] = Idle;
+ */
#elif defined(PAR)
IF_DEBUG(par,
DumpGranEvent(GR_DESCHEDULE, t));
-#else
-#endif
+
+ /* Send a fetch (if BlockedOnGA) and dump event to log file */
+ blockThread(t);
+
+ IF_DEBUG(scheduler,
+ belch("--<< TSO %ld (%p; %s) stopped, blocking on node %p with BQ: ",
+ t->id, t, whatNext_strs[t->what_next], t->block_info.closure);
+ if (t->block_info.closure!=(StgClosure*)NULL) print_bq(t->block_info.closure));
+
+#else /* !GRAN */
/* don't need to do anything. Either the thread is blocked on
* I/O, in which case we'll have called addToBlockedQueue
* previously, or it's blocked on an MVar or Blackhole, in which
* case it'll be on the relevant queue already.
*/
IF_DEBUG(scheduler,
- fprintf(stderr, "thread %d stopped, ", t->id);
+ fprintf(stderr, "--<< TSO %d (%p) stopped ", t->id, t);
printThreadBlockage(t);
fprintf(stderr, "\n"));
+
+ /* Only for dumping event to log file
+ ToDo: do I need this in GranSim, too?
+ blockThread(t);
+ */
+#endif
threadPaused(t);
break;
* more main threads, we probably need to stop all the tasks until
* we get a new one.
*/
- IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
+ IF_DEBUG(scheduler,belch("--++ TSO %d (%p) finished", t->id, t));
t->what_next = ThreadComplete;
#if defined(GRAN)
- // ToDo: endThread(t, CurrentProc); // clean-up the thread
+ endThread(t, CurrentProc); // clean-up the thread
#elif defined(PAR)
advisory_thread_count--;
if (RtsFlags.ParFlags.ParStats.Full)
#ifdef SMP
pthread_cond_broadcast(&gc_pending_cond);
#endif
+#if defined(GRAN)
+ /* add a ContinueThread event to continue execution of current thread */
+ new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
+ ContinueThread,
+ t, (StgClosure*)NULL, (rtsSpark*)NULL);
+ IF_GRAN_DEBUG(bq,
+ fprintf(stderr, "GRAN: eventq and runnableq after Garbage collection:\n");
+ G_EVENTQ(0);
+ G_CURR_THREADQ(0))
+#endif /* GRAN */
}
#if defined(GRAN)
next_thread:
createGenThread() and createIOThread() (in SchedAPI.h) are
convenient packaged versions of this function.
+
+ currently pri (priority) is only used in a GRAN setup -- HWL
------------------------------------------------------------------------ */
//@cindex createThread
#if defined(GRAN)
-/* currently pri (priority) is only used in a GRAN setup -- HWL */
+/* currently pri (priority) is only used in a GRAN setup -- HWL */
StgTSO *
createThread(nat stack_size, StgInt pri)
{
createThread_(nat size, rtsBool have_lock)
{
#endif
+
StgTSO *tso;
nat stack_size;
*/
#endif
+#if defined(GRAN) || defined(PAR)
+ DumpGranEvent(GR_START,tso);
+#endif
+
/* Link the new thread on the global thread list.
*/
-#if defined(GRAN)
-#error ToDo
-#else
tso->global_link = all_threads;
all_threads = tso;
-#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;
IF_DEBUG(gran,printTSO(tso));
#elif defined(PAR)
+# if defined(DEBUG)
+ tso->par.magic = TSO_MAGIC; // debugging only
+# endif
tso->par.sparkname = 0;
tso->par.startedat = CURRENT_TIME;
tso->par.exported = 0;
globalGranStats.tot_sq_probes++;
#endif
+#if defined(GRAN)
+ IF_GRAN_DEBUG(pri,
+ belch("==__ schedule: Created TSO %d (%p);",
+ CurrentProc, tso, tso->id));
+#elif defined(PAR)
+ IF_PAR_DEBUG(verbose,
+ belch("==__ schedule: Created TSO %d (%p); %d threads active",
+ tso->id, tso, advisory_thread_count));
+#else
IF_DEBUG(scheduler,sched_belch("created thread %ld, stack size = %lx words",
tso->id, tso->stack_size));
+#endif
+ return tso;
+}
+
+/*
+ Turn a spark into a thread.
+ ToDo: fix for SMP (needs to acquire SCHED_MUTEX!)
+*/
+#if defined(PAR)
+//@cindex activateSpark
+StgTSO *
+activateSpark (rtsSpark spark)
+{
+ StgTSO *tso;
+
+ ASSERT(spark != (rtsSpark)NULL);
+ tso = createThread_(RtsFlags.GcFlags.initialStkSize, rtsTrue);
+ if (tso!=END_TSO_QUEUE) {
+ pushClosure(tso,spark);
+ PUSH_ON_RUN_QUEUE(tso);
+ advisory_thread_count++;
+
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ //ASSERT(run_queue_hd == END_TSO_QUEUE); // I think ...
+ IF_PAR_DEBUG(verbose,
+ belch("==^^ activateSpark: turning spark of closure %p (%s) into a thread",
+ (StgClosure *)spark, info_type((StgClosure *)spark)));
+ }
+ } else {
+ barf("activateSpark: Cannot create TSO");
+ }
+ // ToDo: fwd info on local/global spark to thread -- HWL
+ // tso->gran.exported = spark->exported;
+ // tso->gran.locked = !spark->global;
+ // tso->gran.sparkname = spark->name;
+
return tso;
}
+#endif
/* ---------------------------------------------------------------------------
* scheduleThread()
void
scheduleThread(StgTSO *tso)
{
+ if (tso==END_TSO_QUEUE){
+ schedule();
+ return;
+ }
+
ACQUIRE_LOCK(&sched_mutex);
/* Put the new thread on the head of the runnable queue. The caller
* KH @ 25/10/99
* ------------------------------------------------------------------------ */
-#ifdef SMP
-static void *
+#if defined(PAR) || defined(SMP)
+void *
taskStart( void *arg STG_UNUSED )
{
- schedule();
- return NULL;
+ rts_evalNothing(NULL);
}
#endif
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * waitThread is the external interface for running a new computataion
+ * waitThread is the external interface for running a new computation
* and waiting for the result.
*
* In the non-SMP case, we create a new main thread, push it on the
do {
pthread_cond_wait(&m->wakeup, &sched_mutex);
} while (m->stat == NoStatus);
+#elif defined(GRAN)
+ /* GranSim specific init */
+ CurrentTSO = m->tso; // the TSO to run
+ procStatus[MainProc] = Busy; // status of main PE
+ CurrentProc = MainProc; // PE to run it on
+
+ schedule();
#else
schedule();
ASSERT(m->stat != NoStatus);
markEventQueue();
#else /* !GRAN */
- run_queue_hd = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
- run_queue_tl = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
+ if (run_queue_hd != END_TSO_QUEUE) {
+ ASSERT(run_queue_tl != END_TSO_QUEUE);
+ run_queue_hd = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
+ run_queue_tl = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
+ }
- blocked_queue_hd = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
- blocked_queue_tl = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
+ if (blocked_queue_hd != END_TSO_QUEUE) {
+ ASSERT(blocked_queue_tl != END_TSO_QUEUE);
+ blocked_queue_hd = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
+ blocked_queue_tl = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
+ }
#endif
for (m = main_threads; m != NULL; m = m->link) {
m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
}
- suspended_ccalling_threads =
- (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
+ if (suspended_ccalling_threads != END_TSO_QUEUE)
+ suspended_ccalling_threads =
+ (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
#if defined(SMP) || defined(PAR) || defined(GRAN)
markSparkQueue();
IF_DEBUG(sanity,checkTSO(tso));
if (tso->stack_size >= tso->max_stack_size) {
-#if 0
- /* 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));
-#endif
+
+ IF_DEBUG(gc,
+ belch("@@ threadStackOverflow of TSO %d (%p): stack too large (now %ld; max is %ld",
+ tso->id, tso, tso->stack_size, tso->max_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)));
+
#ifdef INTERPRETER
fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
exit(1);
tso->why_blocked = NotBlocked;
dest->mut_link = NULL;
+ IF_PAR_DEBUG(verbose,
+ belch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld",
+ 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)));
+
IF_DEBUG(sanity,checkTSO(tso));
#if 0
IF_DEBUG(scheduler,printTSO(dest));
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,
+ GR_RESUME, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
0, 0 /* spark_queue_len(ADVISORY_POOL) */);
switch (get_itbl(node)->type) {
static StgBlockingQueueElement *
unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
{
- StgBlockingQueueElement *next;
+ 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(tso);
+ 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);
- bq_processing_time += RtsFlags.GranFlags.Costs.lunblocktime;
+ CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.lunblocktime;
// insertThread(tso, node_loc);
- new_event(tso_loc, tso_loc,
- CurrentTime[CurrentProc]+bq_processing_time,
+ 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)
- bq_processing_time += RtsFlags.GranFlags.Costs.mpacktime;
- bq_processing_time += RtsFlags.GranFlags.Costs.gunblocktime;
- new_event(tso_loc, CurrentProc,
- CurrentTime[CurrentProc]+bq_processing_time+
- RtsFlags.GranFlags.Costs.latency,
+ 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
- bq_processing_time += RtsFlags.GranFlags.Costs.mtidytime;
// len++;
- }
+ }
/* the thread-queue-overhead is accounted for in either Resume or UnblockThread */
IF_GRAN_DEBUG(bq,
- fprintf(stderr," %s TSO %d (%p) [PE %d] (blocked_on=%p) (next=%p) ,",
+ fprintf(stderr," %s TSO %d (%p) [PE %d] (block_info.closure=%p) (next=%p) ,",
(node_loc==tso_loc ? "Local" : "Global"),
- tso->id, tso, CurrentProc, tso->blocked_on, tso->link))
- tso->blocked_on = NULL;
+ tso->id, tso, CurrentProc, tso->block_info.closure, tso->link));
+ tso->block_info.closure = NULL;
IF_DEBUG(scheduler,belch("-- Waking up thread %ld (%p)",
tso->id, tso));
- }
-
- /* 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 (next!=END_BQ_QUEUE) {
- ASSERT(get_itbl(node)->type == RBH && get_itbl(next)->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 = ((StgRBHSave *)next)->payload[0];
- ((StgRBH *)node)->mut_link = ((StgRBHSave *)next)->payload[1];
-
- IF_GRAN_DEBUG(bq,
- belch("## Filled in RBH_Save for %p (%s) at end of AwBQ",
- node, info_type(node)));
- }
}
#elif defined(PAR)
static StgBlockingQueueElement *
}
#endif
-#if defined(PAR) || defined(GRAN)
-inline StgTSO *
-unblockOne(StgTSO *tso, StgClosure *node)
+#if defined(GRAN) || defined(PAR)
+inline StgBlockingQueueElement *
+unblockOne(StgBlockingQueueElement *bqe, StgClosure *node)
{
ACQUIRE_LOCK(&sched_mutex);
- tso = unblockOneLocked(tso, node);
+ bqe = unblockOneLocked(bqe, node);
RELEASE_LOCK(&sched_mutex);
- return tso;
+ return bqe;
}
#else
inline StgTSO *
void
awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
{
- StgBlockingQueueElement *bqe, *next;
- StgTSO *tso;
- PEs node_loc, tso_loc;
- rtsTime bq_processing_time = 0;
- nat len = 0, len_local = 0;
+ StgBlockingQueueElement *bqe;
+ PEs node_loc;
+ nat len = 0;
IF_GRAN_DEBUG(bq,
belch("## AwBQ for node %p on PE %d @ %ld by TSO %d (%p): ", \
*/
//tso = (StgTSO *)bqe; // wastes an assignment to get the type right
//tso_loc = where_is(tso);
+ len++;
bqe = unblockOneLocked(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,
+ belch("## Filled in RBH_Save for %p (%s) at end of AwBQ",
+ node, info_type(node)));
+ }
+
/* statistics gathering */
- /* ToDo: fix counters
if (RtsFlags.GranFlags.GranSimStats.Global) {
- globalGranStats.tot_bq_processing_time += bq_processing_time;
+ // 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_bq_len_local += len_local; // same for local TSOs only
globalGranStats.tot_awbq++; // total no. of bqs awakened
}
IF_GRAN_DEBUG(bq,
- fprintf(stderr,"## BQ Stats of %p: [%d entries, %d local] %s\n",
- node, len, len_local, (next!=END_TSO_QUEUE) ? "RBH" : ""));
- */
+ fprintf(stderr,"## BQ Stats of %p: [%d entries] %s\n",
+ node, len, (bqe!=END_BQ_QUEUE) ? "RBH" : ""));
}
#elif defined(PAR)
void
This has nothing to do with the UnblockThread event in GranSim. -- HWL
-------------------------------------------------------------------------- */
+#if defined(GRAN) || defined(PAR)
+/*
+ NB: only the type of the blocking queue is different in GranSim and GUM
+ the operations on the queue-elements are the same
+ long live polymorphism!
+*/
+static void
+unblockThread(StgTSO *tso)
+{
+ StgBlockingQueueElement *t, **last;
+
+ ACQUIRE_LOCK(&sched_mutex);
+ switch (tso->why_blocked) {
+
+ case NotBlocked:
+ return; /* not blocked */
+
+ case BlockedOnMVar:
+ ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
+ {
+ StgBlockingQueueElement *last_tso = END_BQ_QUEUE;
+ StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
+
+ last = (StgBlockingQueueElement **)&mvar->head;
+ for (t = (StgBlockingQueueElement *)mvar->head;
+ t != END_BQ_QUEUE;
+ last = &t->link, last_tso = t, t = t->link) {
+ if (t == (StgBlockingQueueElement *)tso) {
+ *last = (StgBlockingQueueElement *)tso->link;
+ if (mvar->tail == tso) {
+ mvar->tail = (StgTSO *)last_tso;
+ }
+ goto done;
+ }
+ }
+ barf("unblockThread (MVAR): TSO not found");
+ }
+
+ case BlockedOnBlackHole:
+ ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
+ {
+ StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
+
+ last = &bq->blocking_queue;
+ for (t = bq->blocking_queue;
+ t != END_BQ_QUEUE;
+ last = &t->link, t = t->link) {
+ if (t == (StgBlockingQueueElement *)tso) {
+ *last = (StgBlockingQueueElement *)tso->link;
+ goto done;
+ }
+ }
+ barf("unblockThread (BLACKHOLE): TSO not found");
+ }
+
+ case BlockedOnException:
+ {
+ StgTSO *target = tso->block_info.tso;
+
+ ASSERT(get_itbl(target)->type == TSO);
+ ASSERT(target->blocked_exceptions != NULL);
+
+ last = (StgBlockingQueueElement **)&target->blocked_exceptions;
+ for (t = (StgBlockingQueueElement *)target->blocked_exceptions;
+ t != END_BQ_QUEUE;
+ last = &t->link, t = t->link) {
+ ASSERT(get_itbl(t)->type == TSO);
+ if (t == (StgBlockingQueueElement *)tso) {
+ *last = (StgBlockingQueueElement *)tso->link;
+ goto done;
+ }
+ }
+ barf("unblockThread (Exception): TSO not found");
+ }
+
+ case BlockedOnDelay:
+ case BlockedOnRead:
+ case BlockedOnWrite:
+ {
+ StgBlockingQueueElement *prev = NULL;
+ for (t = (StgBlockingQueueElement *)blocked_queue_hd; t != END_BQ_QUEUE;
+ prev = t, t = t->link) {
+ if (t == (StgBlockingQueueElement *)tso) {
+ if (prev == NULL) {
+ blocked_queue_hd = (StgTSO *)t->link;
+ if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
+ blocked_queue_tl = END_TSO_QUEUE;
+ }
+ } else {
+ prev->link = t->link;
+ if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
+ blocked_queue_tl = (StgTSO *)prev;
+ }
+ }
+ goto done;
+ }
+ }
+ barf("unblockThread (I/O): TSO not found");
+ }
+
+ default:
+ barf("unblockThread");
+ }
+
+ done:
+ tso->link = END_TSO_QUEUE;
+ tso->why_blocked = NotBlocked;
+ tso->block_info.closure = NULL;
+ PUSH_ON_RUN_QUEUE(tso);
+ RELEASE_LOCK(&sched_mutex);
+}
+#else
static void
unblockThread(StgTSO *tso)
{
PUSH_ON_RUN_QUEUE(tso);
RELEASE_LOCK(&sched_mutex);
}
+#endif
/* -----------------------------------------------------------------------------
* raiseAsync()
break;
#if defined(PAR)
case BlockedOnGA:
- fprintf(stderr,"blocked on global address");
+ fprintf(stderr,"blocked on global address; local FM_BQ is %p (%s)",
+ tso->block_info.closure, info_type(tso->block_info.closure));
+ break;
+ case BlockedOnGA_NoSend:
+ fprintf(stderr,"blocked on global address (no send); local FM_BQ is %p (%s)",
+ tso->block_info.closure, info_type(tso->block_info.closure));
break;
#endif
+ default:
+ barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
+ tso->why_blocked, tso->id, tso);
}
}
print_bq (StgClosure *node)
{
StgBlockingQueueElement *bqe;
- StgTSO *tso;
PEs node_loc, tso_loc;
rtsBool end;
!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 != (StgTSO*)NULL); // 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);
tso_loc = where_is((StgClosure *)bqe);
switch (get_itbl(bqe)->type) {
case TSO:
- fprintf(stderr," TSO %d (%x) on [PE %d],",
- ((StgTSO *)bqe)->id, ((StgTSO *)bqe), tso_loc);
+ fprintf(stderr," TSO %d (%p) on [PE %d],",
+ ((StgTSO *)bqe)->id, (StgTSO *)bqe, tso_loc);
break;
case CONSTR:
fprintf(stderr," %s (IP %p),",
break;
default:
barf("Unexpected closure type %s in blocking queue of %p (%s)",
- info_type(bqe), node, info_type(node));
+ info_type((StgClosure *)bqe), node, info_type(node));
break;
}
} /* for */
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.16 2000/03/16 17:27:13 simonmar Exp $
+ * $Id: Schedule.h,v 1.17 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team 1998-1999
*
* Called from STG : yes
* Locks assumed : none
*/
-#if defined(GRAN)
-StgTSO *unblockOne(StgTSO *tso, StgClosure *node);
-#elif defined(PAR)
-StgTSO *unblockOne(StgTSO *tso, StgClosure *node);
+#if defined(GRAN) || defined(PAR)
+StgBlockingQueueElement *unblockOne(StgBlockingQueueElement *bqe, StgClosure *node);
#else
StgTSO *unblockOne(StgTSO *tso);
#endif
/* Thread queues.
* Locks required : sched_mutex
+ *
+ * In GranSim we have one run/blocked_queue per PE.
*/
+#if defined(GRAN)
+// run_queue_hds defined in GranSim.h
+#else
extern StgTSO *run_queue_hd, *run_queue_tl;
extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
+#endif
+/* Linked list of all threads. */
extern StgTSO *all_threads;
#ifdef SMP
extern task_info *task_ids;
#endif
-#if !defined(GRAN)
-extern StgTSO *run_queue_hd, *run_queue_tl;
-extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
-#endif
-
/* Needed by Hugs.
*/
void interruptStgRts ( void );
-// ?? needed -- HWL
void raiseAsync(StgTSO *tso, StgClosure *exception);
nat run_queue_len(void);
* Some convenient macros...
*/
+/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
#define END_TSO_QUEUE ((StgTSO *)(void*)&END_TSO_QUEUE_closure)
+/* this is the NIL ptr for a list CAFs */
#define END_CAF_LIST ((StgCAF *)(void*)&END_TSO_QUEUE_closure)
+#if defined(PAR) || defined(GRAN)
+/* this is the NIL ptr for a blocking queue */
+# define END_BQ_QUEUE ((StgBlockingQueueElement *)(void*)&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*)&END_TSO_QUEUE_closure)
+#endif
//@cindex APPEND_TO_RUN_QUEUE
/* Add a thread to the end of the run queue.
run_queue_tl = tso; \
}
-//@cindex POP_RUN_QUEUE
+//@cindex POP_RUN_QUEUE
/* Pop the first thread off the runnable queue.
*/
#define POP_RUN_QUEUE() \
-/* -----------------------------------------------------------------------------
- * $Id: Sparks.c,v 1.1 2000/01/12 15:15:18 simonmar Exp $
+/* ---------------------------------------------------------------------------
+ * $Id: Sparks.c,v 1.2 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 2000
*
* Sparking support for PAR and SMP versions of the RTS.
*
- * ---------------------------------------------------------------------------*/
+ * -------------------------------------------------------------------------*/
-#if defined(SMP) || defined(PAR)
+//@node Spark Management Routines, , ,
+//@section Spark Management Routines
+
+//@menu
+//* Includes::
+//* GUM code::
+//* GranSim code::
+//@end menu
+
+//@node Includes, GUM code, Spark Management Routines, Spark Management Routines
+//@subsection Includes
#include "Rts.h"
#include "Schedule.h"
#include "SchedAPI.h"
-#include "Sparks.h"
#include "Storage.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
+# if defined(PAR)
+# include "ParallelRts.h"
+# elif defined(GRAN)
+# include "GranSimRts.h"
+# endif
+#include "Sparks.h"
+
+#if defined(SMP) || defined(PAR)
+
+//@node GUM code, GranSim code, Includes, Spark Management Routines
+//@subsection GUM code
static void slide_spark_pool( StgSparkPool *pool );
}
return NULL;
}
-
+
rtsBool
add_to_spark_queue( StgClosure *closure, StgSparkPool *pool )
{
pool->tl = to_sparkp;
}
-static inline nat
+nat
spark_queue_len( StgSparkPool *pool )
{
return (nat) (pool->tl - pool->hd);
}
}
-#endif /* SMP || PAR */
+void
+disposeSpark(spark)
+StgClosure *spark;
+{
+#if !defined(SMP)
+ 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)
+
+//@node GranSim code, , GUM code, Spark Management Routines
+//@subsection GranSim code
+
+//@menu
+//* Basic interface to sparkq::
+//* Aux fcts::
+//@end menu
+
+//@node Basic interface to sparkq, Aux fcts, GranSim code, GranSim code
+//@subsubsection Basic interface to sparkq
+/*
+ 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)
+*/
+//@cindex findLocalSpark
+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,
+ belch("^^ 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) {
+ fprintf(stderr,"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) {
+ fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
+ stg_exit(EXIT_FAILURE);
+ break;
+ } */
+ prev = spark;
+ spark = spark->next;
+
+ IF_GRAN_DEBUG(pri,
+ belch("++ 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)
+*/
+//@cindex activateSpark
+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,
+ belch("++ 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);
+ // 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 */
+//@cindex newSpark
+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,
+ belch(",, 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);
+}
+
+//@cindex disposeSpark
+void
+disposeSpark(spark)
+rtsSpark *spark;
+{
+ ASSERT(spark!=NULL);
+ free(spark);
+}
+
+//@cindex disposeSparkQ
+void
+disposeSparkQ(spark)
+rtsSparkQ spark;
+{
+ if (spark==NULL)
+ return;
+
+ disposeSparkQ(spark->next);
+
+# ifdef GRAN_CHECK
+ if (SparksAvail < 0) {
+ fprintf(stderr,"disposeSparkQ: SparksAvail<0 after disposing sparkq @ %p\n", &spark);
+ print_spark(spark);
+ }
+# endif
+
+ free(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.
+*/
+
+//@cindex add_to_spark_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,
+ belch("++ 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) )
+ fprintf(stderr,"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) {
+ fprintf(stderr,"ghuH: SPARKQ on PE %d is not sorted:\n",
+ CurrentProc);
+ print_sparkq(CurrentProc);
+ }
+ }
+# endif
+}
+
+//@node Aux fcts, , Basic interface to sparkq, GranSim code
+//@subsubsection Aux fcts
-#if defined(GRAN)
+//@cindex spark_queue_len
+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]) )
+ fprintf(stderr,"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);
+}
-... ToDo ...
+/*
+ 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.
+*/
+//@cindex delete_from_sparkq
+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 ) {
+ fprintf(stderr,"## |%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 ) {
+ fprintf(stderr,"## |%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) */
+//@cindex markSparkQueue
+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,
+ belch("@@ markSparkQueue: spark statistics at start of GC:");
+ print_sparkq_stats());
+}
+
+//@cindex print_spark
+void
+print_spark(spark)
+rtsSpark *spark;
+{
+ char str[16];
+
+ if (spark==NULL) {
+ fprintf(stderr,"Spark: NIL\n");
+ return;
+ } else {
+ sprintf(str,
+ ((spark->node==NULL) ? "______" : "%#6lx"),
+ stgCast(StgPtr,spark->node));
+
+ fprintf(stderr,"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);
+ }
+}
+
+//@cindex print_sparkq
+void
+print_sparkq(proc)
+PEs proc;
+// rtsSpark *hd;
+{
+ rtsSpark *x = pending_sparks_hds[proc];
+
+ fprintf(stderr,"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.
+*/
+//@cindex print_sparkq_stats
+void
+print_sparkq_stats(void)
+{
+ PEs p;
+
+ fprintf(stderr, "SparkQs: [");
+ for (p=0; p<RtsFlags.GranFlags.proc; p++)
+ fprintf(stderr, ", PE %d: %d", p, spark_queue_len(p));
+ fprintf(stderr, "\n");
+}
#endif
/* -----------------------------------------------------------------------------
- * $Id: Sparks.h,v 1.1 2000/01/12 15:15:18 simonmar Exp $
+ * $Id: Sparks.h,v 1.2 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 2000
*
- * Sparking support for PAR and SMP versions of the RTS.
- *
+ * Sparking support for GRAN, PAR and SMP versions of the RTS.
+ *
* ---------------------------------------------------------------------------*/
+#if defined(GRAN)
+
+void findLocalSpark (rtsEvent *event, rtsBool *found_res, rtsSparkQ *spark_res);
+rtsBool activateSpark (rtsEvent *event, rtsSparkQ spark);
+rtsSpark *newSpark(StgClosure *node, nat name, nat gran_info,
+ nat size_info, nat par_info, nat local);
+void add_to_spark_queue(rtsSpark *spark);
+rtsSpark *delete_from_sparkq (rtsSpark *spark, PEs p, rtsBool dispose_too);
+void disposeSpark(rtsSpark *spark);
+void disposeSparkQ(rtsSparkQ spark);
+void print_spark(rtsSpark *spark);
+void print_sparkq(PEs proc);
+void print_sparkq_stats(void);
+nat spark_queue_len(PEs proc);
+void markSparkQueue(void);
+
+#elif defined(PAR) || defined(SMP)
+
void initSparkPools( void );
void markSparkQueue( void );
-StgClosure * findSpark( void );
+StgClosure *findSpark( void );
rtsBool add_to_spark_queue( StgClosure *closure, StgSparkPool *pool );
void markSparkQueue( void );
+
+#endif
/* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.14 2000/03/08 10:58:38 simonmar Exp $
+ * $Id: StgCRun.c,v 1.15 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
char* nm;
while (1) {
-#define STACK_DETAILS 0
+// #define STACK_DETAILS 0 // I like details -- HWL
#if STACK_DETAILS
{
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.38 2000/03/14 09:55:05 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.39 2000/03/31 03:09:36 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
/* Change the BLACKHOLE into a BLACKHOLE_BQ */
((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
-#if defined(PAR)
- /* Save the Thread State here, before calling RTS routines below! */
- SAVE_THREAD_STATE(1);
-
- /* if collecting stats update the execution time etc */
- if (RtsFlags.ParFlags.ParStats.Full) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
- CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
- CurrentTSO->par.blockcount++;
- CurrentTSO->par.blockedat = CURRENT_TIME;
- DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
- }
+ /* PAR: dumping of event now done in blockThread -- HWL */
- THREAD_RETURN(1); /* back to the scheduler */
-#else
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
-#endif
FE_
}
((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
#endif
-#if defined(PAR)
- /* Save the Thread State here, before calling RTS routines below! */
- SAVE_THREAD_STATE(1);
-
- /* if collecting stats update the execution time etc */
- if (RtsFlags.ParFlags.ParStats.Full) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
- CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
- CurrentTSO->par.blockcount++;
- CurrentTSO->par.blockedat = CURRENT_TIME;
- DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
- }
+ /* PAR: dumping of event now done in blockThread -- HWL */
- THREAD_RETURN(1); /* back to the scheduler */
-#else
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
-#endif
FE_
}
CurrentTSO->why_blocked = BlockedOnBlackHole;
CurrentTSO->block_info.closure = R1.cl;
-#if defined(PAR)
- /* Save the Thread State here, before calling RTS routines below! */
- SAVE_THREAD_STATE(1);
-
- /* if collecting stats update the execution time etc */
- if (RtsFlags.ParFlags.ParStats.Full) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
- CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
- CurrentTSO->par.blockcount++;
- CurrentTSO->par.blockedat = CURRENT_TIME;
- DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
- }
+ /* PAR: dumping of event now done in blockThread -- HWL */
- THREAD_RETURN(1); /* back to the scheduler */
-#else
- /* saves thread state and leaves thread in ThreadEnterGHC state; */
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
-#endif
-
FE_
}
/* Change the CAF_BLACKHOLE into a BLACKHOLE_BQ */
((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
-#if defined(PAR)
- /* Save the Thread State here, before calling RTS routines below! */
- SAVE_THREAD_STATE(1);
-
- /* if collecting stats update the execution time etc */
- if (RtsFlags.ParFlags.ParStats.Full) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
- CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
- CurrentTSO->par.blockcount++;
- CurrentTSO->par.blockedat = CURRENT_TIME;
- DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
- }
+ /* PAR: dumping of event now done in blockThread -- HWL */
- THREAD_RETURN(1); /* back to the scheduler */
-#else
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
-#endif
-
FE_
}
/* ----------------------------------------------------------------------------
- Time-stamp: <Fri Jan 14 2000 09:41:07 Stardate: [-30]4202.01 hwloidl>
- $Id: FetchMe.hc,v 1.4 2000/01/14 16:15:08 simonmar Exp $
+ Time-stamp: <Thu Feb 24 2000 21:31:41 Stardate: [-30]4409.48 hwloidl>
+ $Id: FetchMe.hc,v 1.5 2000/03/31 03:09:37 hwloidl Exp $
Entry code for a FETCH_ME closure
another PE. We issue a fetch message, and wait for the data to be
retrieved.
+ A word on the ptr/nonptr fields in the macros: they are unused at the
+ moment; all closures defined here have constant size (ie. no payload
+ that varies from closure to closure). Therefore, all routines that
+ need to know the size of these closures have to do a sizeofW(StgFetchMe)
+ etc to get the closure size. See get_closure_info(), evacuate() and
+ checkClosure() (using the same fcts for determining the size of the
+ closures would be a good idea; at least it would be a nice step towards
+ making this code bug free).
+
About the difference between std and PAR in returning to the RTS:
in PAR we call RTS functions from within the entry code (see also
BLACKHOLE_entry and friends in StgMiscClosures.hc); therefore, we
//@cindex FETCH_ME_entry
STGFUN(FETCH_ME_entry)
{
+ /*
+ Not needed any more since we call blockThread in the scheduler
+ (via BLOCK_NP(1) which returns with BlockedOnGA
+
extern globalAddr *rga_GLOBAL;
extern globalAddr *lga_GLOBAL;
extern globalAddr fmbqga_GLOBAL;
extern StgClosure *p_GLOBAL;
- /*
globalAddr *rga;
globalAddr *lga;
globalAddr fmbqga;
*/
FB_
- rga_GLOBAL = ((StgFetchMe *)R1.p)->ga;
- ASSERT(rga->payload.gc.gtid != mytid);
-
- /* Turn the FETCH_ME into a FETCH_ME_BQ, and place the current thread
- * on the blocking queue.
- */
- // R1.cl->header.info = FETCH_ME_BQ_info;
- SET_INFO((StgClosure *)R1.cl, &FETCH_ME_BQ_info);
-
- CurrentTSO->link = END_BQ_QUEUE;
- ((StgFetchMeBlockingQueue *)R1.cl)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
-
- /* record onto which closure the current thread is blcoking */
- CurrentTSO->block_info.closure = R1.cl;
- //recordMutable((StgMutClosure *)R1.cl);
- p_GLOBAL = R1.cl;
-
- /* Save the Thread State here, before calling RTS routines below! */
- //BLOCK_NP_NO_JUMP(1);
- SAVE_THREAD_STATE(1);
-
- /* unknown junk... needed? --SDM yes, want to see what's happening -- HWL */
- if (RtsFlags.ParFlags.ParStats.Full) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
- CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
- CurrentTSO->par.fetchcount++;
- /* TSO_QUEUE(CurrentTSO) = Q_FETCHING; */
- CurrentTSO->par.blockedat = CURRENT_TIME;
- /* we are about to send off a FETCH message, so dump a FETCH event */
- /* following should be an STGCALL --SDM */
- DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(rga_GLOBAL->payload.gc.gtid),
- GR_FETCH, CurrentTSO, (StgClosure *)R1.p, 0);
- }
-
- /* Phil T. claims that this was a workaround for a hard-to-find
- * bug, hence I'm leaving it out for now --SDM
- */
- /* Assign a brand-new global address to the newly created FMBQ */
- lga_GLOBAL = makeGlobal(p_GLOBAL, rtsFalse);
- splitWeight(&fmbqga_GLOBAL, lga_GLOBAL);
- ASSERT(fmbqga_GLOBAL.weight == 1L << (BITS_IN(unsigned) - 1));
-
- STGCALL3(sendFetch, rga_GLOBAL, &fmbqga_GLOBAL, 0/*load*/);
-
- // sendFetch now called from processTheRealFetch, to make SDM happy
- //theGlobalFromGA.payload.gc.gtid = rga->payload.gc.gtid;
- //theGlobalFromGA.payload.gc.slot = rga->payload.gc.slot;
- //theGlobalFromGA.weight = rga->weight;
- //theGlobalToGA.payload.gc.gtid = fmbqga.payload.gc.gtid;
- //theGlobalToGA.payload.gc.slot = fmbqga.payload.gc.slot;
- //theGlobalToGA.weight = fmbqga.weight;
-
- // STGCALL6(fprintf,stderr,"%% Fetching %p from remote PE ((%x,%d,%x))\n",R1.p,rga->payload.gc.gtid, rga->payload.gc.slot, rga->weight);
-
- THREAD_RETURN(1); /* back to the scheduler */
- // was: BLOCK_NP(1);
+ /*
+ rga_GLOBAL = ((StgFetchMe *)R1.p)->ga;
+ ASSERT(rga->payload.gc.gtid != mytid);
+ */
+ ASSERT(((StgFetchMe *)R1.p)->ga->payload.gc.gtid != mytid);
+
+ /* Turn the FETCH_ME into a FETCH_ME_BQ, and place the current thread
+ * on the blocking queue.
+ */
+ // R1.cl->header.info = FETCH_ME_BQ_info;
+ SET_INFO((StgClosure *)R1.cl, &FETCH_ME_BQ_info);
+
+ /* Put ourselves on the blocking queue for this black hole */
+ // This is really, really BAD; tmp HACK to remember ga (checked in blockThread)
+ ASSERT(looks_like_ga(((StgFetchMe *)R1.p)->ga));
+ CurrentTSO->link = (StgBlockingQueueElement *)((StgFetchMe *)R1.p)->ga; // END_BQ_QUEUE;
+ ((StgFetchMeBlockingQueue *)R1.cl)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
+
+ /* jot down why and on what closure we are blocked */
+ CurrentTSO->why_blocked = BlockedOnGA;
+ CurrentTSO->block_info.closure = R1.cl;
+ //recordMutable((StgMutClosure *)R1.cl);
+ //p_GLOBAL = R1.cl;
+
+ /* sendFetch etc is now done in blockThread, which is called from the
+ scheduler -- HWL */
+
+ BLOCK_NP(1);
FE_
}
FB_
TICK_ENT_BH();
- /* Put ourselves on the blocking queue for this black hole */
- CurrentTSO->block_info.closure = R1.cl;
+ /* Put ourselves on the blocking queue for this node */
CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
-#if defined(PAR)
- /* Save the Thread State here, before calling RTS routines below! */
- SAVE_THREAD_STATE(1);
-
- if (RtsFlags.ParFlags.ParStats.Full) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
- CurrentTSO->par.exectime += CURRENT_TIME - CurrentTSO->par.blockedat;
- CurrentTSO->par.blockcount++;
- CurrentTSO->par.blockedat = CURRENT_TIME;
- DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, CurrentTSO, (StgClosure *)R1.p, 0);
- }
-
- THREAD_RETURN(1); /* back to the scheduler */
-#else
+ /* jot down why and on what closure we are blocked */
+ CurrentTSO->why_blocked = BlockedOnGA_NoSend;
+ CurrentTSO->block_info.closure = R1.cl;
+
/* stg_gen_block is too heavyweight, use a specialised one */
BLOCK_NP(1);
-#endif
FE_
}
globally visible closure i.e. one with a GA. A BLOCKED_FETCH closure
indicates that a TSO on another PE is waiting for the result of this
computation. Thus, when updating the closure, the result has to be sent
- to that PE. The relevant routines handling that are awaken_blocked_queue
+ to that PE. The relevant routines handling that are awakenBlockedQueue
and blockFetch (for putting BLOCKED_FETCH closure into a BQ).
*/
{
FB_
/* see NON_ENTERABLE_ENTRY_CODE in StgMiscClosures.hc */
- DUMP_ERRMSG("BLOCKED_FETCH object entered!\n");
+ STGCALL2(fprintf,stderr,"BLOCKED_FETCH object entered!\n");
STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);
FE_
}
/* ---------------------------------------------------------------------------
- Time-stamp: <Sat Dec 04 1999 21:28:56 Stardate: [-30]3999.47 hwloidl>
- $Id: Global.c,v 1.2 2000/01/13 14:34:06 hwloidl Exp $
+ Time-stamp: <Mon Mar 27 2000 17:10:57 Stardate: [-30]4568.37 hwloidl>
+ $Id: Global.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
(c) The AQUA/Parade Projects, Glasgow University, 1995
The GdH/APART 624 Projects, Heriot-Watt University, Edinburgh, 1999
#include "Storage.h"
#include "Hash.h"
#include "ParallelRts.h"
+#if defined(DIST)
+#include "Dist.h"
+#endif
/*
@globalAddr@ structures are allocated in chunks to reduce malloc overhead.
//@subsection Global tables and lists
//@cindex thisPE
-int thisPE;
+nat thisPE;
//@menu
//* Free lists::
GALA *gl, *p;
if ((gl = freeGALAList) != NULL) {
+ IF_DEBUG(sanity,
+ ASSERT(gl->ga.weight==0xdead0add);
+ ASSERT(gl->la==0xdead00aa));
freeGALAList = gl->next;
} else {
gl = (GALA *) stgMallocBytes(GCHUNK * sizeof(GALA), "allocGALA");
freeGALAList = gl + 1;
- for (p = freeGALAList; p < gl + GCHUNK - 1; p++)
+ for (p = freeGALAList; p < gl + GCHUNK - 1; p++) {
p->next = p + 1;
+ IF_DEBUG(sanity,
+ p->ga.weight=0xdead0add;
+ p->la=0xdead00aa);
+ }
+ /* last elem in the new block has NULL pointer in link field */
p->next = NULL;
+ IF_DEBUG(sanity,
+ p->ga.weight=0xdead0add;
+ p->la=0xdead00aa);
}
+ IF_DEBUG(sanity,
+ gl->ga.weight=0xdead0add;
+ gl->la=0xdead00aa);
return gl;
}
{
GALA *gala;
- /* We never look for GA's on indirections */
+ /* We never look for GA's on indirections. -- unknown hacker
+ Well, in fact at the moment we do in the new RTS. -- HWL
+ ToDo: unwind INDs when entering them into the hash table
+
ASSERT(IS_INDIRECTION(addr) == NULL);
+ */
if ((gala = lookupHashTable(LAtoGALAtable, (StgWord) addr)) == NULL)
return NULL;
else
}
}
+/* ga becomes non-preferred (e.g. due to CommonUp) */
+void
+GALAdeprecate(ga)
+globalAddr *ga;
+{
+ StgWord pga = PackGA(taskIDtoPE(ga->payload.gc.gtid), ga->payload.gc.slot);
+ GALA *gala;
+
+ gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
+ ASSERT(gala!=NULL);
+ ASSERT(gala->preferred==rtsTrue);
+ gala->preferred==rtsFalse;
+}
+
/*
External references to our globally-visible closures are managed through an
indirection table. The idea is that the closure may move about as the result
//@cindex allocIndirection
static GALA *
-allocIndirection(StgPtr addr)
+allocIndirection(StgClosure *closure)
{
GALA *gala;
if ((gala = freeIndirections) != NULL) {
+ IF_DEBUG(sanity,
+ ASSERT(gala->ga.weight==0xdead0add);
+ ASSERT(gala->la==0xdead00aa));
freeIndirections = gala->next;
} else {
gala = allocGALA();
+ IF_DEBUG(sanity,
+ ASSERT(gala->ga.weight==0xdead0add);
+ ASSERT(gala->la==0xdead00aa));
gala->ga.payload.gc.gtid = mytid;
gala->ga.payload.gc.slot = nextIndirection++;
}
gala->ga.weight = MAX_GA_WEIGHT;
- gala->la = addr;
+ gala->la = closure;
+ IF_DEBUG(sanity,
+ gala->next=0xcccccccc);
return gala;
}
+/*
+ This is only used for sanity checking (see LOOKS_LIKE_SLOT)
+*/
+StgInt
+highest_slot (void) { return nextIndirection; }
+
/*
- Make a local closure at @addr@ globally visible. We have to allocate an
- indirection slot for it, and update both the local address to global address
- and global address to local address maps.
+ Make a local closure globally visible.
+
+ Called from: GlobaliseAndPackGA
+ Args:
+ closure ... closure to be made visible
+ preferred ... should the new GA become the preferred one (normalle=y true)
+
+ Allocate a GALA structure and add it to the (logical) Indirections table,
+ by inserting it into the LAtoGALAtable hash table and putting it onto the
+ liveIndirections list (only if it is preferred).
+
+ We have to allocate an indirection slot for it, and update both the local
+ address to global address and global address to local address maps.
*/
//@cindex makeGlobal
globalAddr *
-makeGlobal(addr, preferred)
-StgClosure *addr;
+makeGlobal(closure, preferred)
+StgClosure *closure;
rtsBool preferred;
{
- GALA *oldGALA = lookupHashTable(LAtoGALAtable, (StgWord) addr);
- GALA *newGALA = allocIndirection((StgPtr)addr);
+ /* check whether we already have a GA for this local closure */
+ GALA *oldGALA = lookupHashTable(LAtoGALAtable, (StgWord) closure);
+ /* create an entry in the LAGA table */
+ GALA *newGALA = allocIndirection((StgPtr)closure);
StgWord pga = PackGA(thisPE, newGALA->ga.payload.gc.slot);
- ASSERT(HEAP_ALLOCED(addr)); // check that addr might point into the heap
+ IF_DEBUG(sanity,
+ ASSERT(newGALA->next==0xcccccccc););
+ // ASSERT(HEAP_ALLOCED(closure)); // check that closure might point into the heap; might be static, though
ASSERT(GALAlookup(&(newGALA->ga)) == NULL);
- newGALA->la = addr;
+ newGALA->la = closure;
newGALA->preferred = preferred;
if (preferred) {
/* The new GA is now the preferred GA for the LA */
if (oldGALA != NULL) {
oldGALA->preferred = rtsFalse;
- (void) removeHashTable(LAtoGALAtable, (StgWord) addr, (void *) oldGALA);
+ (void) removeHashTable(LAtoGALAtable, (StgWord) closure, (void *) oldGALA);
}
- insertHashTable(LAtoGALAtable, (StgWord) addr, (void *) newGALA);
+ insertHashTable(LAtoGALAtable, (StgWord) closure, (void *) newGALA);
}
+ ASSERT(!isOnLiveIndTable(&(newGALA->ga)));
/* put the new GALA entry on the list of live indirections */
newGALA->next = liveIndirections;
liveIndirections = newGALA;
/*
Assign an existing remote global address to an existing closure.
+
+ Called from: Unpack in Pack.c
+ Args:
+ local_closure ... a closure that has just been unpacked
+ remote_ga ... the GA that came with it, ie. the name under which the
+ closure is known while being transferred
+ preferred ... should the new GA become the preferred one (normalle=y true)
+
+ Allocate a GALA structure and add it to the (logical) RemoteGA table,
+ by inserting it into the LAtoGALAtable hash table and putting it onto the
+ liveRemoteGAs list (only if it is preferred).
+
We do not retain the @globalAddr@ structure that's passed in as an argument,
so it can be a static in the calling routine.
*/
//@cindex setRemoteGA
globalAddr *
-setRemoteGA(addr, ga, preferred)
-StgClosure *addr;
-globalAddr *ga;
+setRemoteGA(local_closure, remote_ga, preferred)
+StgClosure *local_closure;
+globalAddr *remote_ga;
rtsBool preferred;
{
- GALA *oldGALA = lookupHashTable(LAtoGALAtable, (StgWord) addr);
+ /* old entry ie the one with the GA generated when sending off the closure */
+ GALA *oldGALA = lookupHashTable(LAtoGALAtable, (StgWord) local_closure);
+ /* alloc new entry and fill it with contents of the newly arrives GA */
GALA *newGALA = allocGALA();
- StgWord pga = PackGA(taskIDtoPE(ga->payload.gc.gtid), ga->payload.gc.slot);
+ StgWord pga = PackGA(taskIDtoPE(remote_ga->payload.gc.gtid),
+ remote_ga->payload.gc.slot);
- ASSERT(ga->payload.gc.gtid != mytid);
- ASSERT(ga->weight > 0);
- ASSERT(GALAlookup(ga) == NULL);
+ ASSERT(remote_ga->payload.gc.gtid != mytid);
+ ASSERT(remote_ga->weight > 0);
+ ASSERT(GALAlookup(remote_ga) == NULL);
- newGALA->ga = *ga;
- newGALA->la = addr;
+ newGALA->ga = *remote_ga;
+ newGALA->la = local_closure;
newGALA->preferred = preferred;
if (preferred) {
/* The new GA is now the preferred GA for the LA */
if (oldGALA != NULL) {
oldGALA->preferred = rtsFalse;
- (void) removeHashTable(LAtoGALAtable, (StgWord) addr, (void *) oldGALA);
+ (void) removeHashTable(LAtoGALAtable, (StgWord) local_closure, (void *) oldGALA);
}
- insertHashTable(LAtoGALAtable, (StgWord) addr, (void *) newGALA);
+ insertHashTable(LAtoGALAtable, (StgWord) local_closure, (void *) newGALA);
}
+
+ ASSERT(!isOnRemoteGATable(&(newGALA->ga)));
+ /* add new entry to the (logical) RemoteGA table */
newGALA->next = liveRemoteGAs;
liveRemoteGAs = newGALA;
insertHashTable(pGAtoGALAtable, pga, (void *) newGALA);
- ga->weight = 0;
-
+ /*
+ The weight carried by the incoming closure is transferred to the newGALA
+ entry (via the structure assign above). Therefore, we have to give back
+ the weight to the GA on the other processor, because that indirection is
+ no longer needed.
+ */
+ remote_ga->weight = 0;
return &(newGALA->ga);
}
*/
//@cindex splitWeight
+#if 0
void
splitWeight(to, from)
globalAddr *to, *from;
{
/* Make sure we have enough weight to split */
- if (from->weight == 1)
+ if (from->weight!=MAX_GA_WEIGHT && from->weight<=3) // fixed by UK in Eden implementation
from = makeGlobal(GALAlookup(from), rtsTrue);
to->payload = from->payload;
- if (from->weight == 0)
+ if (from->weight == MAX_GA_WEIGHT)
to->weight = 1L << (BITS_IN(unsigned) - 1);
else
to->weight = from->weight / 2;
from->weight -= to->weight;
}
-
+#else
+void
+splitWeight(to, from)
+globalAddr *to, *from;
+{
+ /* Make sure we have enough weight to split */
+ /* Splitting at 2 needed, as weight 1 is not legal in packets (UK+KH) */
+
+ if (from->weight / 2 <= 2) /* old: weight== 1 (UK) */
+ from = makeGlobal(GALAlookup(from), rtsTrue);
+
+ to->payload = from->payload;
+
+ if (from->weight <= 1) /* old == 0 (UK) */
+ to->weight = 1L << (BITS_IN(unsigned) - 1);
+ else
+ to->weight = from->weight / 2;
+
+ from->weight -= to->weight;
+}
+#endif
/*
Here, I am returning a bit of weight that a remote PE no longer needs.
*/
taskIDtoPEtable = allocHashTable();
LAtoGALAtable = allocHashTable();
pGAtoGALAtable = allocHashTable();
+#ifdef DIST
+ stickyClosureTable = allocHashTable();
+#endif
}
//@cindex PackGA
When we do a copying collection, we want to evacuate all of the local
entries in the GALA table for which there are outstanding remote
pointers (i.e. for which the weight is not MAX_GA_WEIGHT.)
+ This routine has to be run BEFORE doing the GC proper (it's a
+ ``mark roots'' thing).
*/
//@cindex markLocalGAs
void
StgPtr old_la, new_la;
nat n=0, m=0; // debugging only
- IF_DEBUG(gc,
- belch("@@ markLocalGAs: Marking LIVE INDIRECTIONS in GALA table starting with GALA at %p\n",
+ IF_PAR_DEBUG(tables,
+ belch("@@%%%% markLocalGAs: Marking LIVE INDIRECTIONS in GALA table starting with GALA at %p\n",
liveIndirections);
printLAGAtable());
for (gala = liveIndirections, m=0; gala != NULL; gala = next, m++) {
- IF_DEBUG(gc,
- printGA(&(gala->ga));
- fprintf(stderr, ";@ %d: LA: %p (%s) ",
- m, gala->la, info_type(gala->la)));
- next = gala->next;
- old_la = gala->la;
- ASSERT(gala->ga.payload.gc.gtid == mytid); /* it's supposed to be local */
- if (get_itbl((StgClosure *)old_la)->type == EVACUATED) {
- /* somebody else already evacuated this closure */
- new_la = ((StgEvacuated *)old_la)->evacuee;
- IF_DEBUG(gc,
- belch(" already evacuated to %p\n", new_la));
- } else {
- StgClosure *foo ; // debugging only
- n++;
- IF_PAR_DEBUG(verbose,
- if (IS_INDIRECTION((StgClosure *)old_la))
- belch("{markLocalGAs}Daq ghuH: trying to mark an indirection %p (%s) -> %p (%s); [closure=%p]",
- old_la, info_type(old_la),
- (foo = UNWIND_IND((StgClosure *)old_la)), info_type(foo),
- old_la));
- new_la = MarkRoot(UNWIND_IND((StgClosure *)old_la)); // or just evacuate(old_ga)
- IF_DEBUG(gc,
- belch(" evacuated %p to %p\n", old_la, new_la));
- }
-
- gala->la = new_la;
- /* remove old LA and replace with new LA */
- //(void) removeHashTable(LAtoGALAtable, (StgWord) old_la, (void *) gala);
- //insertHashTable(LAtoGALAtable, (StgWord) new_la, (void *) gala);
-
- gala->next = prev;
- prev = gala;
- }
- liveIndirections = prev; /* list has been reversed during the marking */
-
- IF_PAR_DEBUG(verbose,
- belch("@@ markLocalGAs: %d of %d GALAs marked on PE %x",
- n, m, mytid));
-
- /* -------------------------------------------------------------------- */
-
- n=0; m=0; // debugging only
-
- IF_DEBUG(gc,
- belch("@@ markLocalGAs: Marking LIVE REMOTE GAs in GALA table starting with GALA at %p\n",
- liveRemoteGAs));
-
- for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
- IF_DEBUG(gc,
- printGA(&(gala->ga)));
+ IF_PAR_DEBUG(tables,
+ fputs("@@ ",stderr);
+ printGA(&(gala->ga));
+ fprintf(stderr, ";@ %d: LA: %p (%s) ",
+ m, gala->la, info_type(gala->la)));
next = gala->next;
old_la = gala->la;
- ASSERT(gala->ga.payload.gc.gtid != mytid); /* it's supposed to be remote */
- if (get_itbl((StgClosure *)old_la)->type == EVACUATED) {
- /* somebody else already evacuated this closure */
- new_la = ((StgEvacuated *)old_la)->evacuee;
- } else {
- n++;
- new_la = MarkRoot((StgClosure *)old_la); // or just evacuate(old_ga)
- }
-
- gala->la = new_la;
- /* remove old LA and replace with new LA */
- //(void) removeHashTable(LAtoGALAtable, (StgWord) old_la, (void *) gala);
- //insertHashTable(LAtoGALAtable, (StgWord) new_la, (void *) gala);
-
- gala->next = prev;
- prev = gala;
- }
- liveRemoteGAs = prev; /* list is reversed during marking */
-
- /* If we have any remaining FREE messages to send off, do so now */
- // sendFreeMessages();
-
- IF_DEBUG(gc,
- belch("@@ markLocalGAs: GALA after marking");
- printLAGAtable();
- belch("--------------------------------------"));
-
-}
-
-void
-OLDmarkLocalGAs(rtsBool full)
-{
- extern StgClosure *MarkRootHWL(StgClosure *root);
-
- GALA *gala;
- GALA *next;
- GALA *prev = NULL;
- StgPtr new_la;
- nat n=0, m=0; // debugging only
-
- IF_DEBUG(gc,
- belch("@@ markLocalGAs: Marking entries in GALA table starting with GALA at %p",
- liveIndirections);
- printLAGAtable());
-
- for (gala = liveIndirections; gala != NULL; gala = next) {
- IF_DEBUG(gc,
- printGA(&(gala->ga));
- fprintf(stderr, " LA: %p (%s) ",
- gala->la, info_type(gala->la)));
- next = gala->next;
ASSERT(gala->ga.payload.gc.gtid == mytid); /* it's supposed to be local */
if (gala->ga.weight != MAX_GA_WEIGHT) {
/* Remote references exist, so we must evacuate the local closure */
- StgPtr old_la = gala->la;
-
- if (get_itbl((StgClosure *)old_la)->type != EVACUATED) { // track evacuee!??
+ if (get_itbl((StgClosure *)old_la)->type == EVACUATED) {
+ /* somebody else already evacuated this closure */
+ new_la = ((StgEvacuated *)old_la)->evacuee;
+ IF_PAR_DEBUG(tables,
+ belch(" already evacuated to %p", new_la));
+ } else {
+#if 1
+ /* unwind any indirections we find */
+ StgClosure *foo = UNWIND_IND((StgClosure *)old_la) ; // debugging only
+ //ASSERT(HEAP_ALLOCED(foo));
n++;
- IF_DEBUG(gc,
- fprintf(stderr, " marking as root\n"));
- new_la = MarkRoot((StgClosure *)old_la); // or just evacuate(old_ga)
- //IF_DEBUG(gc,
- // fprintf(stderr, " new LA is %p ", new_la));
- if (!full && gala->preferred && new_la != old_la) {
- IF_DEBUG(gc,
- fprintf(stderr, " replacing %p with %p in LAGA table\n",
- old_la, new_la));
- (void) removeHashTable(LAtoGALAtable, (StgWord) old_la, (void *) gala);
+
+ new_la = MarkRoot(foo); // or just evacuate(old_ga)
+ IF_PAR_DEBUG(tables,
+ belch(" evacuated %p to %p", foo, new_la));
+ //ASSERT(Bdescr(new_la)->evacuated);
+#else
+ new_la = MarkRoot(old_la); // or just evacuate(old_ga)
+ IF_PAR_DEBUG(tables,
+ belch(" evacuated %p to %p", old_la, new_la));
+#endif
+ }
+
+ gala->la = new_la;
+ /* remove old LA and replace with new LA */
+ if (!full && gala->preferred && new_la != old_la) {
+ GALA *q;
+ ASSERT(lookupHashTable(LAtoGALAtable, (StgWord)old_la));
+ (void) removeHashTable(LAtoGALAtable, (StgWord) old_la, (void *) gala);
+ if ((q = lookupHashTable(LAtoGALAtable, (StgWord) new_la))!=NULL) {
+ if (q->preferred && gala->preferred) {
+ q->preferred = rtsFalse;
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
+ new_la, info_type(new_la));
+ printGA(&(q->ga));
+ fputc('\n', stderr));
+ }
+ } else {
insertHashTable(LAtoGALAtable, (StgWord) new_la, (void *) gala);
}
- } else {
- IF_DEBUG(gc,
- fprintf(stderr, " EVAC "));
- new_la = ((StgEvacuated *)old_la)->evacuee;
- IF_DEBUG(gc,
- fprintf(stderr, " replacing %p with %p in LAGA table\n",
- old_la, new_la));
- (void) removeHashTable(LAtoGALAtable, (StgWord) old_la, (void *) gala);
- insertHashTable(LAtoGALAtable, (StgWord) new_la, (void *) gala);
- }
+ IF_PAR_DEBUG(tables,
+ belch("__## Hash table update (%p --> %p): ",
+ old_la, new_la));
+ }
+
gala->next = prev;
prev = gala;
} else {
/* Since we have all of the weight, this GA is no longer needed */
StgWord pga = PackGA(thisPE, gala->ga.payload.gc.slot);
-
- m++;
- IF_DEBUG(gc,
- fprintf(stderr, " freeing slot %d",
- gala->ga.payload.gc.slot));
-
- /* put the now redundant GALA onto the free list */
+
+ IF_PAR_DEBUG(free,
+ belch("@@!! Freeing slot %d",
+ gala->ga.payload.gc.slot));
+ /* put gala on free indirections list */
gala->next = freeIndirections;
freeIndirections = gala;
- /* remove the GALA from the GALA table; now it's just local */
(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
if (!full && gala->preferred)
- (void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
+ (void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
-#ifdef DEBUG
- gala->ga.weight = 0x0d0d0d0d;
- gala->la = (StgWord) 0x0bad0bad;
-#endif
+ IF_DEBUG(sanity,
+ gala->ga.weight = 0xdead0add;
+ gala->la = (StgClosure *) 0xdead00aa);
}
- }
+ } /* for gala ... */
liveIndirections = prev; /* list has been reversed during the marking */
- IF_PAR_DEBUG(verbose,
- belch("@@ markLocalGAs: %d GALAs marked, %d GALAs nuked on PE %x",
+ IF_PAR_DEBUG(tables,
+ belch("@@%%%% markLocalGAs: %d of %d GALAs marked on PE %x",
n, m, mytid));
-
-}
-
-//@cindex RebuildGAtables
-void
-RebuildGAtables(rtsBool full)
-{
- GALA *gala;
- GALA *next;
- GALA *prev;
- StgClosure *closure, *last, *new_closure;
-
- //prepareFreeMsgBuffers();
-
- if (full)
- RebuildLAGAtable();
-
- IF_DEBUG(gc,
- belch("@@ RebuildGAtables: After ReBuilding GALA table starting with GALA at %p",
- liveRemoteGAs);
- printLAGAtable());
}
+/*
+ Traverse the GALA table: for every live remote GA check whether it has been
+ touched during GC; if not it is not needed locally and we can free the
+ closure (i.e. let go of its heap space and send a free message to the
+ PE holding its GA).
+ This routine has to be run AFTER doing the GC proper.
+*/
void
-OLDRebuildGAtables(rtsBool full)
+rebuildGAtables(rtsBool full)
{
GALA *gala;
GALA *next;
prepareFreeMsgBuffers();
+ IF_PAR_DEBUG(tables,
+ belch("@@%%%% rebuildGAtables: rebuilding LIVE REMOTE GAs in GALA table starting with GALA at %p\n",
+ liveRemoteGAs));
+
for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
- IF_DEBUG(gc,
- printGA(&(gala->ga)));
+ IF_PAR_DEBUG(tables,
+ printGA(&(gala->ga)));
next = gala->next;
ASSERT(gala->ga.payload.gc.gtid != mytid); /* it's supposed to be remote */
closure = (StgClosure *) (gala->la);
-
- /*
- * If the old closure has not been forwarded, we let go. Note that this
- * approach also drops global aliases for PLCs.
- */
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, " %p (%s) ",
+ (StgClosure *)closure, info_type(closure)));
if (!full && gala->preferred)
(void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
/* Follow indirection chains to the end, just in case */
+ // should conform with unwinding in markLocalGAs
closure = UNWIND_IND(closure);
/*
- if (get_itbl(closure)->type != EVACUATED) { // (new_closure = isAlive(closure)) == NULL) { // (W_) Forward_Ref_info)
- // closure is not alive any more, thus remove GA
+ If closure has been evacuated it is live; otherwise it's dead and we
+ can nuke the GA attached to it in the LAGA table.
+ This approach also drops global aliases for PLCs.
+ */
+
+ if (get_itbl(closure)->type == EVACUATED) {
+ closure = ((StgEvacuated *)closure)->evacuee;
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, " EVAC %p (%s)\n",
+ closure, info_type(closure)));
+ } else {
+ /* closure is not alive any more, thus remove GA and send free msg */
int pe = taskIDtoPE(gala->ga.payload.gc.gtid);
StgWord pga = PackGA(pe, gala->ga.payload.gc.slot);
- IF_DEBUG(gc,
- fprintf(stderr, " (LA: %p (%s)) is unused on this PE -> sending free\n",
- closure, info_type(closure)));
+ /* check that the block containing this closure is not in to-space */
+ //ASSERT(Bdescr(closure)->evacuated==0);
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, " !EVAC %p (%s); sending free to PE %d\n",
+ closure, info_type(closure), pe));
(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
freeRemoteGA(pe, &(gala->ga));
gala->next = freeGALAList;
freeGALAList = gala;
- } else {
- */
- if (get_itbl(closure)->type == EVACUATED) {
- IF_DEBUG(gc,
- fprintf(stderr, " EVAC %p (%s)\n",
- closure, info_type(closure)));
- closure = ((StgEvacuated *)closure)->evacuee;
- } else {
- IF_DEBUG(gc,
- fprintf(stderr, " !EVAC %p (%s)\n",
- closure, info_type(closure)));
+ IF_DEBUG(sanity,
+ gala->ga.weight = 0xdead0add;
+ gala->la = 0xdead00aa);
+ continue;
}
gala->la = closure;
- if (!full && gala->preferred)
- insertHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
+ if (!full && gala->preferred) {
+ GALA *q;
+ if ((q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la))!=NULL) {
+ if (q->preferred && gala->preferred) {
+ q->preferred = rtsFalse;
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
+ gala->la, info_type(gala->la));
+ printGA(&(q->ga));
+ fputc('\n', stderr));
+ }
+ } else {
+ insertHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
+ }
+ }
gala->next = prev;
prev = gala;
}
/* If we have any remaining FREE messages to send off, do so now */
sendFreeMessages();
+ IF_DEBUG(sanity,
+ checkFreeGALAList();
+ checkFreeIndirectionsList());
+
if (full)
- RebuildLAGAtable();
+ rebuildLAGAtable();
- IF_DEBUG(gc,
- belch("@@ RebuildGAtables: After ReBuilding GALA table starting with GALA at %p",
+ IF_PAR_DEBUG(tables,
+ belch("@#%%%% rebuildGAtables: After ReBuilding GALA table starting with GALA at %p",
liveRemoteGAs);
printLAGAtable());
}
/*
Rebuild the LA->GA table, assuming that the addresses in the GALAs are
correct.
+ A word on the lookupHashTable check in both loops:
+ After GC we may end up with 2 preferred GAs for the same LA! For example,
+ if we received a closure whose GA already exists on this PE we CommonUp
+ both closures, making one an indirection to the other. Before GC everything
+ is fine: one preferred GA refers to the IND, the other preferred GA refers
+ to the closure it points to. After GC, however, we have short cutted the
+ IND and suddenly we have 2 preferred GAs for the same closure. We detect
+ this case in the loop below and deprecate one GA, so that we always just
+ have one preferred GA per LA.
*/
-//@cindex RebuildLAGAtable
+//@cindex rebuildLAGAtable
void
-RebuildLAGAtable(void)
+rebuildLAGAtable(void)
{
GALA *gala;
nat n=0, m=0; // debugging
freeHashTable(LAtoGALAtable, NULL);
LAtoGALAtable = allocHashTable();
- IF_DEBUG(gc,
- belch("@@ RebuildLAGAtable: new LAGA table at %p",
+ IF_PAR_DEBUG(tables,
+ belch("@@%%%% rebuildLAGAtable: new LAGA table at %p",
LAtoGALAtable));
for (gala = liveIndirections; gala != NULL; gala = gala->next) {
n++;
- if (gala->preferred)
+ if (gala->preferred) {
+ GALA *q;
+ if (q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la)) {
+ if (q->preferred && gala->preferred) {
+ /* this deprecates q (see also GALAdeprecate) */
+ q->preferred = rtsFalse;
+ (void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *)q);
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
+ gala->la, info_type(gala->la));
+ printGA(&(q->ga));
+ fputc('\n', stderr));
+ }
+ }
insertHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
+ }
}
for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
m++;
- if (gala->preferred)
+ if (gala->preferred) {
+ GALA *q;
+ if (q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la)) {
+ if (q->preferred && gala->preferred) {
+ /* this deprecates q (see also GALAdeprecate) */
+ q->preferred = rtsFalse;
+ (void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *)q);
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
+ gala->la, info_type(gala->la));
+ printGA(&(q->ga));
+ fputc('\n', stderr));
+ }
+ }
insertHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
+ }
}
- IF_DEBUG(gc,
- belch("@@ RebuildLAGAtable: inserted %d entries from liveIndirections and %d entries from liveRemoteGAs",
+ IF_PAR_DEBUG(tables,
+ belch("@@%%%% rebuildLAGAtable: inserted %d entries from liveIndirections and %d entries from liveRemoteGAs",
n,m));
-
}
//@node Debugging routines, Index, GC functions for GALA tables, Global Address Manipulation
Printing the LA->GA table.
*/
-//@cindex DebugPrintLAGAtable
+//@cindex printLiveIndTable
void
-printLAGAtable(void)
+printLiveIndTable(void)
{
- GALA *gala;
- nat n=0, m=0; // debugging
+ GALA *gala, *q;
+ nat n=0; // debugging
- belch("@@ LAGAtable (%p) with liveIndirections=%p, liveRemoteGAs=%p:",
- LAtoGALAtable, liveIndirections, liveRemoteGAs);
+ belch("@@%%%%:: logical LiveIndTable (%p) (liveIndirections=%p):",
+ LAtoGALAtable, liveIndirections);
for (gala = liveIndirections; gala != NULL; gala = gala->next) {
n++;
printGALA(gala);
- fputc('\n', stderr);
+ /* check whether this gala->la is hashed into the LAGA table */
+ q = lookupHashTable(LAtoGALAtable, (StgWord)(gala->la));
+ fprintf(stderr, "\t%s\n", (q==NULL) ? "...." : (q==gala) ? "====" : "####");
+ //ASSERT(lookupHashTable(LAtoGALAtable, (StgWord)(gala->la)));
}
+ belch("@@%%%%:: %d live indirections",
+ n);
+}
+
+void
+printRemoteGATable(void)
+{
+ GALA *gala, *q;
+ nat m=0; // debugging
+
+ belch("@@%%%%:: logical RemoteGATable (%p) (liveRemoteGAs=%p):",
+ LAtoGALAtable, liveRemoteGAs);
for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
m++;
printGALA(gala);
- fputc('\n', stderr);
+ /* check whether this gala->la is hashed into the LAGA table */
+ q = lookupHashTable(LAtoGALAtable, (StgWord)(gala->la));
+ fprintf(stderr, "\t%s\n", (q==NULL) ? "...." : (q==gala) ? "====" : "####");
+ // ASSERT(lookupHashTable(LAtoGALAtable, (StgWord)(gala->la)));
}
- belch("@@ LAGAtable has %d liveIndirections entries and %d liveRemoteGAs entries",
- n, m);
+ belch("@@%%%%:: %d remote GAs",
+ m);
+}
+
+//@cindex printLAGAtable
+void
+printLAGAtable(void)
+{
+ belch("@@%%: LAGAtable (%p) with liveIndirections=%p, liveRemoteGAs=%p:",
+ LAtoGALAtable, liveIndirections, liveRemoteGAs);
+
+ printLiveIndTable();
+ printRemoteGATable();
}
+/*
+ Check whether a GA is already in a list.
+*/
+rtsBool
+isOnLiveIndTable(globalAddr *ga)
+{
+ GALA *gala;
+
+ for (gala = liveIndirections; gala != NULL; gala = gala->next)
+ if (gala->ga.weight==ga->weight &&
+ gala->ga.payload.gc.slot==ga->payload.gc.slot &&
+ gala->ga.payload.gc.gtid==ga->payload.gc.gtid)
+ return rtsTrue;
+
+ return rtsFalse;
+}
+
+rtsBool
+isOnRemoteGATable(globalAddr *ga)
+{
+ GALA *gala;
+
+ for (gala = liveRemoteGAs; gala != NULL; gala = gala->next)
+ if (gala->ga.weight==ga->weight &&
+ gala->ga.payload.gc.slot==ga->payload.gc.slot &&
+ gala->ga.payload.gc.gtid==ga->payload.gc.gtid)
+ return rtsTrue;
+
+ return rtsFalse;
+}
+
+/*
+ Sanity check for free lists.
+*/
+void
+checkFreeGALAList(void) {
+ GALA *gl;
+
+ for (gl=freeGALAList; gl != NULL; gl=gl->next) {
+ ASSERT(gl->ga.weight==0xdead0add);
+ ASSERT(gl->la==0xdead00aa);
+ }
+}
+
+void
+checkFreeIndirectionsList(void) {
+ GALA *gl;
+
+ for (gl=freeIndirections; gl != NULL; gl=gl->next) {
+ ASSERT(gl->ga.weight==0xdead0add);
+ ASSERT(gl->la==0xdead00aa);
+ }
+}
#endif /* PAR -- whole file */
//@node Index, , Debugging routines, Global Address Manipulation
//@subsection Index
//@index
+//* DebugPrintLAGAtable:: @cindex\s-+DebugPrintLAGAtable
//* GALAlookup:: @cindex\s-+GALAlookup
//* LAGAlookup:: @cindex\s-+LAGAlookup
//* LAtoGALAtable:: @cindex\s-+LAtoGALAtable
//* PackGA:: @cindex\s-+PackGA
-//* RebuildGAtables:: @cindex\s-+RebuildGAtables
-//* RebuildLAGAtable:: @cindex\s-+RebuildLAGAtable
//* addWeight:: @cindex\s-+addWeight
//* allocGALA:: @cindex\s-+allocGALA
//* allocIndirection:: @cindex\s-+allocIndirection
//* markLocalGAs:: @cindex\s-+markLocalGAs
//* nextIndirection:: @cindex\s-+nextIndirection
//* pGAtoGALAtable:: @cindex\s-+pGAtoGALAtable
+//* printGA:: @cindex\s-+printGA
+//* printGALA:: @cindex\s-+printGALA
+//* rebuildLAGAtable:: @cindex\s-+rebuildLAGAtable
//* registerTask:: @cindex\s-+registerTask
//* setRemoteGA:: @cindex\s-+setRemoteGA
//* splitWeight:: @cindex\s-+splitWeight
/*
- Time-stamp: <Sat Dec 11 1999 17:25:27 Stardate: [-30]4033.42 software>
- $Id: GranSim.c,v 1.2 2000/01/13 14:34:06 hwloidl Exp $
+ Time-stamp: <Mon Mar 20 2000 19:18:25 Stardate: [-30]4534.02 hwloidl>
+ $Id: GranSim.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
Variables and functions specific to GranSim the parallelism simulator
for GPH.
#include "GranSim.h"
#include "ParallelRts.h"
#include "ParallelDebug.h"
+#include "Sparks.h"
#include "Storage.h" // for recordMutable
PEs where_is(StgClosure *node);
static rtsBool stealSomething(PEs proc, rtsBool steal_spark, rtsBool steal_thread);
-static inline rtsBool stealSpark(PEs proc);
-static inline rtsBool stealThread(PEs proc);
+static rtsBool stealSpark(PEs proc);
+static rtsBool stealThread(PEs proc);
static rtsBool stealSparkMagic(PEs proc);
static rtsBool stealThreadMagic(PEs proc);
/* subsumed by stealSomething
{
PEs i;
for (i = 0; i < RtsFlags.GranFlags.proc && !IS_LOCAL_TO(ga, i); i++);
- ASSERT(0<=i && i<RtsFlags.GranFlags.proc);
+ ASSERT(i<RtsFlags.GranFlags.proc);
return (i);
}
// ToDo: traverse_eventw_for_gc if GUM-Fetching!!! HWL
belch("ghuH: packets in BulkFetching not marked as roots; mayb be fatal");
else
- event->node = (StgTSO *)MarkRoot((StgClosure *)event->node);
+ event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
break;
case GlobalBlock:
event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
Prune all ContinueThread events related to tso or node in the eventq.
Currently used if a thread leaves STG land with ThreadBlocked status,
i.e. it blocked on a closure and has been put on its blocking queue. It
- will be reawakended via a call to awaken_blocked_queue. Until then no
+ will be reawakended via a call to awakenBlockedQueue. Until then no
event effecting this tso should appear in the eventq. A bit of a hack,
because ideally we shouldn't generate such spurious ContinueThread events
in the first place.
endThread(StgTSO *tso, PEs proc)
{
ASSERT(procStatus[proc]==Busy); // coming straight out of STG land
- ASSERT(tso->whatNext==ThreadComplete);
+ ASSERT(tso->what_next==ThreadComplete);
// ToDo: prune ContinueThreads for this TSO from event queue
DumpEndEvent(proc, tso, rtsFalse /* not mandatory */);
fprintf(RtsFlags.GcFlags.statsFile,"***** veQ boSwI' PackNearbyGraph(node %p, tso %p (%d))\n",
node, tso, tso->id);
# endif
+ barf("//// do_the_fetchnode: out of heap after handleFetchRequest; ToDo: call GarbageCollect()");
prepend_event(event);
- GarbageCollect(GetRoots);
+ performGC(); // GarbageCollect(GetRoots);
// HWL: ToDo: check whether a ContinueThread has to be issued
// HWL old: ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
-# if defined(GRAN_CHECK) && defined(GRAN)
+# if 0 && defined(GRAN_CHECK) && defined(GRAN)
if (RtsFlags.GcFlags.giveStats) {
fprintf(RtsFlags.GcFlags.statsFile,"***** SAVE_Hp=%p, SAVE_HpLim=%p, PACK_HEAP_REQUIRED=%d\n",
Hp, HpLim, 0) ; // PACK_HEAP_REQUIRED); ???
within GranSimBlock;
since tso is both in the EVQ and the BQ for node, we have to take it out
of the BQ first before we can handle the FetchReply;
- ToDo: special cases in awaken_blocked_queue, since the BQ magically moved.
+ ToDo: special cases in awakenBlockedQueue, since the BQ magically moved.
*/
- if (tso->blocked_on!=(StgClosure*)NULL) {
+ if (tso->block_info.closure!=(StgClosure*)NULL) {
IF_GRAN_DEBUG(bq,
belch("## ghuH: TSO %d (%p) in FetchReply is blocked on node %p (shouldn't happen AFAIK)",
tso->id, tso, node));
tso->gran.sparkname, spark_queue_len(proc));
*/
+ ASSERT(OutstandingFetches[proc] > 0);
--OutstandingFetches[proc];
- ASSERT(OutstandingFetches[proc] >= 0);
new_event(proc, proc, CurrentTime[proc],
ResumeThread,
event->tso, (RtsFlags.GranFlags.DoBulkFetching ?
creator = event->creator; /* proc that requested work */
rtsSparkQ spark = event->spark;
/* ToDo: check that this size is safe -- HWL */
+#if 0
+ ToDo: check available heap
+
nat req_heap = sizeofW(StgTSO) + MIN_STACK_WORDS;
// add this? -- HWL:RtsFlags.ConcFlags.stkChunkSize;
+#endif
IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the Findwork\n"));
thread. This is a conservative estimate of the required heap.
This eliminates special checks for GC around NewThread within
ActivateSpark. */
-
+
+#if 0
+ ToDo: check available heap
+
if (Hp + req_heap > HpLim ) {
IF_DEBUG(gc,
belch("GC: Doing GC from within Findwork handling (that's bloody dangerous if you ask me)");)
procStatus[CurrentProc]=Idle;
return;
}
+#endif
if ( RtsFlags.GranFlags.DoAlwaysCreateThreads ||
RtsFlags.GranFlags.Fishing ||
graph = PackOneNode(node, tso, &size);
new_event(from, to, CurrentTime[to],
FetchReply,
- tso, graph, (rtsSpark*)NULL);
+ tso, (StgClosure *)graph, (rtsSpark*)NULL);
} else {
new_event(from, to, CurrentTime[to],
FetchReply,
/* The tso requesting the node is blocked and cannot be on a run queue */
ASSERT(!is_on_queue(tso, from));
-
- if ((graph = PackNearbyGraph(node, tso, &size)) == NULL)
+
+ // ToDo: check whether graph is ever used as an rtsPackBuffer!!
+ if ((graph = (StgClosure *)PackNearbyGraph(node, tso, &size)) == NULL)
return (OutOfHeap); /* out of heap */
/* Actual moving/copying of node is done on arrival; see FETCHREPLY */
/* Put ourselves on the blocking queue for this black hole */
// tso->link=END_TSO_QUEUE; not necessary; see assertion above
((StgBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)tso;
- tso->blocked_on = bh;
+ tso->block_info.closure = bh;
recordMutable((StgMutClosure *)bh);
break;
{
G_PRINT_NODE(bh);
barf("Qagh: thought %p was a black hole (IP %p (%s))",
- bh, info, info_type(get_itbl(bh)));
+ bh, info, info_type(bh));
}
}
return (Ok);
Steal a spark (piece of work) from any processor and bring it to proc.
*/
//@cindex stealSpark
-static inline rtsBool
+static rtsBool
stealSpark(PEs proc) { stealSomething(proc, rtsTrue, rtsFalse); }
/*
Steal a thread from any processor and bring it to proc i.e. thread migration
*/
//@cindex stealThread
-static inline rtsBool
+static rtsBool
stealThread(PEs proc) { stealSomething(proc, rtsFalse, rtsTrue); }
/*
stealSparkMagic(proc)
PEs proc;
{
- PEs p, i, j, n, first, upb;
- rtsSpark *spark, *next;
+ PEs p=0, i=0, j=0, n=0, first, upb;
+ rtsSpark *spark=NULL, *next;
PEs pes_by_time[MAX_PROC];
rtsBool stolen = rtsFalse;
rtsTime stealtime;
stealThreadMagic(proc)
PEs proc;
{
- PEs p, i, j, n, first, upb;
- StgTSO *tso;
+ PEs p=0, i=0, j=0, n=0, first, upb;
+ StgTSO *tso=END_TSO_QUEUE;
PEs pes_by_time[MAX_PROC];
rtsBool stolen = rtsFalse;
rtsTime stealtime;
double fishdelay, sparkdelay, latencydelay;
fishdelay = (double)RtsFlags.GranFlags.proc/2;
sparkdelay = fishdelay -
- ((fishdelay-1)/(double)(RtsFlags.GranFlags.proc-1))*(double)idlers();
+ ((fishdelay-1.0)/(double)(RtsFlags.GranFlags.proc-1))*((double)idlers());
latencydelay = sparkdelay*((double)RtsFlags.GranFlags.Costs.latency);
return((rtsTime)latencydelay);
PEs proc;
StgClosure *node;
{
- PEs node_proc = where_is(node), tso_proc = where_is(tso);
+ PEs node_proc = where_is(node),
+ tso_proc = where_is((StgClosure *)tso);
ASSERT(tso_proc==CurrentProc);
// ASSERT(node_proc==CurrentProc);
/* --------------------------------------------------------------------------
- Time-stamp: <Sat Dec 04 1999 01:26:45 Stardate: [-30]3995.30 hwloidl>
- $Id: GranSimRts.h,v 1.2 2000/01/13 14:34:07 hwloidl Exp $
+ Time-stamp: <Wed Mar 29 2000 19:09:41 Stardate: [-30]4578.78 hwloidl>
+ $Id: GranSimRts.h,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
Variables and functions specific to GranSim.
----------------------------------------------------------------------- */
/* Communication related routines */
rtsFetchReturnCode fetchNode(StgClosure* node, PEs from, PEs to);
rtsFetchReturnCode handleFetchRequest(StgClosure* node, PEs curr_proc, PEs p, StgTSO* tso);
-rtsFetchReturnCode blockFetch(StgTSO* tso, PEs proc, StgClosure* bh);
void handleIdlePEs(void);
long int random(void); /* used in stealSpark() and stealThread() in GranSim.c */
/* ----------------------------------------------------------------------------
- * Time-stamp: <Wed Jan 12 2000 13:32:25 Stardate: [-30]4193.86 hwloidl>
- * $Id: HLComms.c,v 1.2 2000/01/13 14:34:07 hwloidl Exp $
+ * Time-stamp: <Wed Mar 29 2000 19:35:36 Stardate: [-30]4578.87 hwloidl>
+ * $Id: HLComms.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
*
* High Level Communications Routines (HLComms.lc)
*
p[5] = (long) gagamap->payload.gc.slot;
gagamap++;
}
- IF_PAR_DEBUG(ack,
+ IF_PAR_DEBUG(schedule,
belch(",, [%x] Sending Ack (%d pairs) to PE %x\n",
mytid, ngas, task));
*ngas = GAarraysize / 6;
- IF_PAR_DEBUG(ack,
+ IF_PAR_DEBUG(schedule,
belch(",, [%x] Unpacking Ack (%d pairs) on %x\n",
mytid, *ngas, mytid));
*/
/*
- * blockFetch blocks a BlockedFetch node on some kind of black hole.
- */
-//@cindex blockFetch
-static void
-blockFetch(StgBlockedFetch *bf, StgClosure *bh) {
- bf->node = bh;
- switch (get_itbl(bh)->type) {
- case BLACKHOLE:
- bf->link = END_BQ_QUEUE;
- //((StgBlockingQueue *)bh)->header.info = &BLACKHOLE_BQ_info;
- SET_INFO(bh, &BLACKHOLE_BQ_info); // turn closure into a blocking queue
- ((StgBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
-
- // put bh on the mutables list
- recordMutable((StgMutClosure *)bh);
-
-# if 0
- /*
- * If we modify a black hole in the old generation, we have to
- * make sure it goes on the mutables list
- */
-
- if (bh <= StorageMgrInfo.OldLim) {
- MUT_LINK(bh) = (StgWord) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = bh;
- } else
- MUT_LINK(bh) = MUT_NOT_LINKED;
-# endif
- break;
-
- case BLACKHOLE_BQ:
- /* enqueue bf on blocking queue of closure bh */
- bf->link = ((StgBlockingQueue *)bh)->blocking_queue;
- ((StgBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
-
- // put bh on the mutables list; ToDo: check
- recordMutable((StgMutClosure *)bh);
- break;
-
- case FETCH_ME_BQ:
- /* enqueue bf on blocking queue of closure bh */
- bf->link = ((StgFetchMeBlockingQueue *)bh)->blocking_queue;
- ((StgFetchMeBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
-
- // put bh on the mutables list; ToDo: check
- recordMutable((StgMutClosure *)bh);
- break;
-
- case RBH:
- /* enqueue bf on blocking queue of closure bh */
- bf->link = ((StgRBH *)bh)->blocking_queue;
- ((StgRBH *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
-
- // put bh on the mutables list; ToDo: check
- recordMutable((StgMutClosure *)bh);
- break;
-
- default:
- barf("Panic (blockFetch): thought %p was a black hole (IP %#lx, %s)",
- (StgClosure *)bh, get_itbl((StgClosure *)bh),
- info_type((StgClosure *)bh));
- }
- IF_PAR_DEBUG(verbose,
- belch("## blockFetch: after block the BQ of %p (%s) is:",
- bh, info_type(bh));
- print_bq(bh));
-}
-
-
-/*
* processFetches constructs and sends resume messages for every
* BlockedFetch which is ready to be awakened.
* awaken_blocked_queue (in Schedule.c) is responsible for moving
//@cindex processFetches
void
processFetches(void) {
- StgBlockedFetch *bf;
- StgClosure *closure, *next;
+ StgBlockedFetch *bf, *next;
+ StgClosure *closure;
StgInfoTable *ip;
globalAddr rga;
static rtsPackBuffer *packBuffer;
IF_PAR_DEBUG(verbose,
- belch("__ processFetches: %d pending fetches",
- pending_fetches_len()));
+ belch("____ processFetches: %d pending fetches (root @ %p)",
+ pending_fetches_len(), PendingFetches));
for (bf = PendingFetches;
bf != END_BF_QUEUE;
- bf=(StgBlockedFetch *)(bf->link)) {
+ bf=next) {
/* the PendingFetches list contains only BLOCKED_FETCH closures */
ASSERT(get_itbl(bf)->type==BLOCKED_FETCH);
+ /* store link (we might overwrite it via blockFetch later on */
+ next = (StgBlockedFetch *)(bf->link);
/*
* Find the target at the end of the indirection chain, and
*/
closure = bf->node;
/*
- HACK 312: bf->node may have been evacuated since filling it; follow
- the evacuee in this case; the proper way to handle this is to
- traverse the blocking queue and update the node fields of
- BLOCKED_FETCH entries when evacuating an BLACKHOLE_BQ, FETCH_ME_BQ
- or RBH (but it's late and I'm tired)
+ We evacuate BQs and update the node fields where necessary in GC.c
+ So, if we find an EVACUATED closure, something has gone Very Wrong
+ (and therefore we let the RTS crash most ungracefully).
*/
- if (get_itbl(closure)->type == EVACUATED)
- closure = ((StgEvacuated *)closure)->evacuee;
+ ASSERT(get_itbl(closure)->type != EVACUATED);
+ // closure = ((StgEvacuated *)closure)->evacuee;
- while ((next = IS_INDIRECTION(closure)) != NULL) { closure = next; }
+ closure = UNWIND_IND(closure);
+ //while ((ind = IS_INDIRECTION(closure)) != NULL) { closure = ind; }
ip = get_itbl(closure);
if (ip->type == FETCH_ME) {
sendFetch(((StgFetchMe *)closure)->ga, &rga, 0 /* load */);
- IF_PAR_DEBUG(forward,
- belch("__ processFetches: Forwarding fetch from %lx to %lx",
+ IF_PAR_DEBUG(fetch,
+ belch("__-> processFetches: Forwarding fetch from %lx to %lx",
mytid, rga.payload.gc.gtid));
} else if (IS_BLACK_HOLE(closure)) {
IF_PAR_DEBUG(verbose,
- belch("__ processFetches: trying to send a BLACK_HOLE => doign a blockFetch on closure %p (%s)",
+ belch("__++ processFetches: trying to send a BLACK_HOLE => doing a blockFetch on closure %p (%s)",
closure, info_type(closure)));
bf->node = closure;
blockFetch(bf, closure);
packBuffer = gumPackBuffer;
IF_PAR_DEBUG(verbose,
- belch("__ processFetches: PackNearbyGraph of closure %p (%s)",
+ belch("__*> processFetches: PackNearbyGraph of closure %p (%s)",
closure, info_type(closure)));
if ((packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size)) == NULL) {
bf->link = (StgBlockingQueueElement *)PendingFetches;
PendingFetches = (StgBlockedFetch *)bf;
// ToDo: check that nothing more has to be done to prepare for GC!
+ barf("processFetches: out of heap while packing graph; ToDo: call GC here");
GarbageCollect(GetRoots);
bf = PendingFetches;
PendingFetches = (StgBlockedFetch *)(bf->link);
/* the old version did this in the FETCH_ME entry code */
sendFetch(&theGlobalFromGA, &theGlobalToGA, 0/*load*/);
-#if DEBUG
- theGlobalFromGA.payload.gc.gtid = 0;
- theGlobalToGA.payload.gc.gtid = 0;
-#endif DEBUG
}
#endif
ASSERT(origPE != mytid);
IF_PAR_DEBUG(fish,
- belch("$$ [%x] processing fish; %d sparks available",
- mytid, spark_queue_len(ADVISORY_POOL)));
- while ((spark = findLocalSpark(rtsTrue)) != NULL) {
+ belch("$$__ processing fish; %d sparks available",
+ spark_queue_len(&(MainRegTable.rSparks))));
+ while ((spark = findSpark()) != NULL) {
nat size;
// StgClosure *graph;
IF_PAR_DEBUG(fish,
belch("$$ GC while trying to satisfy FISH via PackNearbyGraph of node %p",
(StgClosure *)spark));
+ barf("processFish: out of heap while packing graph; ToDo: call GC here");
GarbageCollect(GetRoots);
/* Now go back and try again */
} else {
IF_PAR_DEBUG(fish,
- belch("$$ [%x] Replying to FISH from %x by sending graph @ %p (%s)",
- mytid, origPE,
+ belch("$$-- Replying to FISH from %x by sending graph @ %p (%s)",
+ origPE,
(StgClosure *)spark, info_type((StgClosure *)spark)));
sendSchedule(origPE, size, packBuffer);
disposeSpark(spark);
}
if (spark == (rtsSpark)NULL) {
IF_PAR_DEBUG(fish,
- belch("$$ [%x] No sparks available for FISH from %x",
- mytid, origPE));
+ belch("$$^^ No sparks available for FISH from %x",
+ origPE));
/* We have no sparks to give */
if (age < FISH_LIFE_EXPECTANCY)
/* and the fish is atill young, send it to another PE to look for work */
unpackFetch(&ga, &rga, &load);
IF_PAR_DEBUG(fetch,
- belch("%% [%x] Rcvd Fetch for ((%x, %d, 0)), Resume ((%x, %d, %x)) (load %d) from %x",
- mytid,
+ belch("%%%%__ Rcvd Fetch for ((%x, %d, 0)), Resume ((%x, %d, %x)) (load %d) from %x",
ga.payload.gc.gtid, ga.payload.gc.slot,
rga.payload.gc.gtid, rga.payload.gc.slot, rga.weight, load,
rga.payload.gc.gtid));
StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)GALAlookup(&rga);
IF_PAR_DEBUG(fetch,
- belch("%% [%x] Fetch returned to sending PE; closure=%p (%s); receiver=%p (%s)",
- mytid, closure, info_type(closure), fmbq, info_type(fmbq)));
+ belch("%%%%== Fetch returned to sending PE; closure=%p (%s); receiver=%p (%s)",
+ closure, info_type(closure), fmbq, info_type(fmbq)));
/* We may have already discovered that the fetch target is our own. */
if ((StgClosure *)fmbq != closure)
CommonUp((StgClosure *)fmbq, closure);
blockFetch(bf, closure);
IF_PAR_DEBUG(fetch,
- belch("%% [%x] Blocking Fetch ((%x, %d, %x)) on %p (%s)",
- mytid,
+ belch("%%++ Blocking Fetch ((%x, %d, %x)) on %p (%s)",
rga.payload.gc.gtid, rga.payload.gc.slot, rga.weight,
closure, info_type(closure)));
} else {
rtsPackBuffer *buffer = (rtsPackBuffer *)NULL;
if ((buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size)) == NULL) {
+ barf("processFetch: out of heap while packing graph; ToDo: call GC here");
GarbageCollect(GetRoots);
closure = GALAlookup(&ga);
buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size);
buffer = (StgWord *)gumPackBuffer;
unpackFree(&nelem, buffer);
IF_PAR_DEBUG(free,
- belch("!! [%x] Rcvd Free (%d GAs)", mytid, nelem / 2));
+ belch("!!__ Rcvd Free (%d GAs)", nelem / 2));
ga.payload.gc.gtid = mytid;
for (i = 0; i < nelem;) {
ga.weight = (rtsWeight) buffer[i++];
ga.payload.gc.slot = (int) buffer[i++];
IF_PAR_DEBUG(free,
- fprintf(stderr, "!! [%x] Processing free ", mytid);
+ fprintf(stderr, "!!-- Processing free ");
printGA(&ga);
fputc('\n', stderr);
);
unpackResume(&lga, &nelem, (StgPtr)packBuffer);
IF_PAR_DEBUG(resume,
- fprintf(stderr, "[] [%x] Rcvd Resume for ", mytid);
+ fprintf(stderr, "[]__ Rcvd Resume for ");
printGA(&lga);
fputc('\n', stderr);
PrintPacket((rtsPackBuffer *)packBuffer));
if (get_itbl((StgClosure *)bqe)->type == TSO)
DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(sender),
GR_REPLY, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
- 0, spark_queue_len(ADVISORY_POOL));
+ 0, spark_queue_len(&(MainRegTable.rSparks)));
}
newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
if (get_itbl(old)->type == FETCH_ME_BQ)
CommonUp(old, newGraph);
- IF_PAR_DEBUG(resume,
+ IF_PAR_DEBUG(tables,
DebugPrintGAGAMap(gagamap, nGAs));
sendAck(sender, nGAs, gagamap);
packBuffer = gumPackBuffer; /* HWL */
unpackSchedule(&nelem, packBuffer);
- IF_PAR_DEBUG(schedule,
- belch("-- [%x] Rcvd Schedule (%d elems)", mytid, nelem);
+ IF_PAR_DEBUG(packet,
+ belch("--__ Rcvd Schedule (%d elems)", nelem);
PrintPacket(packBuffer));
/*
SAVE_Hp -= space_required;
}
*/
- // ToDo: check whether GC is necessary !!!!!!!!!!!!!!!!!!!!!1
+ // ToDo: check whether GC is necessary !!!!!!!!!!!!!!!!!!!!!
newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
ASSERT(newGraph != NULL);
- success = add_to_spark_queue(newGraph, rtsFalse);
+ success = add_to_spark_queue(newGraph, &(MainRegTable.rSparks));
- IF_PAR_DEBUG(pack,
+ IF_PAR_DEBUG(packet,
if (success)
- belch("+* added spark to unpacked graph %p; %d sparks available on [%x]",
- newGraph, spark_queue_len(ADVISORY_POOL), mytid);
+ belch("--^^ added spark to unpacked graph %p; %d sparks available on [%x]",
+ newGraph, spark_queue_len(&(MainRegTable.rSparks)), mytid);
else
- belch("+* received non-sparkable closure %p; nothing added to spark pool; %d sparks available on [%x]",
- newGraph, spark_queue_len(ADVISORY_POOL), mytid);
- belch("-* Unpacked graph with root at %p (%s):",
+ belch("--^^ received non-sparkable closure %p; nothing added to spark pool; %d sparks available on [%x]",
+ newGraph, spark_queue_len(&(MainRegTable.rSparks)), mytid);
+ belch("*< Unpacked graph with root at %p (%s):",
newGraph, info_type(newGraph));
PrintGraph(newGraph, 0));
- IF_PAR_DEBUG(pack,
+ IF_PAR_DEBUG(tables,
DebugPrintGAGAMap(gagamap, nGAs));
if (nGAs > 0)
unpackAck(&nGAs, gagamap);
- IF_PAR_DEBUG(ack,
- belch(",, [%x] Rcvd Ack (%d pairs)", mytid, nGAs);
+ IF_PAR_DEBUG(tables,
+ belch(",,,, Rcvd Ack (%d pairs)", nGAs);
DebugPrintGAGAMap(gagamap, nGAs));
+ IF_DEBUG(sanity,
+ checkGAGAMap(gagamap, nGAs));
+
/*
* For each (oldGA, newGA) pair, set the GA of the corresponding
* thunk to the newGA, convert the thunk to a FetchMe, and return
}
(void) addWeight(gaga);
}
+
+ /* check the sanity of the LAGA and GALA tables after mincing them */
+ IF_DEBUG(sanity, checkLAGAtable(rtsFalse));
}
//@node GUM Message Processor, Miscellaneous Functions, Message-Processing Functions, High Level Communications Routines
switch (opcode) {
case PP_FINISH:
IF_PAR_DEBUG(verbose,
- belch("== [%x] received FINISH", mytid));
+ belch("==== received FINISH [%p]", mytid));
/* setting this global variables eventually terminates the main
scheduling loop for this PE and causes a shut-down, sending
PP_FINISH to SysMan */
case PP_SCHEDULE:
processSchedule(task);
break;
-
+
default:
/* Anything we're not prepared to deal with. */
barf("Task %x: Unexpected opcode %x from %x",
//@subsection Miscellaneous Functions
/*
+ * blockFetch blocks a BlockedFetch node on some kind of black hole.
+ */
+//@cindex blockFetch
+void
+blockFetch(StgBlockedFetch *bf, StgClosure *bh) {
+ bf->node = bh;
+ switch (get_itbl(bh)->type) {
+ case BLACKHOLE:
+ bf->link = END_BQ_QUEUE;
+ //((StgBlockingQueue *)bh)->header.info = &BLACKHOLE_BQ_info;
+ SET_INFO(bh, &BLACKHOLE_BQ_info); // turn closure into a blocking queue
+ ((StgBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
+
+ // put bh on the mutables list
+ recordMutable((StgMutClosure *)bh);
+ break;
+
+ case BLACKHOLE_BQ:
+ /* enqueue bf on blocking queue of closure bh */
+ bf->link = ((StgBlockingQueue *)bh)->blocking_queue;
+ ((StgBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
+
+ // put bh on the mutables list; ToDo: check
+ recordMutable((StgMutClosure *)bh);
+ break;
+
+ case FETCH_ME_BQ:
+ /* enqueue bf on blocking queue of closure bh */
+ bf->link = ((StgFetchMeBlockingQueue *)bh)->blocking_queue;
+ ((StgFetchMeBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
+
+ // put bh on the mutables list; ToDo: check
+ recordMutable((StgMutClosure *)bh);
+ break;
+
+ case RBH:
+ /* enqueue bf on blocking queue of closure bh */
+ bf->link = ((StgRBH *)bh)->blocking_queue;
+ ((StgRBH *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
+
+ // put bh on the mutables list; ToDo: check
+ recordMutable((StgMutClosure *)bh);
+ break;
+
+ default:
+ barf("blockFetch: thought %p was a black hole (IP %#lx, %s)",
+ (StgClosure *)bh, get_itbl((StgClosure *)bh),
+ info_type((StgClosure *)bh));
+ }
+ IF_PAR_DEBUG(schedule,
+ belch("##++ blockFetch: after block the BQ of %p (%s) is:",
+ bh, info_type(bh));
+ print_bq(bh));
+}
+
+
+/*
+ blockThread is called from the main scheduler whenever tso returns with
+ a ThreadBlocked return code; tso has already been added to a blocking
+ queue (that's done in the entry code of the closure, because it is a
+ cheap operation we have to do in any case); the main purpose of this
+ routine is to send a Fetch message in case we are blocking on a FETCHME(_BQ)
+ closure, which is indicated by the tso.why_blocked field;
+ we also write an entry into the log file if we are generating one
+
+ Should update exectime etc in the entry code already; but we don't have
+ something like ``system time'' in the log file anyway, so this should
+ even out the inaccuracies.
+*/
+
+//@cindex blockThread
+void
+blockThread(StgTSO *tso)
+{
+ globalAddr *remote_ga;
+ globalAddr *local_ga;
+ globalAddr fmbq_ga;
+
+ // ASSERT(we are on some blocking queue)
+ ASSERT(tso->block_info.closure != (StgClosure *)NULL);
+
+ /*
+ We have to check why this thread has been blocked.
+ */
+ switch (tso->why_blocked) {
+ case BlockedOnGA:
+ /* the closure must be a FETCH_ME_BQ; tso came in here via
+ FETCH_ME entry code */
+ ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
+
+ /* HACK: the link field is used to hold the GA between FETCH_ME_entry
+ end this point; if something (eg. GC) happens inbetween the whole
+ thing will blow up
+ The problem is that the ga field of the FETCH_ME has been overwritten
+ with the head of the blocking (which is tso).
+ */
+ //ASSERT(looks_like_ga((globalAddr *)tso->link));
+ ASSERT(tso->link!=END_TSO_QUEUE && tso->link!=NULL);
+ remote_ga = (globalAddr *)tso->link; // ((StgFetchMe *)tso->block_info.closure)->ga;
+ tso->link = END_BQ_QUEUE;
+ /* it was tso which turned node from FETCH_ME into FETCH_ME_BQ =>
+ we have to send a Fetch message here! */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ tso->par.exectime += CURRENT_TIME - tso->par.blockedat;
+ tso->par.fetchcount++;
+ tso->par.blockedat = CURRENT_TIME;
+ /* we are about to send off a FETCH message, so dump a FETCH event */
+ DumpRawGranEvent(CURRENT_PROC,
+ taskIDtoPE(remote_ga->payload.gc.gtid),
+ GR_FETCH, tso, tso->block_info.closure, 0);
+ }
+ /* Phil T. claims that this was a workaround for a hard-to-find
+ * bug, hence I'm leaving it out for now --SDM
+ */
+ /* Assign a brand-new global address to the newly created FMBQ */
+ local_ga = makeGlobal(tso->block_info.closure, rtsFalse);
+ splitWeight(&fmbq_ga, local_ga);
+ ASSERT(fmbq_ga.weight == 1L << (BITS_IN(unsigned) - 1));
+
+ sendFetch(remote_ga, &fmbq_ga, 0/*load*/);
+
+ break;
+
+ case BlockedOnGA_NoSend:
+ /* the closure must be a FETCH_ME_BQ; tso came in here via
+ FETCH_ME_BQ entry code */
+ ASSERT(get_itbl(tso->block_info.closure)->type==FETCH_ME_BQ);
+
+ /* Fetch message has been sent already */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ tso->par.exectime += CURRENT_TIME - tso->par.blockedat;
+ tso->par.blockcount++;
+ tso->par.blockedat = CURRENT_TIME;
+ /* dump a block event, because fetch has been sent already */
+ DumpRawGranEvent(CURRENT_PROC, thisPE,
+ GR_BLOCK, tso, tso->block_info.closure, 0);
+ }
+ break;
+
+ case BlockedOnBlackHole:
+ /* the closure must be a BLACKHOLE_BQ or an RBH; tso came in here via
+ BLACKHOLE(_BQ) or CAF_BLACKHOLE or RBH entry code */
+ ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
+ get_itbl(tso->block_info.closure)->type==RBH);
+
+ /* if collecting stats update the execution time etc */
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ //rtsTime now = CURRENT_TIME; /* Now */
+ tso->par.exectime += CURRENT_TIME - tso->par.blockedat;
+ tso->par.blockcount++;
+ tso->par.blockedat = CURRENT_TIME;
+ DumpRawGranEvent(CURRENT_PROC, thisPE,
+ GR_BLOCK, tso, tso->block_info.closure, 0);
+ }
+ break;
+
+ default:
+ barf("blockThread: impossible why_blocked code %d for TSO %d",
+ tso->why_blocked, tso->id);
+ }
+
+ IF_PAR_DEBUG(schedule,
+ belch("##++ blockThread: TSO %d blocked on closure %p (%s)",
+ tso->id, tso->block_info.closure, info_type(tso->block_info.closure)));
+}
+
+/*
* ChoosePE selects a GlobalTaskId from the array of PEs 'at random'.
* Important properties:
* - it varies during execution, even if the PE is idle
closure = GALAlookup(&ga);
if ((bf = (StgBlockedFetch *)allocate(FIXED_HS + sizeofW(StgBlockedFetch))) == NULL) {
+ barf("createBlockedFetch: out of heap while allocating heap for a BlocekdFetch; ToDo: call GC here");
GarbageCollect(GetRoots);
closure = GALAlookup(&ga);
bf = (StgBlockedFetch *)allocate(FIXED_HS + sizeofW(StgBlockedFetch));
bf->ga.weight = rga.weight;
// bf->link = NULL; debugging
- IF_PAR_DEBUG(fetch,
- fprintf(stderr, "%% [%x] created BF: closure=%p (%s), GA: ",
- mytid, closure, info_type(closure));
+ IF_PAR_DEBUG(schedule,
+ fprintf(stderr, "%%%%// created BF: bf=%p (%s) of closure , GA: ",
+ bf, info_type(bf), closure);
printGA(&(bf->ga));
fputc('\n',stderr));
return bf;
void
DebugPrintGAGAMap(globalAddr *gagamap, int nGAs)
{
- int i;
+ nat i;
for (i = 0; i < nGAs; ++i, gagamap += 2)
- fprintf(stderr, "gagamap[%d] = ((%x, %d, %x)) -> ((%x, %d, %x))\n", i,
+ fprintf(stderr, "__ gagamap[%d] = ((%x, %d, %x)) -> ((%x, %d, %x))\n", i,
gagamap[0].payload.gc.gtid, gagamap[0].payload.gc.slot, gagamap[0].weight,
gagamap[1].payload.gc.gtid, gagamap[1].payload.gc.slot, gagamap[1].weight);
}
+
+//@cindex checkGAGAMap
+void
+checkGAGAMap(globalAddr *gagamap, int nGAs)
+{
+ nat i;
+
+ for (i = 0; i < nGAs; ++i, gagamap += 2) {
+ ASSERT(looks_like_ga(gagamap));
+ ASSERT(looks_like_ga(gagamap+1));
+ }
+}
#endif
//@cindex freeMsgBuffer
static StgWord **freeMsgBuffer = NULL;
//@cindex freeMsgIndex
-static int *freeMsgIndex = NULL;
+static nat *freeMsgIndex = NULL;
//@cindex prepareFreeMsgBuffers
void
prepareFreeMsgBuffers(void)
{
- int i;
+ nat i;
/* Allocate the freeMsg buffers just once and then hang onto them. */
if (freeMsgIndex == NULL) {
- freeMsgIndex = (int *) stgMallocBytes(nPEs * sizeof(int),
+ freeMsgIndex = (nat *) stgMallocBytes(nPEs * sizeof(nat),
"prepareFreeMsgBuffers (Index)");
freeMsgBuffer = (StgWord **) stgMallocBytes(nPEs * sizeof(long *),
"prepareFreeMsgBuffers (Buffer)");
void
freeRemoteGA(int pe, globalAddr *ga)
{
- int i;
+ nat i;
ASSERT(GALAlookup(ga) == NULL);
if ((i = freeMsgIndex[pe]) + 2 >= RtsFlags.ParFlags.packBufferSize) {
IF_PAR_DEBUG(free,
- belch("Filled a free message buffer (sending remaining messages indivisually)"));
+ belch("!! Filled a free message buffer (sending remaining messages indivisually)"));
sendFree(ga->payload.gc.gtid, i, freeMsgBuffer[pe]);
i = 0;
freeMsgBuffer[pe][i++] = (StgWord) ga->payload.gc.slot;
freeMsgIndex[pe] = i;
-#ifdef DEBUG
- ga->weight = 0x0f0f0f0f;
- ga->payload.gc.gtid = 0x666;
- ga->payload.gc.slot = 0xdeaddead;
-#endif
+ IF_DEBUG(sanity,
+ ga->weight = 0xdead0add;
+ ga->payload.gc.gtid = 0xbbbbbbbb;
+ ga->payload.gc.slot = 0xbbbbbbbb;);
}
//@cindex sendFreeMessages
void
sendFreeMessages(void)
{
- int i;
+ nat i;
for (i = 0; i < nPEs; i++)
if (freeMsgIndex[i] > 0)
/* --------------------------------------------------------------------------
- Time-stamp: <Wed Nov 17 1999 16:50:58 Stardate: [-30]3913.51 hwloidl>
- $Id: LLC.h,v 1.2 2000/01/13 14:34:07 hwloidl Exp $
+ Time-stamp: <Tue Mar 21 2000 20:10:18 Stardate: [-30]4539.20 hwloidl>
+ $Id: LLC.h,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
Low Level Communications Header (LLC.h)
/* ----------------------------------------------------------------------------
- * Time-stamp: <Wed Jan 12 2000 12:29:53 Stardate: [-30]4193.64 hwloidl>
- * $Id: LLComms.c,v 1.2 2000/01/13 14:34:07 hwloidl Exp $
+ * Time-stamp: <Tue Mar 21 2000 20:23:41 Stardate: [-30]4539.24 hwloidl>
+ * $Id: LLComms.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
*
* GUM Low-Level Inter-Task Communication
*
* It's based on the GRAPH for PVM version *
* Phil Trinder, Glasgow University 8th December 1994 *
* *
+ RFPointon, December 1999
+ - removed PP_SYSMAN_TID, introduced PP_READY
+ - removed PP_MAIN_TASK, introduced PP_NEWPE
+ - added PP_REVAL
************************************************************************/
#define REPLY_OK 0x00
/*
- Time-stamp: <Thu Dec 16 1999 18:21:17 Stardate: [-30]4058.61 software>
- $Id: Pack.c,v 1.3 2000/03/17 14:37:22 simonmar Exp $
+ Time-stamp: <Thu Mar 30 2000 22:53:32 Stardate: [-30]4584.56 hwloidl>
+ $Id: Pack.c,v 1.4 2000/03/31 03:09:37 hwloidl Exp $
Graph packing and unpacking code for sending it to another processor
and retrieving the original graph structure from the packet.
@UnpackGraph@ routine is called and the buffer can be discarded
afterwards.
- Note that in GranSim we need many buffers, not just one per PE. */
+ Note that in GranSim we need many buffers, not just one per PE.
+*/
//@node Graph packing, , ,
//@section Graph packing
#if defined(PAR) || defined(GRAN) /* whole file */
-#define _HS (sizeofW(StgHeader))
-
//@menu
//* Includes::
//* Prototypes::
//@node ADT of closure queues, Init for packing, Prototypes, Prototypes
//@subsubsection ADT of closure queues
-static inline void AllocClosureQueue(nat size);
static inline void InitClosureQueue(void);
static inline rtsBool QueueEmpty(void);
static inline void QueueClosure(StgClosure *closure);
//@node Init for packing, Packing routines, ADT of closure queues, Prototypes
//@subsubsection Init for packing
-static void initPacking(void);
+static void InitPacking(rtsBool unpack);
# if defined(PAR)
-rtsBool initPackBuffer(void);
+rtsBool InitPackBuffer(void);
# elif defined(GRAN)
rtsPackBuffer *InstantiatePackBuffer (void);
static void reallocPackBuffer (void);
//@subsubsection Low level packing fcts
# if defined(GRAN)
-static inline void Pack (StgClosure *data);
+static void Pack (StgClosure *data);
# else
-static inline void Pack (StgWord data);
+static void Pack (StgWord data);
+static void PackGeneric(StgClosure *closure);
+static void PackArray(StgClosure *closure);
static void PackPLC (StgPtr addr);
static void PackOffset (int offset);
+static void PackPAP(StgPAP *pap);
+static rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
+static rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
+static void PackFetchMe(StgClosure *closure);
+
static void GlobaliseAndPackGA (StgClosure *closure);
# endif
# if defined(PAR)
void InitPendingGABuffer(nat size);
void CommonUp(StgClosure *src, StgClosure *dst);
-StgClosure *UnpackGraph(rtsPackBuffer *packBuffer,
- globalAddr **gamap,
- nat *nGAs);
+static StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure,
+ rtsBool hasGA);
+static nat FillInClosure(StgWord ***bufptrP, StgClosure *graph);
+static void LocateNextParent(StgClosure **parentP,
+ nat *pptrP, nat *pptrsP, nat *sizeP);
+StgClosure *UnpackGraph(rtsPackBuffer *packBuffer,
+ globalAddr **gamap,
+ nat *nGAs);
+static StgClosure *UnpackClosure (StgWord ***bufptrP, StgClosure **graphP,
+ globalAddr *ga);
+static StgWord **UnpackGA(StgWord **bufptr, globalAddr *ga);
+static StgClosure *UnpackOffset(globalAddr *ga);
+static StgClosure *UnpackPLC(globalAddr *ga);
+static void UnpackArray(StgWord ***bufptrP, StgClosure *graph);
+static nat UnpackPAP(StgWord ***bufptrP, StgClosure *graph);
+
# elif defined(GRAN)
void CommonUp(StgClosure *src, StgClosure *dst);
StgClosure *UnpackGraph(rtsPackBuffer* buffer);
static rtsBool RoomToPack (nat size, nat ptrs);
rtsBool isOffset(globalAddr *ga);
rtsBool isFixed(globalAddr *ga);
+ rtsBool isConstr(globalAddr *ga);
# elif defined(GRAN)
static void DonePacking(void);
static rtsBool NotYetPacking(StgClosure *closure);
clq_size, clq_pos,
buf_id = 1; /* identifier for buffer */
static nat unpacked_size;
-static nat reservedPAsize; /* Space reserved for primitive arrays */
-static rtsBool RoomInBuffer;
+static rtsBool roomInBuffer;
-# if defined(GRAN)
/*
The pack buffer
To be pedantic: in GrAnSim we're packing *addresses* of closures,
not the closures themselves.
*/
-static rtsPackBuffer *Bonzo = NULL; /* size: can be set via option */
-# else
-static rtsPackBuffer *Bonzo = NULL; /* size: can be set via option */
-# endif
+static rtsPackBuffer *globalPackBuffer = NULL, /* for packing a graph */
+ *globalUnpackBuffer = NULL; /* for unpacking a graph */
+
/*
Bit of a hack for testing if a closure is the root of the graph. This is
static HashTable *offsetTable;
//@cindex PendingGABuffer
-static globalAddr *PendingGABuffer;
-/* is initialised in main; */
+static globalAddr *PendingGABuffer, *gaga;
+
# endif /* PAR */
+
//@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
//@subsection ADT of Closure Queues
//@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
//@subsubsection Init routines
-/* @InitClosureQueue@ initialises the closure queue. */
-
-//@cindex AllocClosureQueue
-static inline void
-AllocClosureQueue(size)
-nat size;
-{
- ASSERT(ClosureQueue == NULL);
- ClosureQueue = (StgClosure**) stgMallocWords(size, "AllocClosureQueue");
-}
+/* @InitClosureQueue@ allocates and initialises the closure queue. */
//@cindex InitClosureQueue
static inline void
{
clq_pos = clq_size = 0;
- if ( ClosureQueue == NULL )
- AllocClosureQueue(RTS_PACK_BUFFER_SIZE);
+ if (ClosureQueue==NULL)
+ ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE,
+ "InitClosureQueue");
}
//@node Basic routines, , Init routines, ADT of Closure Queues
return((StgClosure*)NULL);
}
+/* DeQueueClosure returns the head of the closure queue. */
+
+//@cindex DeQueueClosure
+static inline StgClosure *
+PrintQueueClosure(void)
+{
+ nat i;
+
+ fputs("Closure queue:", stderr);
+ for (i=clq_pos; i < clq_size; i++)
+ fprintf(stderr, "%p (%s), ",
+ ClosureQueue[clq_pos++], info_type(ClosureQueue[clq_pos++]));
+ fputc('\n', stderr);
+}
+
//@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
//@subsection Initialisation for packing
/*
packet strategy implemented, so in the case of an overflow we just stop
adding closures to the closure queue. If an overflow of the simulated
packet occurs, we just realloc some more space for it and carry on as
- usual. -- HWL */
+ usual. -- HWL
+*/
# if defined(GRAN)
rtsPackBuffer *
InstantiatePackBuffer (void) {
- extern rtsPackBuffer *Bonzo;
+ extern rtsPackBuffer *globalPackBuffer;
- Bonzo = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
+ globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
"InstantiatePackBuffer: failed to alloc packBuffer");
- Bonzo->size = RtsFlags.GranFlags.packBufferSize_internal;
- Bonzo->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
+ globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
+ globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
"InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
/* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
/* stgMallocWords is now simple allocate in Storage.c */
- return (Bonzo);
+ return (globalPackBuffer);
}
/*
static void
reallocPackBuffer (void) {
- ASSERT(pack_locn >= (int)Bonzo->size+sizeofW(rtsPackBuffer));
+ ASSERT(pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer));
IF_GRAN_DEBUG(packBuffer,
belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
- Bonzo, Bonzo->size+REALLOC_SZ,
+ globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
CurrentProc, CurrentTime[CurrentProc]));
- Bonzo = (rtsPackBuffer*)realloc(Bonzo,
+ globalPackBuffer = (rtsPackBuffer*)realloc(globalPackBuffer,
sizeof(StgClosure*)*(REALLOC_SZ +
- (int)Bonzo->size +
+ (int)globalPackBuffer->size +
sizeofW(rtsPackBuffer))) ;
- if (Bonzo==(rtsPackBuffer*)NULL)
+ if (globalPackBuffer==(rtsPackBuffer*)NULL)
barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n",
- REALLOC_SZ, Bonzo, CurrentProc, CurrentTime[CurrentProc]);
+ REALLOC_SZ, globalPackBuffer, CurrentProc, CurrentTime[CurrentProc]);
- Bonzo->size += REALLOC_SZ;
+ globalPackBuffer->size += REALLOC_SZ;
- ASSERT(pack_locn < Bonzo->size+sizeofW(rtsPackBuffer));
+ ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
}
# endif
# if defined(PAR)
/* @initPacking@ initialises the packing buffer etc. */
-//@cindex initPackBuffer
+//@cindex InitPackBuffer
rtsBool
-initPackBuffer(void)
+InitPackBuffer(void)
{
- if (Bonzo == NULL) { /* not yet allocated */
-
- if ((Bonzo = (rtsPackBuffer *)
- stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize,
- "initPackBuffer")) == NULL)
- return rtsFalse;
-
- InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
- AllocClosureQueue(RtsFlags.ParFlags.packBufferSize);
+ if (globalPackBuffer==(rtsPackBuffer*)NULL) {
+ if ((globalPackBuffer = (rtsPackBuffer *)
+ stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize,
+ "InitPackBuffer")) == NULL)
+ return rtsFalse;
}
return rtsTrue;
}
-# endif
+# endif
+//@cindex InitPacking
static void
-initPacking(void)
+InitPacking(rtsBool unpack)
{
# if defined(GRAN)
- Bonzo = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
+ globalPackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
/* NB: free in UnpackGraph */
+# elif defined(PAR)
+ if (unpack) {
+ /* allocate a GA-to-GA map (needed for ACK message) */
+ InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
+ } else {
+ /* allocate memory to pack the graph into */
+ InitPackBuffer();
+ }
# endif
+ /* init queue of closures seen during packing */
+ InitClosureQueue();
+
+ if (unpack)
+ return;
- Bonzo->id = buf_id++; /* buffer id are only used for debugging! */
+ globalPackBuffer->id = buf_id++; /* buffer id are only used for debugging! */
pack_locn = 0; /* the index into the actual pack buffer */
unpacked_size = 0; /* the size of the whole graph when unpacked */
- reservedPAsize = 0;
- RoomInBuffer = rtsTrue;
- InitClosureQueue();
+ roomInBuffer = rtsTrue;
packed_thunks = 0; /* total number of thunks packed so far */
# if defined(PAR)
offsetTable = allocHashTable();
StgTSO* tso;
nat *packBufferSize;
{
- extern rtsPackBuffer *Bonzo;
- /* Ensure enough heap for all possible RBH_Save closures */
-
ASSERT(RTS_PACK_BUFFER_SIZE > 0);
/* ToDo: check that we have enough heap for the packet
return NULL;
*/
- initPacking();
+ InitPacking(rtsFalse);
# if defined(GRAN)
graph_root = closure;
# endif
IF_GRAN_DEBUG(pack,
belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [PE %d]\n demanded by TSO %d (%p) [PE %u]",
- Bonzo->id, Bonzo, closure, where_is(closure),
+ globalPackBuffer->id, globalPackBuffer, closure, where_is(closure),
tso->id, tso, where_is((StgClosure*)tso)));
IF_GRAN_DEBUG(pack,
belch("** PrintGraph of %p is:", closure);
PrintGraph(closure,0));
- IF_PAR_DEBUG(pack,
+ IF_PAR_DEBUG(packet,
belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n demanded by TSO %d (%p)",
- Bonzo->id, Bonzo, closure, mytid,
+ globalPackBuffer->id, globalPackBuffer, closure, mytid,
tso->id, tso));
- IF_PAR_DEBUG(pack,
+ IF_PAR_DEBUG(packet,
belch("** PrintGraph of %p is:", closure);
belch("** pack_locn=%d", pack_locn);
PrintGraph(closure,0));
# if defined(PAR)
/* Record how much space is needed to unpack the graph */
- Bonzo->tso = tso; // ToDo: check: used in GUM or only for debugging?
- Bonzo->unpacked_size = unpacked_size;
- Bonzo->size = pack_locn;
+ globalPackBuffer->tso = tso; // ToDo: check: used in GUM or only for debugging?
+ globalPackBuffer->unpacked_size = unpacked_size;
+ globalPackBuffer->size = pack_locn;
/* Set the size parameter */
ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize);
/* Record how much space is needed to unpack the graph */
// PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG; for testing
- Bonzo->tso = tso;
- Bonzo->unpacked_size = unpacked_size;
+ globalPackBuffer->tso = tso;
+ globalPackBuffer->unpacked_size = unpacked_size;
// ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
/* ToDo: Print an earlier, more meaningful message */
if (pack_locn==0) /* i.e. packet is empty */
barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
closure);
- Bonzo->size = pack_locn;
+ globalPackBuffer->size = pack_locn;
*packBufferSize = pack_locn;
# endif
# if defined(GRAN)
IF_GRAN_DEBUG(pack ,
belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
- Bonzo->id, closure, Bonzo->size, packed_thunks, Bonzo->unpacked_size));
+ globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size));
if (RtsFlags.GranFlags.GranSimStats.Global) {
globalGranStats.tot_packets++;
globalGranStats.tot_packet_size += pack_locn;
}
- IF_GRAN_DEBUG(pack, PrintPacket(Bonzo));
+ IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
# elif defined(PAR)
- IF_GRAN_DEBUG(pack ,
+ IF_PAR_DEBUG(packet,
belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
- Bonzo->id, closure, Bonzo->size, packed_thunks, Bonzo->unpacked_size);
- PrintPacket(Bonzo));
-# endif /* GRAN */
+ globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size);
+ PrintPacket(globalPackBuffer));
- return (Bonzo);
+ IF_DEBUG(sanity, // do a sanity check on the packet just constructed
+ checkPacket(globalPackBuffer));
+# endif /* GRAN */
+
+ return (globalPackBuffer);
}
//@cindex PackOneNode
StgTSO* tso;
nat *packBufferSize;
{
- extern rtsPackBuffer *Bonzo;
+ extern rtsPackBuffer *globalPackBuffer;
int i, clpack_locn;
- initPacking();
+ InitPacking(rtsFalse);
IF_GRAN_DEBUG(pack,
belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
Pack(closure);
/* Record how much space is needed to unpack the graph */
- Bonzo->tso = tso;
- Bonzo->unpacked_size = unpacked_size;
+ globalPackBuffer->tso = tso;
+ globalPackBuffer->unpacked_size = unpacked_size;
/* Set the size parameter */
ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
- Bonzo->size = pack_locn;
+ globalPackBuffer->size = pack_locn;
*packBufferSize = pack_locn;
if (RtsFlags.GranFlags.GranSimStats.Global) {
globalGranStats.tot_packet_size += pack_locn;
}
IF_GRAN_DEBUG(pack,
- PrintPacket(Bonzo));
+ PrintPacket(globalPackBuffer));
- return (Bonzo);
+ return (globalPackBuffer);
}
# endif /* GRAN */
StgTSO *tso;
nat *packBufferSize;
{
- extern rtsPackBuffer *Bonzo;
+ extern rtsPackBuffer *globalPackBuffer;
IF_GRAN_DEBUG(pack,
belch("** Packing TSO %d (%p)", tso->id, tso));
*packBufferSize = 0;
// PackBuffer[0] = PackBuffer[1] = 0; ???
- return(Bonzo);
+ return(globalPackBuffer);
}
//@cindex PackStkO
-rtsPackBuffer*
+static rtsPackBuffer*
PackStkO(stko, packBufferSize)
StgPtr stko;
nat *packBufferSize;
{
- extern rtsPackBuffer *Bonzo;
+ extern rtsPackBuffer *globalPackBuffer;
IF_GRAN_DEBUG(pack,
belch("** Packing STKO %p", stko));
*packBufferSize = 0;
// PackBuffer[0] = PackBuffer[1] = 0;
- return(Bonzo);
+ return(globalPackBuffer);
}
-void
+static void
PackFetchMe(StgClosure *closure)
{
barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
#elif defined(PAR)
-rtsPackBuffer*
+static rtsPackBuffer*
PackTSO(tso, packBufferSize)
StgTSO *tso;
nat *packBufferSize;
{
- barf("{PackTSO}Daq Qagh: trying to pack a TSO; thread migrations not supported, yet");
+ barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
+ tso->id, tso, packBufferSize);
}
rtsPackBuffer*
StgPtr stko;
nat *packBufferSize;
{
- barf("{PackStkO}Daq Qagh: trying to pack a STKO; thread migrations not supported, yet");
+ barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
+ stko, packBufferSize);
}
//@cindex PackFetchMe
-void
+static void
PackFetchMe(StgClosure *closure)
{
StgInfoTable *ip;
nat i;
+ int offset;
#if defined(GRAN)
barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
#else
+ offset = OffsetFor(closure);
+ if (!NotYetPacking(offset)) {
+ IF_PAR_DEBUG(pack,
+ belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
+ closure, info_type(closure), offset));
+ PackOffset(offset);
+ unpacked_size += 2;
+ return;
+ }
+
+ /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
+ AmPacking(closure);
+ GlobaliseAndPackGA(closure);
+
+ IF_PAR_DEBUG(pack,
+ belch("*>.. Packing FETCH_ME for closure %p (%s) with GA: ((%x, %d, %x))",
+ closure, info_type(closure),
+ globalPackBuffer->buffer[pack_locn-2],
+ globalPackBuffer->buffer[pack_locn-1],
+ globalPackBuffer->buffer[pack_locn-3]));
+
/* Pack a FetchMe closure instead of closure */
ip = &FETCH_ME_info;
/* this assumes that the info ptr is always the first word in a closure*/
for (i = 1; i < _HS; ++i) // pack rest of fixed header
Pack((StgWord)*(((StgPtr)closure)+i));
- unpacked_size += _HS; // ToDo: check
+ unpacked_size += PACK_FETCHME_SIZE;
#endif
}
StgClosure *closure;
{
StgInfoTable *info;
- StgClosure *indirectee, *rbh;
- nat size, ptrs, nonptrs, vhs, i, clpack_locn;
- rtsBool is_CONSTR = rtsFalse;
- char str[80];
+ StgClosure *indirectee;
+ nat clpack_locn;
- ASSERT(closure!=NULL);
- indirectee = closure;
- do {
- /* Don't pack indirection closures */
- closure = indirectee;
- indirectee = IS_INDIRECTION(closure);
- IF_PAR_DEBUG(pack,
- if (indirectee)
- belch("** Shorted an indirection (%s) at %p (-> %p)",
- info_type(closure), closure, indirectee));
- } while (indirectee);
+ ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));
+
+ closure = UNWIND_IND(closure);
+ /* now closure is the thing we want to pack */
+ info = get_itbl(closure);
clpack_locn = OffsetFor(closure);
/* If the closure has been packed already, just pack an indirection to it
to guarantee that the graph doesn't become a tree when unpacked */
if (!NotYetPacking(clpack_locn)) {
- StgInfoTable *info;
-
PackOffset(clpack_locn);
return;
}
- /*
- * PLCs reside on all of the PEs already. Just pack the
- * address as a GA (a bit of a kludge, since an address may
- * not fit in *any* of the individual GA fields). Const,
- * charlike and small intlike closures are converted into
- * PLCs.
- */
- switch (get_itbl(closure)->type) {
-
-# ifdef DEBUG
- // check error cases only in a debugging setup
- case RET_BCO:
- case RET_SMALL:
- case RET_VEC_SMALL:
- case RET_BIG:
- case RET_VEC_BIG:
- case RET_DYN:
- barf("** {Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
- closure, info_type(closure));
- /* never reached */
-
- case UPDATE_FRAME:
- case STOP_FRAME:
- case CATCH_FRAME:
- case SEQ_FRAME:
- barf("** {Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
- closure, info_type(closure));
- /* never reached */
-
- case TSO:
- case BLOCKED_FETCH:
- case EVACUATED:
- /* something's very wrong */
- barf("** {Pack}Daq Qagh: found %s (%p) when packing",
- info_type(closure), closure);
- /* never reached */
-# endif
+ switch (info->type) {
case CONSTR_CHARLIKE:
IF_PAR_DEBUG(pack,
- belch("** Packing a charlike closure %d",
+ belch("*>^^ Packing a charlike closure %d",
((StgIntCharlikeClosure*)closure)->data));
- PackPLC(CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
+ PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
return;
case CONSTR_INTLIKE:
if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
IF_PAR_DEBUG(pack,
- belch("** Packing a small intlike %d as a PLC", val));
- PackPLC(INTLIKE_CLOSURE(val));
+ belch("*>^^ Packing a small intlike %d as a PLC", val));
+ PackPLC((StgPtr)INTLIKE_CLOSURE(val));
return;
} else {
IF_PAR_DEBUG(pack,
- belch("** Packing a big intlike %d as a normal closure",
+ belch("*>^^ Packing a big intlike %d as a normal closure",
val));
- break;
+ PackGeneric(closure);
+ return;
}
}
case CONSTR_2_0:
case CONSTR_1_1:
case CONSTR_0_2:
- /* it's a constructor (i.e. plain data) but we don't know
- how many ptrs, non-ptrs there are => use generic code */
+ /* it's a constructor (i.e. plain data) */
IF_PAR_DEBUG(pack,
- belch("** Packing a CONSTR %p (%s) using generic packing with GA",
+ belch("*>^^ Packing a CONSTR %p (%s) using generic packing",
closure, info_type(closure)));
- // is_CONSTR = rtsTrue;
- break;
- /* fall through to generic packing code */
+ PackGeneric(closure);
+ return;
+ case THUNK_STATIC: // ToDo: check whether that's ok
+ case FUN_STATIC: // ToDo: check whether that's ok
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
// evaluated on each PE if needed
IF_PAR_DEBUG(pack,
- belch("** Packing a %p (%s) as a PLC",
+ belch("*>~~ Packing a %p (%s) as a PLC",
closure, info_type(closure)));
- PackPLC(closure);
+ PackPLC((StgPtr)closure);
return;
- case MVAR:
- /* MVARs may not be copied; they are sticky objects in the new RTS */
- /* therefore we treat them just as RBHs etc (what a great system!) */
- IF_PAR_DEBUG(pack,
- belch("** Found an MVar at %p (%s)",
- closure, info_type(closure)));
- /* fall through !! */
+ case THUNK_SELECTOR:
+ {
+ StgClosure *selectee = ((StgSelector *)closure)->selectee;
- case THUNK_SELECTOR: // ToDo: fix packing of this strange beast
+ IF_PAR_DEBUG(pack,
+ belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric",
+ closure, info_type(closure),
+ selectee, info_type(selectee)));
+ PackGeneric(closure);
+ /* inlined code; probably could use PackGeneric
+ Pack((StgWord)(*(StgPtr)closure));
+ Pack((StgWord)(selectee));
+ QueueClosure(selectee);
+ unpacked_size += 2;
+ */
+ }
+ return;
+
+ case FUN:
+ case FUN_1_0:
+ case FUN_0_1:
+ case FUN_2_0:
+ case FUN_1_1:
+ case FUN_0_2:
+ case THUNK:
+ case THUNK_1_0:
+ case THUNK_0_1:
+ case THUNK_2_0:
+ case THUNK_1_1:
+ case THUNK_0_2:
+ PackGeneric(closure);
+ return;
+
+ case AP_UPD:
+ case PAP:
+ /*
+ barf("*> Packing of PAP not implemented %p (%s)",
+ closure, info_type(closure));
+
+ Currently we don't pack PAPs; we pack a FETCH_ME to the closure,
+ instead. Note that since PAPs contain a chunk of stack as payload,
+ implementing packing of PAPs is a first step towards thread migration.
IF_PAR_DEBUG(pack,
- belch("** Found an THUNK_SELECTORE at %p (%s)",
+ belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME",
closure, info_type(closure)));
- /* fall through !! */
+ PackFetchMe(closure);
+ */
+ PackPAP((StgPAP *)closure);
+ return;
+ case CAF_UNENTERED:
+ case CAF_ENTERED:
case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
case BLACKHOLE:
+ case BLACKHOLE_BQ:
+ case SE_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
case RBH:
case FETCH_ME:
case FETCH_ME_BQ:
//ASSERT(pack_locn > PACK_HDR_SIZE);
IF_PAR_DEBUG(pack,
- belch("** Packing a BH or FM at %p (%s) of (fixed size %d)",
- closure, info_type(closure), _HS));
-
- /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
- GlobaliseAndPackGA(closure);
+ belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME",
+ closure, info_type(closure)));
+ /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
+ phps short-cut the GA here */
+ PackFetchMe(closure);
+ return;
+ case MVAR:
+ barf("*> Pack: packing of MVARs not implemented",
+ closure, info_type(closure));
+
+ /* MVARs may not be copied; they are sticky objects in the new RTS */
+ /* therefore we treat them just as RBHs etc (what a great system!)
+ IF_PAR_DEBUG(pack,
+ belch("** Found an MVar at %p (%s)",
+ closure, info_type(closure))); */
+ IF_PAR_DEBUG(pack,
+ belch("*>.. Packing an MVAR at %p (%s) as a FETCH_ME",
+ closure, info_type(closure)));
+ /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
+ phps short-cut the GA here */
PackFetchMe(closure);
return;
+ case ARR_WORDS:
+ PackArray(closure);
+ return;
+
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ case MUT_VAR:
+ /*
+ Eventually, this should use the same packing routine as ARR_WRODS
+
+ GlobaliseAndPackGA(closure);
+ PackArray(closure);
+ return;
+ */
+ barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
+ closure, info_type(closure));
+
+# ifdef DEBUG
+ case BCO:
+ barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code",
+ closure, info_type(closure));
+ /* never reached */
+
+ // check error cases only in a debugging setup
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case RET_BIG:
+ case RET_VEC_BIG:
+ case RET_DYN:
+ barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
+ closure, info_type(closure));
+ /* never reached */
+
+ case UPDATE_FRAME:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case SEQ_FRAME:
+ barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
+ closure, info_type(closure));
+ /* never reached */
+
+ case TSO:
+ case BLOCKED_FETCH:
+ case EVACUATED:
+ /* something's very wrong */
+ barf("{Pack}Daq Qagh: found %s (%p) when packing",
+ info_type(closure), closure);
+ /* never reached */
+
+ case IND:
+ case IND_OLDGEN:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case IND_STATIC:
+ barf("Pack: found IND_... after shorting out indirections %d (%s)",
+ (nat)(info->type), info_type(closure));
+
+ case WEAK:
+ case FOREIGN:
+ case STABLE_NAME:
+ barf("Pack: found foreign thingy; not yet implemented in %d (%s)",
+ (nat)(info->type), info_type(closure));
+#endif
+
default:
-/* IF_PAR_DEBUG(pack, */
-/* belch("** Not a PLC or BH ... ")); */
+ barf("Pack: strange closure %d", (nat)(info->type));
} /* switch */
+}
+
+/*
+ Pack a constructor of unknown size.
+ Similar to PackGeneric but without creating GAs.
+*/
+#if 0
+//@cindex PackConstr
+static void
+PackConstr(StgClosure *closure)
+{
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i;
+ char str[80];
+
+ ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
/* get info about basic layout of the closure */
info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
- ASSERT(!IS_BLACK_HOLE(closure));
+ ASSERT(info->type == CONSTR ||
+ info->type == CONSTR_1_0 ||
+ info->type == CONSTR_0_1 ||
+ info->type == CONSTR_2_0 ||
+ info->type == CONSTR_1_1 ||
+ info->type == CONSTR_0_2);
IF_PAR_DEBUG(pack,
- fprintf(stderr, "** packing %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
+ fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
closure, info_type(closure), size, ptrs, nonptrs));
- /*
- * Now peek ahead to see whether the closure has any primitive array
- * children
- */
- /*
- ToDo: fix this code -- HWL
- for (i = 0; i < ptrs; ++i) {
- StgInfoTable * childInfo;
- nat childSize, childPtrs, childNonPtrs, childVhs;
-
- // extract i-th pointer out of closure
- childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
- &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
- if (IS_BIG_MOTHER(childInfo)) {
- reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
- + childPtrs * PACK_FETCHME_SIZE;
- }
- }
- */
- /* Record the location of the GA */
- AmPacking(closure);
+ /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
- /* Pack the global address */
- if (!is_CONSTR) {
- GlobaliseAndPackGA(closure);
- } else {
+ if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
IF_PAR_DEBUG(pack,
- belch("** No GA allocated for CONSTR %p (%s)",
+ belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
closure, info_type(closure)));
+ PackFetchMe(closure);
+ return;
}
- /*
- * Pack a fetchme to the closure if it's a black hole, or the buffer is full
- * and it isn't a primitive array. N.B. Primitive arrays are always packed
- * (because their parents index into them directly)
- */
+ /* Record the location of the GA */
+ AmPacking(closure);
- // ToDo: pack FMs if no more room available in packet (see below)
- if (!(RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)))
- barf("** Qagh: Pack: not enough room in packet to pack closure %p (%s)",
- closure, info_type(closure));
+ /* Pack Constructor marker */
+ Pack((StgWord)2);
- /*
- Has been moved into the switch statement
-
- if (IS_BLACK_HOLE(closure))
- !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
- || IS_BIG_MOTHER(info)))
- {
-
- ASSERT(pack_locn > PACK_HDR_SIZE);
+ /* pack fixed and variable header */
+ for (i = 0; i < _HS + vhs; ++i)
+ Pack((StgWord)*(((StgPtr)closure)+i));
- info = FetchMe_info;
- for (i = 0; i < FIXED_HS; ++i) {
- if (i == INFO_HDR_POSN)
- Pack((StgWord) FetchMe_info);
- else
- Pack(closure[i]);
- }
+ /* register all ptrs for further packing */
+ for (i = 0; i < ptrs; ++i)
+ QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
- unpacked_size += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);
+ /* pack non-ptrs */
+ for (i = 0; i < nonptrs; ++i)
+ Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
+}
+#endif
- } else {
- */
- if (info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
- info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR)
- belch("** ghuH: found %s; packing of primitive arrays not yet implemented",
- info_type(closure));
+/*
+ Generic packing code.
+ This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
+*/
+//@cindex PackGeneric
+static void
+PackGeneric(StgClosure *closure)
+{
+ StgInfoTable *info;
+ StgClosure *rbh;
+ nat size, ptrs, nonptrs, vhs, i, m;
+ char str[80];
+
+ ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
+
+ /* get info about basic layout of the closure */
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+
+ ASSERT(!IS_BLACK_HOLE(closure));
+
+ IF_PAR_DEBUG(pack,
+ fprintf(stderr, "*>== generic packing of %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
+ closure, info_type(closure), size, ptrs, nonptrs));
+
+ /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
+
+ if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
+ IF_PAR_DEBUG(pack,
+ belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
+ closure, info_type(closure)));
+ PackFetchMe(closure);
+ return;
+ }
+
+ /* Record the location of the GA */
+ AmPacking(closure);
+ /* Allocate a GA for this closure and put it into the buffer */
+ GlobaliseAndPackGA(closure);
+
+ ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
+ info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
/* At last! A closure we can actually pack! */
if (ip_MUTABLE(info) && (info->type != FETCH_ME))
- fprintf(stderr, "** ghuH: Replicated a Mutable closure!\n");
+ barf("*>// PackClosure: trying to replicate a Mutable closure!");
/*
Remember, the generic closure layout is as follows:
/* register all ptrs for further packing */
for (i = 0; i < ptrs; ++i)
- QueueClosure(((StgClosure *) *(((StgPtr)closure)+(i+_HS+vhs))));
+ QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
/* pack non-ptrs */
for (i = 0; i < nonptrs; ++i)
- Pack((StgWord)*(((StgPtr)closure)+(i+_HS+vhs+ptrs)));
+ Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
- unpacked_size += _HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
+ // ASSERT(_HS+vhs+ptrs+nonptrs==size);
+ if ((m=_HS+vhs+ptrs+nonptrs)<size) {
+ IF_PAR_DEBUG(pack,
+ belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
+ closure, info_type(closure), size-m));
+ for (i=m; i<size; i++)
+ Pack((StgWord)*(((StgPtr)closure)+i));
+ }
+
+ unpacked_size += size;
+ // unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
/*
* Record that this is a revertable black hole so that we can fill in
packed_thunks++;
}
}
+/*
+ Pack an array of words.
+ ToDo: implement packing of MUT_ARRAYs
+*/
-# else /* GRAN */
+//@cindex PackArray
+static void
+PackArray(StgClosure *closure)
+{
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i, n;
+ char str[80];
-/* Fake the packing of a closure */
+#if DEBUG
+ /* we don't really need all that get_closure_info delivers; however, for
+ debugging it's useful to have the stuff anyway */
-void
-PackClosure(closure)
-StgClosure *closure;
-{
- StgInfoTable *info, *childInfo;
+ /* get info about basic layout of the closure */
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+
+ ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
+ info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
+#endif
+ /* record offset of the closure and allocate a GA */
+ AmPacking(closure);
+ GlobaliseAndPackGA(closure);
+
+ n = ((StgArrWords *)closure)->words;
+ // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
+
+ IF_PAR_DEBUG(pack,
+ belch("*>== packing an array of %d words %p (%s) (size=%d)\n",
+ n, closure, info_type(closure),
+ arr_words_sizeW((StgArrWords *)closure)));
+
+ /* Pack the header (2 words: info ptr and the number of words to follow) */
+ Pack((StgWord)*(StgPtr)closure);
+ Pack(((StgArrWords *)closure)->words);
+
+ /* pack the payload of the closure (all non-ptrs) */
+ for (i=0; i<n; i++)
+ Pack((StgWord)((StgArrWords *)closure)->payload[i]);
+
+ unpacked_size += arr_words_sizeW((StgArrWords *)closure);
+}
+
+/*
+ Pack a PAP closure.
+ Note that the representation of a PAP in the buffer is different from
+ its representation in the heap. In particular, pointers to local
+ closures are packed directly as FETCHME closures, using
+ PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
+ structure. To account for the difference in size we store the packed
+ size of the closure as part of the PAP's variable header in the buffer.
+*/
+
+//@cindex PackPAP
+static void
+PackPAP(StgPAP *pap) {
+ nat m, n, i, j, pack_start;
+ StgPtr p, q, end/*dbg*/;
+ const StgInfoTable* info;
+ StgWord32 bitmap;
+ /* debugging only */
+ nat size, ptrs, nonptrs, vhs;
+ char str[80];
+
+ /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
+ ASSERT(PACK_FETCHME_SIZE == 1 + sizeofW(StgFetchMe));
+ ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
+
+ /* record offset of the closure and allocate a GA */
+ AmPacking((StgClosure *)pap);
+ GlobaliseAndPackGA((StgClosure *)pap);
+
+ /* get info about basic layout of the closure */
+ info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
+ ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
+
+ n = (nat)(pap->n_args);
+
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP: packing PAP @ %p with %d words (size=%d; ptrs=%d; nonptrs=%d:",
+ (StgClosure *)pap, n, size, ptrs, nonptrs);
+ printClosure((StgClosure *)pap));
+
+ /* Pack the PAP header */
+ Pack((StgWord)(pap->header.info));
+ Pack((StgWord)(pap->n_args));
+ Pack((StgWord)(pap->fun));
+ pack_start = pack_locn; // to compute size of PAP in buffer
+ Pack((StgWord)0); // this will be filled in later (size of PAP in buffer)
+
+ /* Pack the payload of a PAP i.e. a stack chunk */
+ /* pointers to start of stack chunk */
+ p = (StgPtr)(pap->payload);
+ end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
+ while (p<end) {
+ /* the loop body has been borrowed from scavenge_stack */
+ q = (StgPtr)*p;
+
+ /* If we've got a tag, pack all words in that block */
+ if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
+ nat m = ARG_TAG(q); // first word after this block
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
+ p, m, p));
+ for (i=0; i<m+1; i++)
+ Pack((StgWord)*(p+i));
+ p += m+1; // m words + the tag
+ continue;
+ }
+
+ /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
+ ToDo: provide RTS flag to also pack these closures
+ */
+ if (! LOOKS_LIKE_GHC_INFO(q) ) {
+ /* distinguish static closure (PLC) from other closures (FM) */
+ switch (get_itbl((StgClosure*)q)->type) {
+ case CONSTR_CHARLIKE:
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP: packing a charlike closure %d",
+ ((StgIntCharlikeClosure*)q)->data));
+
+ PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
+ p++;
+ break;
+
+ case CONSTR_INTLIKE:
+ {
+ StgInt val = ((StgIntCharlikeClosure*)q)->data;
+
+ if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
+ PackPLC((StgPtr)INTLIKE_CLOSURE(val));
+ p++;
+ break;
+ } else {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
+ val));
+ Pack((StgWord)(ARGTAG_MAX+1));
+ PackFetchMe((StgClosure *)q);
+ p++;
+ break;
+ }
+ }
+ case THUNK_STATIC: // ToDo: check whether that's ok
+ case FUN_STATIC: // ToDo: check whether that's ok
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
+ q, info_type((StgClosure *)q)));
+
+ PackPLC((StgPtr)q);
+ p++;
+ break;
+ }
+ default:
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: packing FM to %p (%s)",
+ p, q, info_type((StgClosure*)q)));
+ Pack((StgWord)(ARGTAG_MAX+1));
+ PackFetchMe((StgClosure *)q);
+ p++;
+ break;
+ }
+ continue;
+ }
+
+ /*
+ * Otherwise, q must be the info pointer of an activation
+ * record. All activation records have 'bitmap' style layout
+ * info.
+ */
+ info = get_itbl((StgClosure *)p);
+ switch (info->type) {
+
+ /* Dynamic bitmap: the mask is stored on the stack */
+ case RET_DYN:
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: RET_DYN",
+ p));
+
+ /* Pack the header as is */
+ Pack((StgWord)(((StgRetDyn *)p)->info));
+ Pack((StgWord)(((StgRetDyn *)p)->liveness));
+ Pack((StgWord)(((StgRetDyn *)p)->ret_addr));
+
+ bitmap = ((StgRetDyn *)p)->liveness;
+ p = (P_)&((StgRetDyn *)p)->payload[0];
+ goto small_bitmap;
+
+ /* probably a slow-entry point return address: */
+ case FUN:
+ case FUN_STATIC:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
+ p));
+
+ Pack((StgWord)(((StgClosure *)p)->header.info));
+ p++;
+
+ goto follow_srt; //??
+ }
+
+ /* Using generic code here; could inline as in scavenge_stack */
+ case UPDATE_FRAME:
+ {
+ StgUpdateFrame *frame = (StgUpdateFrame *)p;
+ nat type = get_itbl(frame->updatee)->type;
+
+ ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
+
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
+ p, frame->updatee, frame->link));
+
+ Pack((StgWord)(frame->header.info));
+ Pack((StgWord)(frame->link)); // ToDo: fix intra-stack pointer
+ Pack((StgWord)(frame->updatee)); // ToDo: follow link
+
+ p += 3;
+ }
+
+ /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
+ case STOP_FRAME:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: STOP_FRAME",
+ p));
+ Pack((StgWord)((StgStopFrame *)p)->header.info);
+ p++;
+ }
+
+ case CATCH_FRAME:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
+ p, ((StgCatchFrame *)p)->handler));
+
+ Pack((StgWord)((StgCatchFrame *)p)->header.info);
+ Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
+ Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
+ Pack((StgWord)((StgCatchFrame *)p)->handler);
+ p += 4;
+ }
+
+ case SEQ_FRAME:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
+ p, ((StgSeqFrame *)p)->link));
+
+ Pack((StgWord)((StgSeqFrame *)p)->header.info);
+ Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer
+
+ // ToDo: handle bitmap
+ bitmap = info->layout.bitmap;
+
+ p = (StgPtr)&(((StgClosure *)p)->payload);
+ goto small_bitmap;
+ }
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
+ p, info->layout.bitmap));
+
+
+ Pack((StgWord)((StgClosure *)p)->header.info);
+ p++;
+ // ToDo: handle bitmap
+ bitmap = info->layout.bitmap;
+ /* this assumes that the payload starts immediately after the info-ptr */
+
+ small_bitmap:
+ while (bitmap != 0) {
+ if ((bitmap & 1) == 0) {
+ Pack((StgWord)(ARGTAG_MAX+1));
+ PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
+ } else {
+ Pack((StgWord)*p++);
+ }
+ bitmap = bitmap >> 1;
+ }
+
+ follow_srt:
+ belch("*>-- PackPAP: nothing to do for follow_srt");
+ continue;
+
+ /* large bitmap (> 32 entries) */
+ case RET_BIG:
+ case RET_VEC_BIG:
+ {
+ StgPtr q;
+ StgLargeBitmap *large_bitmap;
+
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
+ p, info->layout.large_bitmap));
+
+
+ Pack((StgWord)((StgClosure *)p)->header.info);
+ p++;
+
+ large_bitmap = info->layout.large_bitmap;
+
+ for (j=0; j<large_bitmap->size; j++) {
+ bitmap = large_bitmap->bitmap[j];
+ q = p + sizeof(W_) * 8;
+ while (bitmap != 0) {
+ if ((bitmap & 1) == 0) {
+ Pack((StgWord)(ARGTAG_MAX+1));
+ PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
+ } else {
+ Pack((StgWord)*p++);
+ }
+ bitmap = bitmap >> 1;
+ }
+ if (j+1 < large_bitmap->size) {
+ while (p < q) {
+ Pack((StgWord)(ARGTAG_MAX+1));
+ PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ }
+ }
+
+ /* and don't forget to follow the SRT */
+ goto follow_srt;
+ }
+
+ default:
+ barf("PackPAP: weird activation record found on stack (@ %p): %d",
+ p, (int)(info->type));
+ }
+ }
+ // fill in size of the PAP (only the payload!) in buffer
+ globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
+ // add the size of the whole packed closure; this relies on the fact that
+ // the size of the unpacked PAP + size of all unpacked FMs is the same as
+ // the size of the packed PAP!!
+ unpacked_size += sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
+}
+# else /* GRAN */
+
+/* Fake the packing of a closure */
+
+void
+PackClosure(closure)
+StgClosure *closure;
+{
+ StgInfoTable *info, *childInfo;
nat size, ptrs, nonptrs, vhs;
char info_hdr_ty[80];
nat i;
case THUNK_SELECTOR:
{
- StgClosure *sel = ((StgSelector *)closure)->selectee;
+ StgClosure *selectee = ((StgSelector *)closure)->selectee;
IF_GRAN_DEBUG(pack,
belch("** Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
- closure, info_type(closure), sel, info_type(sel)));
- QueueClosure(sel);
+ closure, info_type(closure), selectee, info_type(selectee)));
+ QueueClosure(selectee);
IF_GRAN_DEBUG(pack,
belch("** [%p (%s) (Queueing closure) ....]",
- sel, info_type(sel)));
+ selectee, info_type(selectee)));
}
return;
//@cindex Pack
# if defined(PAR)
-static inline void
+static void
Pack(data)
StgWord data;
{
ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
- Bonzo->buffer[pack_locn++] = data;
+ globalPackBuffer->buffer[pack_locn++] = data;
}
#endif
#if defined(GRAN)
-static inline void
+static void
Pack(closure)
StgClosure *closure;
{
/* This checks the size of the GrAnSim internal pack buffer. The simulated
pack buffer is checked via RoomToPack (as in GUM) */
- if (pack_locn >= (int)Bonzo->size+sizeofW(rtsPackBuffer))
+ if (pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer))
reallocPackBuffer();
if (closure==(StgClosure*)NULL)
belch("Qagh {Pack}Daq: Trying to pack 0");
- Bonzo->buffer[pack_locn++] = closure;
+ globalPackBuffer->buffer[pack_locn++] = closure;
/* ASSERT: Data is a closure in GrAnSim here */
info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+ // ToDo: is check for MIN_UPD_SIZE really needed? */
unpacked_size += _HS + (size < MIN_UPD_SIZE ?
MIN_UPD_SIZE :
size);
export. The GA is then packed into the pack buffer. */
# if defined(PAR)
-
+//@cindex GlobaliseAndPackGA
static void
GlobaliseAndPackGA(closure)
StgClosure *closure;
if ((ga = LAGAlookup(closure)) == NULL)
ga = makeGlobal(closure, rtsTrue);
+ ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
splitWeight(&packGA, ga);
ASSERT(packGA.weight > 0);
IF_PAR_DEBUG(pack,
- fprintf(stderr, "** Globalising closure %p (%s) with GA",
+ fprintf(stderr, "*>## Globalising closure %p (%s) with GA ",
closure, info_type(closure));
printGA(&packGA);
fputc('\n', stderr));
PackOffset(offset)
int offset;
{
+ /*
IF_PAR_DEBUG(pack,
belch("** Packing Offset %d at pack location %u",
offset, pack_locn));
+ */
Pack(1L); /* weight */
Pack(0L); /* pe */
Pack(offset); /* slot/offset */
InitPendingGABuffer(size)
nat size;
{
- PendingGABuffer = (globalAddr *)
- stgMallocBytes(size*2*sizeof(globalAddr),
- "InitPendingGABuffer");
+ if (PendingGABuffer==(globalAddr *)NULL)
+ PendingGABuffer = (globalAddr *)
+ stgMallocBytes(size*2*sizeof(globalAddr),
+ "InitPendingGABuffer");
+
+ /* current location in the buffer */
+ gaga = PendingGABuffer;
}
/*
ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
ASSERT(src != dst);
- IF_PAR_DEBUG(verbose,
- belch("__ CommonUp %p (%s) with %p (%s)",
+ IF_PAR_DEBUG(pack,
+ belch("*___ CommonUp %p (%s) --> %p (%s)",
src, info_type(src), dst, info_type(dst)));
switch (get_itbl(src)->type) {
bqe = END_BQ_QUEUE;
break;
+ /* currently we also common up 2 CONSTRs; this should reduce heap
+ * consumption but also does more work; not sure whether it's worth doing
+ */
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_2_0:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case ARR_WORDS:
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ case MUT_VAR:
+ break;
+
default:
/* Don't common up anything else */
return;
/*
ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
if (bqe != END_BQ_QUEUE)
- awaken_blocked_queue(bqe, src);
+ awakenBlockedQueue(bqe, src);
+ */
+}
+
+/*
+ * Common up the new closure with any existing closure having the same
+ * GA
+ */
+//@cindex SetGAandCommonUp
+static StgClosure *
+SetGAandCommonUp(globalAddr *ga, StgClosure *closure, rtsBool hasGA)
+{
+ StgClosure *existing;
+ StgInfoTable *ip, *oldip;
+ globalAddr *newGA;
+
+ if (!hasGA)
+ return closure;
+
+ ip = get_itbl(closure);
+ if ((existing = GALAlookup(ga)) == NULL) {
+ /* Just keep the new object */
+ IF_PAR_DEBUG(pack,
+ belch("*<## Unpacking new GA ((%x, %d, %x))",
+ ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight));
+
+ // make an entry binding closure to ga in the RemoteGA table
+ newGA = setRemoteGA(closure, ga, rtsTrue);
+ if (ip->type == FETCH_ME)
+ ((StgFetchMe *)closure)->ga = newGA;
+ } else {
+ /* Two closures, one global name. Someone loses */
+ oldip = get_itbl(existing);
+ if ((oldip->type == FETCH_ME ||
+ /* If we pack GAs for CONSTRs we have to check for them, too */
+ IS_BLACK_HOLE(existing)) &&
+ ip->type != FETCH_ME)
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*<#- Unpacking old GA ((%x, %d, %x)); redirecting %p -> %p",
+ ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
+ existing, closure));
+
+ /*
+ * What we had wasn't worth keeping, so make the old closure an
+ * indirection to the new closure (copying BQs if necessary) and
+ * make sure that the old entry is not the preferred one for this
+ * closure.
+ */
+ CommonUp(existing, closure);
+ //GALAdeprecate(ga);
+ /* now ga indirectly refers to the new closure */
+ ASSERT(UNWIND_IND(GALAlookup(ga))==closure);
+ } else {
+ /*
+ * Either we already had something worthwhile by this name or
+ * the new thing is just another FetchMe. However, the thing we
+ * just unpacked has to be left as-is, or the child unpacking
+ * code will fail. Remember that the way pointer words are
+ * filled in depends on the info pointers of the parents being
+ * the same as when they were packed.
+ */
+ IF_PAR_DEBUG(pack,
+ belch("*<#@ Unpacking old GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
+ ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
+ existing, info_type(existing), closure, info_type(closure)));
+
+ closure = existing;
+#if 0
+ // HACK
+ ty = get_itbl(closure)->type;
+ if (ty == CONSTR ||
+ ty == CONSTR_1_0 ||
+ ty == CONSTR_0_1 ||
+ ty == CONSTR_2_0 ||
+ ty == CONSTR_1_1 ||
+ ty == CONSTR_0_2)
+ CommonUp(closure, graph);
+#endif
+ }
+ /* Pool the total weight in the stored ga */
+ (void) addWeight(ga);
+ }
+
+ /* ToDo: check this assertion!!
+ if we have unpacked a FETCH_ME, we have a GA, too
+ ASSERT(get_itbl(*closureP)->type!=FETCH_ME ||
+ looks_like_ga(((StgFetchMe *)*closureP)->ga));
+ */
+ /* Sort out the global address mapping */
+ if (ip_THUNK(ip)){
+ // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
+ //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
+ /* Make up new GAs for single-copy closures */
+ globalAddr *newGA = makeGlobal(closure, rtsTrue);
+
+ // It's a new GA and therefore has the full weight
+ ASSERT(newGA->weight==0);
+
+ /* Create an old GA to new GA mapping */
+ *gaga++ = *ga;
+ splitWeight(gaga, newGA);
+ /* inlined splitWeight; we know that newGALA has full weight
+ newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
+ gaga->payload = newGA->payload;
+ */
+ ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
+ gaga++;
+ }
+ return closure;
+}
+
+/*
+ Copies a segment of the buffer, starting at @bufptr@, representing a closure
+ into the heap at @graph@.
+ */
+//@cindex FillInClosure
+static nat
+FillInClosure(StgWord ***bufptrP, StgClosure *graph)
+{
+ StgInfoTable *ip;
+ StgWord **bufptr = *bufptrP;
+ nat ptrs, nonptrs, vhs, i, size;
+ char str[80];
+
+ ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure*)bufptr)->header.info));
+
+ /*
+ * Close your eyes. You don't want to see where we're looking. You
+ * can't get closure info until you've unpacked the variable header,
+ * but you don't know how big it is until you've got closure info.
+ * So...we trust that the closure in the buffer is organized the
+ * same way as they will be in the heap...at least up through the
+ * end of the variable header.
+ */
+ ip = get_closure_info((StgClosure *)bufptr, &size, &ptrs, &nonptrs, &vhs, str);
+
+ /* Make sure that nothing sans the fixed header is filled in
+ The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
+ if (ip->type == FETCH_ME) {
+ ASSERT(size>=MIN_UPD_SIZE); // size of the FM in the heap
+ ptrs = nonptrs = vhs = 0; // i.e. only unpack FH from buffer
+ }
+ /* ToDo: check whether this is really needed */
+ if (ip->type == ARR_WORDS) {
+ UnpackArray(bufptrP, graph);
+ return arr_words_sizeW((StgArrWords *)bufptr);
+ }
+
+ if (ip->type == PAP || ip->type == AP_UPD) {
+ return UnpackPAP(bufptrP, graph); // includes size of unpackes FMs
+ }
+
+ /*
+ Remember, the generic closure layout is as follows:
+ +-------------------------------------------------+
+ | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
+ +-------------------------------------------------+
*/
+ /* Fill in the fixed header */
+ for (i = 0; i < _HS; i++)
+ ((StgPtr)graph)[i] = (StgWord)*bufptr++;
+
+ /* Fill in the packed variable header */
+ for (i = 0; i < vhs; i++)
+ ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
+
+ /* Pointers will be filled in later */
+
+ /* Fill in the packed non-pointers */
+ for (i = 0; i < nonptrs; i++)
+ ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
+
+ /* Indirections are never packed */
+ // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
+ // return bufptr;
+ *bufptrP = bufptr;
+ ASSERT((ip->type==FETCH_ME && sizeofW(StgFetchMe)==size) ||
+ _HS+vhs+ptrs+nonptrs == size);
+ return size;
+}
+
+/*
+ Find the next pointer field in the parent closure.
+ If the current parent has been completely unpacked already, get the
+ next closure from the global closure queue.
+*/
+//@cindex LocateNextParent
+static void
+LocateNextParent(parentP, pptrP, pptrsP, sizeP)
+StgClosure **parentP;
+nat *pptrP, *pptrsP, *sizeP;
+{
+ StgInfoTable *ip; // debugging
+ nat nonptrs, pvhs;
+ char str[80];
+
+ /* pptr as an index into the current parent; find the next pointer field
+ in the parent by increasing pptr; if that takes us off the closure
+ (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue
+ */
+ (*pptrP)++;
+ while (*pptrP + 1 > *pptrsP) {
+ /* *parentP has been constructed (all pointer set); so check it now */
+ IF_DEBUG(sanity,
+ if (*parentP!=(StgClosure*)NULL &&
+ get_itbl(*parentP)->type != FETCH_ME)
+ checkClosure(*parentP));
+
+ *parentP = DeQueueClosure();
+
+ if (*parentP == NULL)
+ break;
+ else {
+ ip = get_closure_info(*parentP, sizeP, pptrsP, &nonptrs,
+ &pvhs, str);
+ *pptrP = 0;
+ }
+ }
+ /* *parentP points to the new (or old) parent; */
+ /* *pptr, *pptrs and *size have been updated referring to the new parent */
+}
+
+/*
+ UnpackClosure is the heart of the unpacking routine. It is called for
+ every closure found in the packBuffer. Any prefix such as GA, PLC marker
+ etc has been unpacked into the *ga structure.
+ UnpackClosure does the following:
+ - check for the kind of the closure (PLC, Offset, std closure)
+ - copy the contents of the closure from the buffer into the heap
+ - update LAGA tables (in particular if we end up with 2 closures
+ having the same GA, we make one an indirection to the other)
+ - set the GAGA map in order to send back an ACK message
+
+ At the end of this function *graphP has been updated to point to the
+ next free word in the heap for unpacking the rest of the graph and
+ *bufptrP points to the next word in the pack buffer to be unpacked.
+*/
+
+static StgClosure*
+UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
+ StgClosure *closure;
+ nat size;
+ rtsBool hasGA = rtsFalse;
+
+ /* Now unpack the closure body, if there is one; three cases:
+ - PLC: closure is just a pointer to a static closure
+ - Offset: closure has been unpacked already
+ - else: copy data from packet into closure
+ */
+ if (isFixed(ga)) {
+ closure = UnpackPLC(ga);
+ } else if (isOffset(ga)) {
+ closure = UnpackOffset(ga);
+ } else {
+ ASSERT(LOOKS_LIKE_GA(ga));
+ /* Now we have to build something. */
+ hasGA = !isConstr(ga);
+ /* the new closure will be built here */
+ closure = *graphP;
+
+ /* fill in the closure from the buffer */
+ size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
+
+ /* Add to queue for processing */
+ QueueClosure(closure);
+
+ /* common up with other graph if necessary */
+ closure = SetGAandCommonUp(ga, closure, hasGA);
+
+ /* if we unpacked a THUNK, check that it is large enough to update */
+ ASSERT(!closure_THUNK(closure) || size>=MIN_UPD_SIZE);
+ /* graph shall point to next free word in the heap */
+ *graphP += size;
+ //graph += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
+ }
+ return closure;
}
/*
The format of graph in the pack buffer is as defined in @Pack.lc@. */
-//@cindex UnpackGraph
-StgClosure *
-UnpackGraph(packBuffer, gamap, nGAs)
-rtsPackBuffer *packBuffer;
-globalAddr **gamap;
-nat *nGAs;
+//@cindex UnpackGraph
+StgClosure *
+UnpackGraph(packBuffer, gamap, nGAs)
+rtsPackBuffer *packBuffer;
+globalAddr **gamap;
+nat *nGAs;
+{
+ StgWord **bufptr, **slotptr;
+ globalAddr gaS;
+ StgClosure *closure, *graphroot, *graph, *parent;
+ nat size, heapsize, bufsize,
+ pptr = 0, pptrs = 0, pvhs = 0;
+
+ /* Initialisation */
+ InitPacking(rtsTrue); // same as in PackNearbyGraph
+ globalUnpackBuffer = packBuffer;
+
+ IF_DEBUG(sanity, // do a sanity check on the incoming packet
+ checkPacket(packBuffer));
+
+ ASSERT(gaga==PendingGABuffer);
+ graphroot = (StgClosure *)NULL;
+
+ /* Unpack the header */
+ bufsize = packBuffer->size;
+ heapsize = packBuffer->unpacked_size;
+ bufptr = packBuffer->buffer;
+
+ /* allocate heap */
+ if (heapsize > 0) {
+ graph = (StgClosure *)allocate(heapsize);
+ ASSERT(graph != NULL);
+ }
+
+ /* iterate over the buffer contents and unpack all closures */
+ parent = (StgClosure *)NULL;
+ do {
+ /* This is where we will ultimately save the closure's address */
+ slotptr = bufptr;
+
+ /* fill in gaS from buffer; gaS may receive GA, PLC- or offset-marker */
+ bufptr = UnpackGA(/*in*/bufptr, /*out*/&gaS);
+
+ /* this allocates heap space, updates LAGA tables etc */
+ closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
+
+ /*
+ * Set parent pointer to point to chosen closure. If we're at the top of
+ * the graph (our parent is NULL), then we want to arrange to return the
+ * chosen closure to our caller (possibly in place of the allocated graph
+ * root.)
+ */
+ if (parent == NULL)
+ graphroot = closure;
+ else
+ ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
+
+ /* Save closure pointer for resolving offsets */
+ *slotptr = (StgWord) closure;
+
+ /* Locate next parent pointer */
+ LocateNextParent(&parent, &pptr, &pptrs, &size);
+
+ IF_DEBUG(sanity,
+ gaS.weight = 0xdeadffff;
+ gaS.payload.gc.gtid = 0xdead;
+ gaS.payload.gc.slot = 0xdeadbeef;);
+ } while (parent != NULL);
+
+ /* we unpacked exactly as many words as there are in the buffer */
+ ASSERT(bufsize == bufptr-(packBuffer->buffer) &&
+ heapsize >= graph-graphroot); // should be ==
+
+ *gamap = PendingGABuffer;
+ *nGAs = (gaga - PendingGABuffer) / 2;
+
+ IF_PAR_DEBUG(tables,
+ belch("** LAGA table after unpacking closure %p:",
+ graphroot);
+ printLAGAtable());
+
+ /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
+ ASSERT(graphroot!=NULL);
+
+ IF_DEBUG(sanity,
+ {
+ StgPtr p;
+
+ /* check the unpacked graph */
+ checkHeapChunk(graphroot,graph-sizeof(StgWord));
+
+ // if we do sanity checks, then wipe the pack buffer after unpacking
+ for (p=packBuffer->buffer; p<(packBuffer->buffer)+(packBuffer->size); )
+ *p++ = 0xdeadbeef;
+ });
+
+ /* reset the global variable */
+ globalUnpackBuffer = (rtsPackBuffer*)NULL;
+ return (graphroot);
+}
+
+//@cindex UnpackGA
+static StgWord **
+UnpackGA(StgWord **bufptr, globalAddr *ga)
+{
+ /* First, unpack the next GA or PLC */
+ ga->weight = (rtsWeight) *bufptr++;
+
+ if (ga->weight > 0) {
+ ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
+ ga->payload.gc.slot = (int) *bufptr++;
+ } else {
+ ga->payload.plc = (StgPtr) *bufptr++;
+ }
+ return bufptr;
+}
+
+//@cindex UnpackPLC
+static StgClosure *
+UnpackPLC(globalAddr *ga)
+{
+ /* No more to unpack; just set closure to local address */
+ IF_PAR_DEBUG(pack,
+ belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
+ return ga->payload.plc;
+}
+
+//@cindex UnpackOffset
+static StgClosure *
+UnpackOffset(globalAddr *ga)
+{
+ /* globalUnpackBuffer is a global var init in UnpackGraph */
+ ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
+ /* No more to unpack; just set closure to cached address */
+ IF_PAR_DEBUG(pack,
+ belch("*<__ Unpacked indirection to %p (was offset %d)",
+ (StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
+ ga->payload.gc.slot));
+return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
+}
+
+/*
+ Input: *bufptrP, *graphP ... ptrs to the pack buffer and into the heap.
+
+ *bufptrP points to something that should be unpacked as a FETCH_ME:
+ |
+ v
+ +-------------------------------
+ | GA | FH of FM
+ +-------------------------------
+
+ The first 3 words starting at *bufptrP are the GA address; the next
+ word is the generic FM info ptr followed by the remaining FH (if any)
+ The result after unpacking will be a FETCH_ME closure, pointed to by
+ *graphP at the start of the fct;
+ |
+ v
+ +------------------------+
+ | FH of FM | ptr to a GA |
+ +------------------------+
+
+ The ptr field points into the RemoteGA table, which holds the actual GA.
+ *bufptrP has been updated to point to the next word in the buffer.
+ *graphP has been updated to point to the first free word at the end.
+*/
+
+static StgClosure*
+UnpackFetchMe (StgWord ***bufptrP, StgClosure **graphP) {
+ StgClosure *closure, *foo;
+ globalAddr gaS;
+
+ /* This fct relies on size of FM < size of FM in pack buffer */
+ ASSERT(sizeofW(StgFetchMe)<=PACK_FETCHME_SIZE);
+
+ /* fill in gaS from buffer */
+ *bufptrP = UnpackGA(*bufptrP, &gaS);
+ /* might be an offset to a closure in the pack buffer */
+ if (isOffset(&gaS)) {
+ belch("*< UnpackFetchMe: found OFFSET to %d when unpacking FM at buffer loc %p",
+ gaS.payload.gc.slot, *bufptrP);
+
+ closure = UnpackOffset(&gaS);
+ /* return address of previously unpacked closure; leaves *graphP unchanged */
+ return closure;
+ }
+
+ /* we have a proper GA at hand */
+ ASSERT(LOOKS_LIKE_GA(&gaS));
+
+ IF_DEBUG(sanity,
+ if (isFixed(&gaS))
+ barf("*< UnpackFetchMe: found PLC where FM was expected %p (%s)",
+ *bufptrP, info_type(*bufptrP)));
+
+ IF_PAR_DEBUG(pack,
+ belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
+ *graphP);
+ printGA(&gaS));
+
+ /* the next thing must be the IP to a FETCH_ME closure */
+ ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
+
+ closure = *graphP;
+ /* fill in the closure from the buffer */
+ FillInClosure(bufptrP, closure);
+
+ /* the newly built closure is a FETCH_ME */
+ ASSERT(get_itbl(closure)->type == FETCH_ME);
+
+ /* common up with other graph if necessary
+ this also assigns the contents of gaS to the ga field of the FM closure */
+ foo = SetGAandCommonUp(&gaS, closure, rtsTrue);
+
+ ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
+
+ IF_PAR_DEBUG(pack,
+ belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
+ *graphP, *graphP+sizeofW(StgFetchMe), closure);
+ printClosure(closure));
+ *graphP += sizeofW(StgFetchMe);
+ return foo;
+}
+
+/*
+ Unpack an array of words.
+ Could use generic unpack most of the time, but cleaner to separate it.
+ ToDo: implement packing of MUT_ARRAYs
+*/
+
+//@cindex UnackArray
+static void
+UnpackArray(StgWord ***bufptrP, StgClosure *graph)
{
- nat size, ptrs, nonptrs, vhs;
- StgWord **buffer, **bufptr, **slotptr;
- globalAddr ga, *gaga;
- StgClosure *closure, *existing,
- *graphroot, *graph, *parent;
- StgInfoTable *ip, *oldip;
- nat bufsize, i,
- pptr = 0, pptrs = 0, pvhs;
- rtsBool hasGA;
+ StgInfoTable *info;
+ StgWord **bufptr=*bufptrP;
+ nat size, ptrs, nonptrs, vhs, i, n;
char str[80];
- initPackBuffer(); /* in case it isn't already init'd */
- graphroot = (StgClosure *)NULL;
+ /* yes, I know I am paranoid; but who's asking !? */
+ IF_DEBUG(sanity,
+ info = get_closure_info((StgClosure*)bufptr,
+ &size, &ptrs, &nonptrs, &vhs, str);
+ ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
+ info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
- gaga = PendingGABuffer;
+ n = ((StgArrWords *)bufptr)->words;
+ // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
- InitClosureQueue();
+ IF_PAR_DEBUG(pack,
+ belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
+ n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
+ arr_words_sizeW((StgArrWords *)bufptr)));
- /* Unpack the header */
- bufsize = packBuffer->size;
- buffer = packBuffer->buffer;
- bufptr = buffer;
+ /* Unpack the header (2 words: info ptr and the number of words to follow) */
+ ((StgArrWords *)graph)->header.info = *bufptr++; // assumes _HS==1; yuck!
+ ((StgArrWords *)graph)->words = *bufptr++;
- /* allocate heap */
- if (bufsize > 0) {
- graph = allocate(bufsize);
- ASSERT(graph != NULL);
- }
+ /* unpack the payload of the closure (all non-ptrs) */
+ for (i=0; i<n; i++)
+ ((StgArrWords *)graph)->payload[i] = *bufptr++;
- parent = (StgClosure *)NULL;
+ ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
+ *bufptrP = bufptr;
+}
- do {
- /* This is where we will ultimately save the closure's address */
- slotptr = bufptr;
+/*
+ Unpack a PAP in the buffer into a heap closure.
+ For each FETCHME we find in the packed PAP we have to unpack a separate
+ FETCHME closure and insert a pointer to this closure into the PAP.
+ We unpack all FETCHMEs into an area after the PAP proper (the `FM area').
+ Note that the size of a FETCHME in the buffer is exactly the same as
+ the size of an unpacked FETCHME plus 1 word for the pointer to it.
+ Therefore, we just allocate packed_size words in the heap for the unpacking.
+ After this routine the heap starting from *graph looks like this:
+
+ graph
+ |
+ v PAP closure | FM area |
+ +------------------------------------------------------------+
+ | PAP header | n_args | fun | payload ... | FM_1 | FM_2 .... |
+ +------------------------------------------------------------+
+
+ where payload contains pointers to each of the unpacked FM_1, FM_2 ...
+ The size of the PAP closure plus all FMs is _HS+2+packed_size.
+*/
- /* First, unpack the next GA or PLC */
- ga.weight = (rtsWeight) *bufptr++;
+//@cindex UnpackPAP
+static nat
+UnpackPAP(StgWord ***bufptrP, StgClosure *graph)
+{
+ nat n, i, j, packed_size = 0;
+ StgPtr p, q, end, payload_start, p_FMs;
+ const StgInfoTable* info;
+ StgWord32 bitmap;
+ StgWord **bufptr = *bufptrP;
- if (ga.weight > 0) {
- ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
- ga.payload.gc.slot = (int) *bufptr++;
- } else {
- ga.payload.plc = (StgPtr) *bufptr++;
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
+ *bufptr, *(bufptr+1), graph));
+
+ /* Unpack the PAP header (both fixed and variable) */
+ ((StgPAP *)graph)->header.info = *bufptr++;
+ n = ((StgPAP *)graph)->n_args = *bufptr++;
+ ((StgPAP *)graph)->fun = *bufptr++;
+ packed_size = *bufptr++;
+
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
+ ((StgPAP *)graph)->header.info,
+ ((StgPAP *)graph)->n_args,
+ ((StgPAP *)graph)->fun,
+ packed_size));
+
+ payload_start = bufptr;
+ /* p points to the current word in the heap */
+ p = ((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
+ p_FMs = graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
+ end = (StgPtr) payload_start+packed_size;
+ /*
+ The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
+ FM area for unpacking all FETCHMEs encountered during unpacking.
+ */
+ while (bufptr<end) {
+ /* be sure that we don't write more than we allocated for this closure */
+ ASSERT(p_FMs <= graph+_HS+2+packed_size);
+ /* be sure that the unpacked PAP doesn't run into the FM area */
+ ASSERT(p < graph+pap_sizeW((StgPAP*)graph));
+ /* the loop body has been borrowed from scavenge_stack */
+ q = *bufptr; // let q be the contents of the current pointer into the buffer
+
+ /* Test whether the next thing is a FETCH_ME.
+ In PAPs FETCH_ME are encoded via a starting marker of ARGTAG_MAX+1
+ */
+ if (q==(StgPtr)(ARGTAG_MAX+1)) {
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: unpacking FM to %p",
+ p, q));
+ bufptr++; // skip ARGTAG_MAX+1 marker
+ // Unpack a FM into the FM area after the PAP proper and insert pointer
+ *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ continue;
}
- /* Now unpack the closure body, if there is one */
- if (isFixed(&ga)) {
- /* No more to unpack; just set closure to local address */
+ /* Test whether it is a PLC */
+ if (q==(StgPtr)0) { // same as isFixed(q)
IF_PAR_DEBUG(pack,
- belch("_* Unpacked PLC at %x", ga.payload.plc));
- hasGA = rtsFalse;
- closure = ga.payload.plc;
- } else if (isOffset(&ga)) {
- /* No more to unpack; just set closure to cached address */
+ belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
+ p, *(bufptr+1)));
+ bufptr++; // skip 0 marker
+ *p++ = *bufptr++;
+ continue;
+ }
+
+ /* If we've got a tag, pack all words in that block */
+ if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
+ nat m = i+ARG_SIZE(q); // first word after this block
IF_PAR_DEBUG(pack,
- belch("_* Unpacked indirection to %p (was offset %x)",
- (StgClosure *) buffer[ga.payload.gc.slot],
- ga.payload.gc.slot));
- ASSERT(parent != (StgClosure *)NULL);
- hasGA = rtsFalse;
- closure = (StgClosure *) buffer[ga.payload.gc.slot];
- } else {
- /* Now we have to build something. */
- hasGA = rtsTrue;
+ belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
+ p, m, p));
+ for (i=0; i<m+1; i++)
+ *p++ = *bufptr++;
+ continue;
+ }
- ASSERT(bufsize > 0);
+ /*
+ * Otherwise, q must be the info pointer of an activation
+ * record. All activation records have 'bitmap' style layout
+ * info.
+ */
+ info = get_itbl((StgClosure *)q);
+ switch (info->type) {
+
+ /* Dynamic bitmap: the mask is stored on the stack */
+ case RET_DYN:
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: RET_DYN",
+ p));
- /*
- * Close your eyes. You don't want to see where we're looking. You
- * can't get closure info until you've unpacked the variable header,
- * but you don't know how big it is until you've got closure info.
- * So...we trust that the closure in the buffer is organized the
- * same way as they will be in the heap...at least up through the
- * end of the variable header.
- */
- ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
-
- /*
- Remember, the generic closure layout is as follows:
- +-------------------------------------------------+
- | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
- +-------------------------------------------------+
- */
- /* Fill in the fixed header */
- for (i = 0; i < _HS; i++)
- ((StgPtr)graph)[i] = (StgWord)*bufptr++;
+ /* Pack the header as is */
+ ((StgRetDyn *)p)->info = *bufptr++;
+ ((StgRetDyn *)p)->liveness = *bufptr;
+ ((StgRetDyn *)p)->ret_addr= *bufptr;
- if (ip->type == FETCH_ME)
- size = ptrs = nonptrs = vhs = 0;
+ //bitmap = ((StgRetDyn *)p)->liveness;
+ //p = (P_)&((StgRetDyn *)p)->payload[0];
+ goto small_bitmap;
- /* Fill in the packed variable header */
- for (i = 0; i < vhs; i++)
- ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
+ /* probably a slow-entry point return address: */
+ case FUN:
+ case FUN_STATIC:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
+ p));
- /* Pointers will be filled in later */
+ ((StgClosure *)p)->header.info = *bufptr;
+ p++;
- /* Fill in the packed non-pointers */
- for (i = 0; i < nonptrs; i++)
- ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
-
- /* Indirections are never packed */
- // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
+ goto follow_srt; //??
+ }
- /* Add to queue for processing */
- QueueClosure(graph);
-
- /*
- * Common up the new closure with any existing closure having the same
- * GA
- */
+ /* Using generic code here; could inline as in scavenge_stack */
+ case UPDATE_FRAME:
+ {
+ StgUpdateFrame *frame = (StgUpdateFrame *)p;
+ //nat type = get_itbl(frame->updatee)->type;
+
+ //ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
- if ((existing = GALAlookup(&ga)) == NULL) {
- globalAddr *newGA;
- /* Just keep the new object */
IF_PAR_DEBUG(pack,
- belch("_* Unpacking new GA ((%x, %d, %x))",
- ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight));
-
- closure = graph;
- newGA = setRemoteGA(graph, &ga, rtsTrue);
- if (ip->type == FETCH_ME)
- // FETCHME_GA(closure) = newGA;
- ((StgFetchMe *)closure)->ga = newGA;
- } else {
- /* Two closures, one global name. Someone loses */
- oldip = get_itbl(existing);
-
- if ((oldip->type == FETCH_ME ||
- // ToDo: don't pack a GA for these in the first place
- oldip->type == CONSTR ||
- oldip->type == CONSTR_1_0 ||
- oldip->type == CONSTR_0_1 ||
- oldip->type == CONSTR_2_0 ||
- oldip->type == CONSTR_1_1 ||
- oldip->type == CONSTR_0_2 ||
- IS_BLACK_HOLE(existing)) &&
- ip->type != FETCH_ME) {
-
- /* What we had wasn't worth keeping */
- closure = graph;
- CommonUp(existing, graph);
- } else {
- StgWord ty;
-
- /*
- * Either we already had something worthwhile by this name or
- * the new thing is just another FetchMe. However, the thing we
- * just unpacked has to be left as-is, or the child unpacking
- * code will fail. Remember that the way pointer words are
- * filled in depends on the info pointers of the parents being
- * the same as when they were packed.
- */
- IF_PAR_DEBUG(pack,
- belch("_* Unpacking old GA ((%x, %d, %x)), keeping %#lx",
- ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight,
- existing));
-
- closure = existing;
- // HACK
- ty = get_itbl(closure)->type;
- if (ty == CONSTR ||
- ty == CONSTR_1_0 ||
- ty == CONSTR_0_1 ||
- ty == CONSTR_2_0 ||
- ty == CONSTR_1_1 ||
- ty == CONSTR_0_2)
- CommonUp(closure, graph);
-
- }
- /* Pool the total weight in the stored ga */
- (void) addWeight(&ga);
+ belch("*<** UnackPAP @ %p: UPDATE_FRAME",
+ p));
+
+ ((StgUpdateFrame *)p)->header.info = *bufptr;
+ ((StgUpdateFrame *)p)->link= *bufptr++; // ToDo: fix intra-stack pointer
+ ((StgUpdateFrame *)p)->updatee = *bufptr; // ToDo: follow link
+
+ p += 3;
}
- /* Sort out the global address mapping */
- if (hasGA || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
- (ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
- /* Make up new GAs for single-copy closures */
- globalAddr *newGA = makeGlobal(closure, rtsTrue);
-
- // keep this assertion!
- // ASSERT(closure == graph);
-
- /* Create an old GA to new GA mapping */
- *gaga++ = ga;
- splitWeight(gaga, newGA);
- ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
- gaga++;
+ /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
+ case STOP_FRAME:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: STOP_FRAME",
+ p));
+ ((StgStopFrame *)p)->header.info = *bufptr;
+ p++;
}
- graph += _HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
- }
- /*
- * Set parent pointer to point to chosen closure. If we're at the top of
- * the graph (our parent is NULL), then we want to arrange to return the
- * chosen closure to our caller (possibly in place of the allocated graph
- * root.)
- */
- if (parent == NULL)
- graphroot = closure;
- else
- ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
+ case CATCH_FRAME:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: CATCH_FRAME",
+ p));
+
+ ((StgCatchFrame *)p)->header.info = *bufptr++;
+ ((StgCatchFrame *)p)->link = *bufptr++;
+ ((StgCatchFrame *)p)->exceptions_blocked = *bufptr++;
+ ((StgCatchFrame *)p)->handler = *bufptr++;
+ p += 4;
+ }
- /* Save closure pointer for resolving offsets */
- *slotptr = (StgWord) closure;
+ case SEQ_FRAME:
+ {
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
+ p));
- /* Locate next parent pointer */
- pptr++;
- while (pptr + 1 > pptrs) {
- parent = DeQueueClosure();
+ ((StgSeqFrame *)p)->header.info = *bufptr++;
+ ((StgSeqFrame *)p)->link = *bufptr++;
- if (parent == NULL)
- break;
- else {
- (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
- &pvhs, str);
- pptr = 0;
+ // ToDo: handle bitmap
+ bitmap = info->layout.bitmap;
+
+ p = (StgPtr)&(((StgClosure *)p)->payload);
+ goto small_bitmap;
}
- }
- } while (parent != NULL);
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL}",
+ p));
- //ASSERT(bufsize == 0 || graph - 1 <= SAVE_Hp);
- *gamap = PendingGABuffer;
- *nGAs = (gaga - PendingGABuffer) / 2;
+ ((StgClosure *)p)->header.info = *bufptr++;
+ p++;
+ // ToDo: handle bitmap
+ bitmap = info->layout.bitmap;
+ /* this assumes that the payload starts immediately after the info-ptr */
- /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
- ASSERT(graphroot!=NULL);
- return (graphroot);
+ small_bitmap:
+ while (bitmap != 0) {
+ if ((bitmap & 1) == 0) {
+ *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ } else {
+ *p++ = *bufptr++;
+ }
+ bitmap = bitmap >> 1;
+ }
+
+ follow_srt:
+ belch("*<-- UnpackPAP: nothing to do for follow_srt");
+ continue;
+
+ /* large bitmap (> 32 entries) */
+ case RET_BIG:
+ case RET_VEC_BIG:
+ {
+ StgPtr q;
+ StgLargeBitmap *large_bitmap;
+ nat i;
+
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
+ p, info->layout.large_bitmap));
+
+
+ ((StgClosure *)p)->header.info = *bufptr++;
+ p++;
+
+ large_bitmap = info->layout.large_bitmap;
+
+ for (j=0; j<large_bitmap->size; j++) {
+ bitmap = large_bitmap->bitmap[j];
+ q = p + sizeof(W_) * 8;
+ while (bitmap != 0) {
+ if ((bitmap & 1) == 0) {
+ *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ } else {
+ *p++ = *bufptr;
+ }
+ bitmap = bitmap >> 1;
+ }
+ if (j+1 < large_bitmap->size) {
+ while (p < q) {
+ *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ }
+ }
+ }
+
+ /* and don't forget to follow the SRT */
+ goto follow_srt;
+ }
+
+ default:
+ barf("UnpackPAP: weird activation record found on stack: %d",
+ (int)(info->type));
+ }
+ }
+ IF_PAR_DEBUG(pack,
+ belch("*<** UnpackPAP finished; unpacked closure @ %p is:",
+ (StgClosure *)graph);
+ printClosure((StgClosure *)graph));
+
+ IF_DEBUG(sanity, /* check sanity of unpacked PAP */
+ checkClosure(graph));
+
+ *bufptrP = bufptr;
+ return _HS+2+packed_size;
}
+
#endif /* PAR */
//@node GranSim Code, , Local Definitions, Unpacking routines
AmPacking(closure)
StgClosure *closure;
{
-/* IF_PAR_DEBUG(pack, */
-/* fprintf(stderr, "** AmPacking %p (%s)(IP %p) at %u\n", */
-/* closure, info_type(closure), get_itbl(closure), pack_locn)); */
-
insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
}
rtsBool found = rtsFalse;
for (i=0; (i<pack_locn) && !found; i++)
- found = Bonzo->buffer[i]==closure;
+ found = globalPackBuffer->buffer[i]==closure;
return (!found);
}
o the size and number of pointers held by any primitive arrays that it
points to
- It has a *side-effect* (naughty, naughty) in assigning RoomInBuffer
+ It has a *side-effect* (naughty, naughty) in assigning roomInBuffer
to rtsFalse.
*/
nat size, ptrs;
{
# if defined(PAR)
- if (RoomInBuffer &&
- (pack_locn + reservedPAsize + size +
- ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
+ if (roomInBuffer &&
+ (pack_locn + // where we are in the buffer right now
+ size + // space needed for the current closure
+ ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE // space for queued closures
+ >=
+ RTS_PACK_BUFFER_SIZE))
{
IF_PAR_DEBUG(pack,
- fprintf(stderr, "Buffer full\n"));
-
- RoomInBuffer = rtsFalse;
+ belch("*>** pack buffer full"));
+ roomInBuffer = rtsFalse;
}
# else /* GRAN */
- if (RoomInBuffer &&
- (unpacked_size + reservedPAsize + size +
+ if (roomInBuffer &&
+ (unpacked_size + size +
((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
{
- IF_GRAN_DEBUG(packBuffer,
- fprintf(stderr, "Buffer full\n"));
- RoomInBuffer = rtsFalse;
+ IF_GRAN_DEBUG(pack,
+ belch("*>** pack buffer full"));
+ roomInBuffer = rtsFalse;
}
# endif
- return (RoomInBuffer);
+ return (roomInBuffer);
}
//@node Types of Global Addresses, Closure Info, Packet size, Aux fcts for packing
# if defined(PAR)
//@cindex isOffset
-rtsBool
-isOffset(ga)
-globalAddr *ga;
+rtsBool inline
+isOffset(globalAddr *ga)
{
return (ga->weight == 1 && ga->payload.gc.gtid == 0);
}
//@cindex isFixed
-rtsBool
-isFixed(ga)
-globalAddr *ga;
+rtsBool inline
+isFixed(globalAddr *ga)
{
return (ga->weight == 0);
}
+
+//@cindex isConstr
+rtsBool inline
+isConstr(globalAddr *ga)
+{
+ return (ga->weight == 2);
+}
# endif
//@node Closure Info, , Types of Global Addresses, Aux fcts for packing
rtsPackBuffer *packBuffer;
{
StgClosure *parent, *graphroot, *closure_start;
- StgInfoTable *ip, *oldip;
+ const StgInfoTable *ip;
globalAddr ga;
StgWord **buffer, **bufptr, **slotptr;
nat bufsize;
nat pptr = 0, pptrs = 0, pvhs;
- nat unpack_locn = 0;
- nat gastart = unpack_locn;
- nat closurestart = unpack_locn;
+ nat locn = 0;
nat i;
nat size, ptrs, nonptrs, vhs;
char str[80];
unpacking components replaced by printing fcts
Long live higher-order fcts!
*/
- initPackBuffer(); /* in case it isn't already init'd */
- graphroot = (StgClosure *)NULL;
-
- // gaga = PendingGABuffer;
-
+ /* Initialisation */
+ //InitPackBuffer(); /* in case it isn't already init'd */
InitClosureQueue();
+ // ASSERT(gaga==PendingGABuffer);
+ graphroot = (StgClosure *)NULL;
/* Unpack the header */
bufsize = packBuffer->size;
- buffer = packBuffer->buffer;
- bufptr = buffer;
-
- /* allocate heap
- if (bufsize > 0) {
- graph = allocate(bufsize);
- ASSERT(graph != NULL);
- }
- */
+ bufptr = packBuffer->buffer;
- fprintf(stderr, ".* Printing <<%d>> (buffer @ %p):\n",
+ fprintf(stderr, "*. Printing <<%d>> (buffer @ %p):\n",
packBuffer->id, packBuffer);
- fprintf(stderr, ".* size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
+ fprintf(stderr, "*. size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
packBuffer->size, packBuffer->unpacked_size,
packBuffer->tso, packBuffer->buffer);
do {
/* This is where we will ultimately save the closure's address */
slotptr = bufptr;
+ locn = slotptr-(packBuffer->buffer); // index of closure in buffer
/* First, unpack the next GA or PLC */
ga.weight = (rtsWeight) *bufptr++;
/* Now unpack the closure body, if there is one */
if (isFixed(&ga)) {
- fprintf(stderr, ".* [%u]: PLC @ %p\n", gastart, ga.payload.plc);
+ fprintf(stderr, "*. %u: PLC @ %p\n", locn, ga.payload.plc);
// closure = ga.payload.plc;
} else if (isOffset(&ga)) {
- fprintf(stderr, ".* [%u]: OFFSET TO [%d]\n", gastart, ga.payload.gc.slot);
+ fprintf(stderr, "*. %u: OFFSET TO %d\n", locn, ga.payload.gc.slot);
// closure = (StgClosure *) buffer[ga.payload.gc.slot];
} else {
/* Print normal closures */
ASSERT(bufsize > 0);
- fprintf(stderr, ".* [%u]: ((%x, %d, %x)) ", gastart,
+ fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
closure_start = bufptr;
- ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
+ ip = get_closure_info((StgClosure *)bufptr,
+ &size, &ptrs, &nonptrs, &vhs, str);
+ /* ToDo: check whether this is really needed */
+ if (ip->type == FETCH_ME) {
+ size = _HS;
+ ptrs = nonptrs = vhs = 0;
+ }
+ /* ToDo: check whether this is really needed */
+ if (ip->type == ARR_WORDS) {
+ ptrs = vhs = 0;
+ nonptrs = ((StgArrWords *)bufptr)->words;
+ size = arr_words_sizeW((StgArrWords *)bufptr);
+ }
+
+ /* special code for printing a PAP in a buffer */
+ if (ip->type == PAP || ip->type == AP_UPD) {
+ vhs = 3;
+ ptrs = 0;
+ nonptrs = ((StgPAP *)bufptr)->payload[0];
+ size = _HS+vhs+ptrs+nonptrs;
+ }
+
/*
Remember, the generic closure layout is as follows:
+-------------------------------------------------+
if (ip->type == FETCH_ME)
size = ptrs = nonptrs = vhs = 0;
+ // VH is always empty in the new RTS
+ ASSERT(vhs==0 ||
+ ip->type == PAP || ip->type == AP_UPD);
/* Print variable header */
fprintf(stderr, "] VH [");
for (i = 0; i < vhs; i++)
fprintf(stderr, " %p", *bufptr++);
- fprintf(stderr, "] %d PTRS [", ptrs);
-
+ //fprintf(stderr, "] %d PTRS [", ptrs);
/* Pointers will be filled in later */
- fprintf(stderr, " ] %d NON-PTRS [", nonptrs);
+ fprintf(stderr, " ] (%d, %d) [", ptrs, nonptrs);
/* Print non-pointers */
for (i = 0; i < nonptrs; i++)
fprintf(stderr, " %p", *bufptr++);
}
}
} while (parent != NULL);
- fprintf(stderr, ".* --- End packet <<%d>> ---\n", packBuffer->id);
+ fprintf(stderr, "*. --- End packet <<%d>> (claimed size=%d; real size=%d)---\n",
+ packBuffer->id, packBuffer->size, size);
+
+}
+
+/*
+ Doing a sanity check on a packet.
+ This does a full iteration over the packet, as in PrintPacket.
+*/
+//@cindex checkPacket
+void
+checkPacket(packBuffer)
+rtsPackBuffer *packBuffer;
+{
+ StgClosure *parent, *graphroot, *closure_start;
+ const StgInfoTable *ip;
+ globalAddr ga;
+ StgWord **buffer, **bufptr, **slotptr;
+
+ nat bufsize;
+ nat pptr = 0, pptrs = 0, pvhs;
+ nat locn = 0;
+ nat size, ptrs, nonptrs, vhs;
+ char str[80];
+
+ /* NB: this whole routine is more or less a copy of UnpackGraph with all
+ unpacking components replaced by printing fcts
+ Long live higher-order fcts!
+ */
+ /* Initialisation */
+ //InitPackBuffer(); /* in case it isn't already init'd */
+ InitClosureQueue();
+ // ASSERT(gaga==PendingGABuffer);
+ graphroot = (StgClosure *)NULL;
+
+ /* Unpack the header */
+ bufsize = packBuffer->size;
+ bufptr = packBuffer->buffer;
+ parent = (StgClosure *)NULL;
+ ASSERT(bufsize > 0);
+ do {
+ /* This is where we will ultimately save the closure's address */
+ slotptr = bufptr;
+ locn = slotptr-(packBuffer->buffer); // index of closure in buffer
+ ASSERT(locn<=bufsize);
+
+ /* First, check whether we have a GA, a PLC, or an OFFSET at hand */
+ ga.weight = (rtsWeight) *bufptr++;
+ if (ga.weight > 0) {
+ ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
+ ga.payload.gc.slot = (int) *bufptr++;
+ } else
+ ga.payload.plc = (StgPtr) *bufptr++;
+
+ /* Now unpack the closure body, if there is one */
+ if (isFixed(&ga)) {
+ /* It's a PLC */
+ ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
+ } else if (isOffset(&ga)) {
+ ASSERT(ga.payload.gc.slot<=bufsize);
+ } else {
+ /* normal closure */
+ ASSERT(LOOKS_LIKE_GA(&ga));
+
+ closure_start = bufptr;
+ ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
+ ip = get_closure_info((StgClosure *)bufptr,
+ &size, &ptrs, &nonptrs, &vhs, str);
+
+ /* ToDo: check whether this is really needed */
+ if (ip->type == FETCH_ME) {
+ size = _HS;
+ ptrs = nonptrs = vhs = 0;
+ }
+ /* ToDo: check whether this is really needed */
+ if (ip->type == ARR_WORDS) {
+ ptrs = vhs = 0;
+ nonptrs = ((StgArrWords *)bufptr)->words+1; // payload+words
+ size = arr_words_sizeW((StgArrWords *)bufptr);
+ ASSERT(size==_HS+vhs+nonptrs);
+ }
+ /* special code for printing a PAP in a buffer */
+ if (ip->type == PAP || ip->type == AP_UPD) {
+ vhs = 3;
+ ptrs = 0;
+ nonptrs = ((StgPAP *)bufptr)->payload[0];
+ size = _HS+vhs+ptrs+nonptrs;
+ }
+
+ /* no checks on contents of closure (pointers aren't packed anyway) */
+ ASSERT(_HS+vhs+nonptrs>=MIN_NONUPD_SIZE);
+ bufptr += _HS+vhs+nonptrs;
+
+ /* Add to queue for processing */
+ QueueClosure((StgClosure *)closure_start);
+
+ /* No Common up needed for checking */
+
+ /* No Sort out the global address mapping for checking */
+
+ } /* normal closure case */
+
+ /* Locate next parent pointer */
+ pptr++;
+ while (pptr + 1 > pptrs) {
+ parent = DeQueueClosure();
+
+ if (parent == NULL)
+ break;
+ else {
+ //ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*parent));
+ (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
+ &pvhs, str);
+ pptr = 0;
+ }
+ }
+ } while (parent != NULL);
+ /* we unpacked exactly as many words as there are in the buffer */
+ ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
}
#else /* GRAN */
void
//@node End of file, , Printing Packet Contents, Graph packing
//@subsection End of file
+
//@index
-//* AllocClosureQueue:: @cindex\s-+AllocClosureQueue
//* AllocateHeap:: @cindex\s-+AllocateHeap
//* AmPacking:: @cindex\s-+AmPacking
//* CommonUp:: @cindex\s-+CommonUp
//* DeQueueClosure:: @cindex\s-+DeQueueClosure
+//* DeQueueClosure:: @cindex\s-+DeQueueClosure
//* DonePacking:: @cindex\s-+DonePacking
+//* FillInClosure:: @cindex\s-+FillInClosure
//* IS_BLACK_HOLE:: @cindex\s-+IS_BLACK_HOLE
//* IS_INDIRECTION:: @cindex\s-+IS_INDIRECTION
//* InitClosureQueue:: @cindex\s-+InitClosureQueue
//* InitPendingGABuffer:: @cindex\s-+InitPendingGABuffer
+//* LocateNextParent:: @cindex\s-+LocateNextParent
//* NotYetPacking:: @cindex\s-+NotYetPacking
//* OffsetFor:: @cindex\s-+OffsetFor
//* Pack:: @cindex\s-+Pack
+//* PackArray:: @cindex\s-+PackArray
//* PackClosure:: @cindex\s-+PackClosure
+//* PackFetchMe:: @cindex\s-+PackFetchMe
+//* PackGeneric:: @cindex\s-+PackGeneric
//* PackNearbyGraph:: @cindex\s-+PackNearbyGraph
//* PackOneNode:: @cindex\s-+PackOneNode
+//* PackPAP:: @cindex\s-+PackPAP
//* PackPLC:: @cindex\s-+PackPLC
//* PackStkO:: @cindex\s-+PackStkO
//* PackTSO:: @cindex\s-+PackTSO
//* QueueClosure:: @cindex\s-+QueueClosure
//* QueueEmpty:: @cindex\s-+QueueEmpty
//* RoomToPack:: @cindex\s-+RoomToPack
+//* SetGAandCommonUp:: @cindex\s-+SetGAandCommonUp
+//* UnpackGA:: @cindex\s-+UnpackGA
//* UnpackGraph:: @cindex\s-+UnpackGraph
+//* UnpackOffset:: @cindex\s-+UnpackOffset
+//* UnpackPLC:: @cindex\s-+UnpackPLC
//* doGlobalGC:: @cindex\s-+doGlobalGC
//* get_closure_info:: @cindex\s-+get_closure_info
-//* get_closure_info:: @cindex\s-+get_closure_info
-//* initPackBuffer:: @cindex\s-+initPackBuffer
+//* InitPackBuffer:: @cindex\s-+initPackBuffer
//* isFixed:: @cindex\s-+isFixed
//* isOffset:: @cindex\s-+isOffset
//* offsetTable:: @cindex\s-+offsetTable
//@end index
+
/* --------------------------------------------------------------------------
- Time-stamp: <Sat Dec 04 1999 18:26:22 Stardate: [-30]3998.84 hwloidl>
- $Id: ParInit.c,v 1.2 2000/01/13 14:34:08 hwloidl Exp $
+ Time-stamp: <Fri Mar 24 2000 17:42:24 Stardate: [-30]4553.68 hwloidl>
+ $Id: ParInit.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
Initialising the parallel RTS
see RtsFlags.ParFlags.maxLocalSparks */
nat spark_limit[SPARK_POOLS];
-globalAddr theGlobalFromGA, theGlobalToGA;
-/*
- HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK !! see FETCH_ME_entry
- Only used within FETCH_ME_entry as local vars, but they shouldn't
- be defined locally in there -- that would move %esp and you'll never
- return from STG land.
- -- HWL
-*/
-globalAddr *rga_GLOBAL;
-globalAddr *lga_GLOBAL;
-globalAddr fmbqga_GLOBAL;
-StgClosure *p_GLOBAL;
-
//@cindex PendingFetches
/* A list of fetch reply messages not yet processed; this list is filled
by awaken_blocked_queue and processed by processFetches */
//@cindex advisory_thread_count
nat advisory_thread_count = 0;
-/* Where to write the log file
- This is now in Parallel.c
-FILE *gr_file = NULL;
-char gr_filename[STATS_FILENAME_MAXLEN];
-*/
-
-/* Flag handling. */
+/* For flag handling see RtsFlags.h */
-#if 0
-/* that's now all done via RtsFlags.ParFlags... */
-rtsBool TraceSparks = rtsFalse; /* Enable the spark trace mode */
-rtsBool SparkLocally = rtsFalse; /* Use local threads if possible */
-rtsBool DelaySparks = rtsFalse; /* Use delayed sparking */
-rtsBool LocalSparkStrategy = rtsFalse; /* Either delayed threads or local threads*/
-rtsBool GlobalSparkStrategy = rtsFalse; /* Export all threads */
+//@node Prototypes
+//@subsection Prototypes
-rtsBool DeferGlobalUpdates = rtsFalse; /* Defer updating of global nodes */
-#endif
+/* Needed for FISH messages (initialisation of random number generator) */
+void srand48 (long);
+time_t time (time_t *);
//@node Initialisation Routines, , Global variables
//@subsection Initialisation Routines
void
shutdownParallelSystem(StgInt n)
{
- belch(" entered shutdownParallelSystem ...");
+ belch("==== entered shutdownParallelSystem ...");
ASSERT(GlobalStopPending = rtsTrue);
sendOp(PP_FINISH, SysManTask);
if (n != 0)
belch("--++ shutting down PE %lx, %ld sparks created, %ld sparks Ignored, %ld threads created, %ld threads Ignored",
(W_) mytid, sparksCreated, sparksIgnored,
threadsCreated, threadsIgnored));
- exit(n);
+ if (n!=0)
+ exit(n);
}
-/* Some prototypes */
-void srand48 (long);
-time_t time (time_t *);
-
//@cindex initParallelSystem
void
initParallelSystem(void)
{
- belch("entered initParallelSystem ...");
-
/* Don't buffer standard channels... */
setbuf(stdout,NULL);
setbuf(stderr,NULL);
srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
/* Used to select target of FISH message*/
- theGlobalFromGA.payload.gc.gtid = 0;
- theGlobalToGA.payload.gc.gtid = 0;
-
- //IF_PAR_DEBUG(verbose,
- belch("initPackBuffer ...");
- if (!initPackBuffer())
- barf("initPackBuffer");
+ if (!InitPackBuffer())
+ barf("InitPackBuffer");
- // IF_PAR_DEBUG(verbose,
- belch("initMoreBuffers ...");
if (!initMoreBuffers())
barf("initMoreBuffers");
- // IF_PAR_DEBUG(verbose,
- belch("initSparkPools ...");
if (!initSparkPools())
barf("initSparkPools");
}
{
int i;
- fprintf(stderr, "SynchroniseSystem: nPEs=%d\n", nPEs);
+ fprintf(stderr, "==== SynchroniseSystem: nPEs=%d\n", nPEs);
initEachPEHook(); /* HWL: hook to be execed on each PE */
- fprintf(stderr, "SynchroniseSystem: initParallelSystem\n");
+ fprintf(stderr, "==== SynchroniseSystem: initParallelSystem\n");
initParallelSystem();
allPEs = startUpPE(nPEs);
/* Record the shortened the PE identifiers for LAGA etc. tables */
for (i = 0; i < nPEs; ++i) {
- fprintf(stderr, "[%x] registering %d-th PE as %x\n", mytid, i, allPEs[i]);
+ fprintf(stderr, "==== [%x] registering %d-th PE as %x\n", mytid, i, allPEs[i]);
registerTask(allPEs[i]);
}
}
/*
- Time-stamp: <Sat Dec 04 1999 19:43:39 Stardate: [-30]3999.10 hwloidl>
+ Time-stamp: <Thu Mar 23 2000 18:20:17 Stardate: [-30]4548.82 hwloidl>
Basic functions for use in either GranSim or GUM.
*/
#include "GranSimRts.h"
#include "ParallelRts.h"
-
//@node Variables and constants, Writing to the log-file, Includes
//@subsection Variables and constants
ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
fprintf(gr_file, "PE %2u [%s]: TIME\n", thisPE, time_string);
- /*
+# if 0
+ ngoq Dogh'q' vImuS
IF_PAR_DEBUG(verbose,
belch("== Start-time: %ld (%s)",
startTime, time_string));
- */
-# if 0
- ngoq Dogh'q' vImuS
if (startTime > LL(1000000000)) {
fprintf(gr_file, "PE %2u [%lu%lu]: TIME\n", thisPE,
FILE *output_file; // DEBUGGING ONLY !!!!!!!!!!!!!!!!!!!!!!!!!1
StgWord id;
char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
- ullong_format_string(TIME_ON_PROC(proc), time_string, rtsFalse/*no commas!*/);
-
+# if defined(GRAN)
+ ullong_format_string(TIME_ON_PROC(proc),
+ time_string, rtsFalse/*no commas!*/);
+# elif defined(PAR)
+ ullong_format_string(CURRENT_TIME,
+ time_string, rtsFalse/*no commas!*/);
+# endif
output_file = gr_file;
- ASSERT(output_file!=NULL);
# if defined(GRAN)
+ if (RtsFlags.GranFlags.GranSimStats.Full)
+ ASSERT(output_file!=NULL);
+
IF_DEBUG(gran,
fprintf(stderr, "GRAN: Dumping info to file with handle %#x\n", output_file))
if (RtsFlags.GranFlags.GranSimStats.Suppressed)
return;
+# elif defined(PAR)
+ if (RtsFlags.ParFlags.ParStats.Full)
+ ASSERT(output_file!=NULL);
# endif
id = tso == NULL ? -1 : tso->id;
rtsBool mandatory_thread;
{
FILE *output_file; // DEBUGGING ONLY !!!!!!!!!!!!!!!!!!!!!!!!!1
- char time_string[TIME_STR_LEN];
- ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
+ char time_string[TIME_STR_LEN];
+# if defined(GRAN)
+ ullong_format_string(TIME_ON_PROC(proc),
+ time_string, rtsFalse/*no commas!*/);
+# elif defined(PAR)
+ ullong_format_string(CURRENT_TIME,
+ time_string, rtsFalse/*no commas!*/);
+# endif
output_file = gr_file;
ASSERT(output_file!=NULL);
}
#endif /* 0 */
+/*
+ extracting specific info out of a closure; used in packing (GranSim, GUM)
+*/
+//@cindex get_closure_info
+StgInfoTable*
+get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs,
+ nat *vhs, char *info_hdr_ty)
+{
+ StgInfoTable *info;
+
+ ASSERT(LOOKS_LIKE_COOL_CLOSURE(node));
+ info = get_itbl(node);
+ /* the switch shouldn't be necessary, really; just use default case */
+ switch (info->type) {
+ case RBH:
+ {
+ StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
+ *size = sizeW_fromITBL(rip);
+ *ptrs = (nat) (rip->layout.payload.ptrs);
+ *nonptrs = (nat) (rip->layout.payload.nptrs);
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+#if 0 /* DEBUG */
+ info_hdr_type(node, info_hdr_ty);
+#else
+ strcpy(info_hdr_ty, "RBH");
+#endif
+ return rip; // NB: we return the reverted info ptr for a RBH!!!!!!
+ }
+
+#if defined(PAR)
+ /* Closures specific to GUM */
+ case FETCH_ME:
+ *size = sizeofW(StgFetchMe);
+ *ptrs = (nat)0;
+ *nonptrs = (nat)0;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+#if 0 /* DEBUG */
+ info_hdr_type(node, info_hdr_ty);
+#else
+ strcpy(info_hdr_ty, "FETCH_ME");
+#endif
+ return info;
+
+ case FETCH_ME_BQ:
+ *size = sizeofW(StgFetchMeBlockingQueue);
+ *ptrs = (nat)0;
+ *nonptrs = (nat)0;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+#if 0 /* DEBUG */
+ info_hdr_type(node, info_hdr_ty);
+#else
+ strcpy(info_hdr_ty, "FETCH_ME_BQ");
+#endif
+ return info;
+
+ case BLOCKED_FETCH:
+ *size = sizeofW(StgBlockedFetch);
+ *ptrs = (nat)0;
+ *nonptrs = (nat)0;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+#if 0 /* DEBUG */
+ info_hdr_type(node, info_hdr_ty);
+#else
+ strcpy(info_hdr_ty, "BLOCKED_FETCH");
+#endif
+ return info;
+#endif /* PAR */
+
+ /* these magic constants are outrageous!! why does the ITBL lie about it? */
+ case THUNK_SELECTOR:
+ *size = THUNK_SELECTOR_sizeW();
+ *ptrs = 1;
+ *nonptrs = MIN_UPD_SIZE-*ptrs; // weird
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+ return info;
+
+ case ARR_WORDS:
+ /* ToDo: check whether this can be merged with the default case */
+ *size = arr_words_sizeW((StgArrWords *)node);
+ *ptrs = 0;
+ *nonptrs = ((StgArrWords *)node)->words;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+ return info;
+
+ case PAP:
+ /* ToDo: check whether this can be merged with the default case */
+ *size = pap_sizeW((StgPAP *)node);
+ *ptrs = 0;
+ *nonptrs = 0;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+ return info;
+
+ case AP_UPD:
+ /* ToDo: check whether this can be merged with the default case */
+ *size = AP_sizeW(((StgAP_UPD *)node)->n_args);
+ *ptrs = 0;
+ *nonptrs = 0;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+ return info;
+
+ default:
+ *size = sizeW_fromITBL(info);
+ *ptrs = (nat) (info->layout.payload.ptrs);
+ *nonptrs = (nat) (info->layout.payload.nptrs);
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+#if 0 /* DEBUG */
+ info_hdr_type(node, info_hdr_ty);
+#else
+ strcpy(info_hdr_ty, "UNKNOWN");
+#endif
+ return info;
+ }
+}
+
+//@cindex IS_BLACK_HOLE
+rtsBool
+IS_BLACK_HOLE(StgClosure* node)
+{
+ // StgInfoTable *info;
+ ASSERT(LOOKS_LIKE_COOL_CLOSURE(node));
+ switch (get_itbl(node)->type) {
+ case BLACKHOLE:
+ case BLACKHOLE_BQ:
+ case RBH:
+ case FETCH_ME:
+ case FETCH_ME_BQ:
+ return rtsTrue;
+ default:
+ return rtsFalse;
+ }
+//return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
+}
+
+//@cindex IS_INDIRECTION
+StgClosure *
+IS_INDIRECTION(StgClosure* node)
+{
+ StgInfoTable *info;
+ ASSERT(LOOKS_LIKE_COOL_CLOSURE(node));
+ info = get_itbl(node);
+ switch (info->type) {
+ case IND:
+ case IND_OLDGEN:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case IND_STATIC:
+ /* relies on indirectee being at same place for all these closure types */
+ return (((StgInd*)node) -> indirectee);
+#if 0
+ case EVACUATED: // counting as ind to use in GC routines, too
+ // could use the same code as above (evacuee is at same pos as indirectee)
+ return (((StgEvacuated *)node) -> evacuee);
+#endif
+ default:
+ return NULL;
+ }
+}
+
+//@cindex unwindInd
+StgClosure *
+UNWIND_IND (StgClosure *closure)
+{
+ StgClosure *next;
+
+ while ((next = IS_INDIRECTION((StgClosure *)closure)) != NULL)
+ closure = next;
+
+ ASSERT(next==(StgClosure *)NULL);
+ ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
+ return closure;
+}
+
#endif /* GRAN || PAR whole file */
/*
- Time-stamp: <Fri Jan 14 2000 13:52:00 Stardate: [-30]4202.88 hwloidl>
+ Time-stamp: <Mon Mar 20 2000 19:27:38 Stardate: [-30]4534.05 hwloidl>
Various debugging routines for GranSim and GUM
*/
fprintf(stderr,"> Id: \t%#lx",closure->id);
// fprintf(stderr,"\tstate: \t%#lx",closure->state);
- fprintf(stderr,"\twhatNext: \t%#lx",closure->whatNext);
+ fprintf(stderr,"\twhat_next: \t%#lx",closure->what_next);
fprintf(stderr,"\tlink: \t%#lx\n",closure->link);
+ fprintf(stderr,"\twhy_blocked: \t%d", closure->why_blocked);
+ fprintf(stderr,"\tblock_info: \t%p\n", closure->block_info);
// fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
fprintf(stderr,">PRI: \t%#lx", closure->gran.pri);
fprintf(stderr,"\tMAGIC: \t%#lx %s\n", closure->gran.magic,
for (j=0; j<indent_level; j++)
fputs(" ", stderr);
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
- || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
+ ASSERT(p!=(StgClosure*)NULL);
+ ASSERT(LOOKS_LIKE_STATIC(p) ||
+ LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p)) ||
+ IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p)));
printClosure(p); // prints contents of this one closure
//p += sizeofW(StgCAF);
break;
}
-
+
case MUT_VAR:
/* ignore MUT_CONSs */
fprintf(stderr, "MUT_VAR (%p) pointing to %p\n", p, ((StgMutVar *)p)->var);
fprintf(stderr, "PAP (%p) pointing to %p\n", p, pap->fun);
// pap->fun =
- PrintGraph(pap->fun, indent_level+1);
+ //PrintGraph(pap->fun, indent_level+1);
//scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
//p += pap_sizeW(pap);
break;
}
case ARR_WORDS:
- fprintf(stderr, "ARR_WORDS (%p) with 0 pointers\n", p);
- /* nothing to follow */
- //p += arr_words_sizeW(stgCast(StgArrWords*,p));
+ /* an array of (non-mutable) words */
+ fprintf(stderr, "ARR_WORDS (%p) of %d non-ptrs (maybe a string?)\n",
+ p, ((StgArrWords *)q)->words);
break;
-
+
case MUT_ARR_PTRS:
/* follow everything */
{
//}
}
+/*
+ Do a sanity check on the whole graph, down to a recursion level of level.
+ Same structure as PrintGraph (nona).
+*/
+void
+checkGraph(StgClosure *p, int rec_level)
+{
+ StgPtr x, q;
+ nat i, j;
+ const StgInfoTable *info;
+
+ if (rec_level==0)
+ return;
+
+ q = p; /* save ptr to object */
+
+ /* First, the obvious generic checks */
+ ASSERT(p!=(StgClosure*)NULL);
+ checkClosure(p); /* see Sanity.c for what's actually checked */
+
+ info = get_itbl((StgClosure *)p);
+ /* the rest of this fct recursively traverses the graph */
+ switch (info -> type) {
+
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,p);
+ nat i;
+ for (i = 0; i < bco->n_ptrs; i++) {
+ checkGraph(bcoConstCPtr(bco,i), rec_level-1);
+ }
+ break;
+ }
+
+ case MVAR:
+ /* treat MVars specially, because we don't want to PrintGraph the
+ * mut_link field in the middle of the closure.
+ */
+ {
+ StgMVar *mvar = ((StgMVar *)p);
+ checkGraph((StgClosure *)mvar->head, rec_level-1);
+ checkGraph((StgClosure *)mvar->tail, rec_level-1);
+ checkGraph((StgClosure *)mvar->value, rec_level-1);
+ break;
+ }
+
+ case THUNK_2_0:
+ case FUN_2_0:
+ case CONSTR_2_0:
+ checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
+ checkGraph(((StgClosure *)p)->payload[1], rec_level-1);
+ break;
+
+ case THUNK_1_0:
+ checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
+ break;
+
+ case FUN_1_0:
+ case CONSTR_1_0:
+ checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
+ break;
+
+ case THUNK_0_1:
+ break;
+
+ case FUN_0_1:
+ case CONSTR_0_1:
+ break;
+
+ case THUNK_0_2:
+ case FUN_0_2:
+ case CONSTR_0_2:
+ break;
+
+ case THUNK_1_1:
+ case FUN_1_1:
+ case CONSTR_1_1:
+ checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
+ break;
+
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ for (i=0; i<info->layout.payload.ptrs; i++)
+ checkGraph(((StgClosure *)p)->payload[i], rec_level-1);
+ break;
+
+ case WEAK:
+ case FOREIGN:
+ case STABLE_NAME:
+ {
+ StgPtr end;
+
+ end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
+ for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
+ checkGraph(*(StgClosure **)p, rec_level-1);
+ }
+ break;
+ }
+
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ checkGraph(((StgIndOldGen *)p)->indirectee, rec_level-1);
+ break;
+
+ case CAF_UNENTERED:
+ {
+ StgCAF *caf = (StgCAF *)p;
+
+ fprintf(stderr, "CAF_UNENTERED (%p) pointing to %p\n", p, caf->body);
+ checkGraph(caf->body, rec_level-1);
+ break;
+ }
+
+ case CAF_ENTERED:
+ {
+ StgCAF *caf = (StgCAF *)p;
+
+ fprintf(stderr, "CAF_ENTERED (%p) pointing to %p and %p\n",
+ p, caf->body, caf->value);
+ checkGraph(caf->body, rec_level-1);
+ checkGraph(caf->value, rec_level-1);
+ break;
+ }
+
+ case MUT_VAR:
+ /* ignore MUT_CONSs */
+ if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
+ checkGraph(((StgMutVar *)p)->var, rec_level-1);
+ }
+ break;
+
+ case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
+ case BLACKHOLE:
+ break;
+
+ case BLACKHOLE_BQ:
+ break;
+
+ case THUNK_SELECTOR:
+ {
+ StgSelector *s = (StgSelector *)p;
+ checkGraph(s->selectee, rec_level-1);
+ break;
+ }
+
+ case IND:
+ checkGraph(((StgInd*)p)->indirectee, rec_level-1);
+ break;
+
+ case IND_OLDGEN:
+ checkGraph(((StgIndOldGen*)p)->indirectee, rec_level-1);
+ break;
+
+ case CONSTR_INTLIKE:
+ break;
+ case CONSTR_CHARLIKE:
+ break;
+ case CONSTR_STATIC:
+ break;
+ case CONSTR_NOCAF_STATIC:
+ break;
+ case THUNK_STATIC:
+ break;
+ case FUN_STATIC:
+ break;
+ case IND_STATIC:
+ break;
+
+ case RET_BCO:
+ break;
+ case RET_SMALL:
+ break;
+ case RET_VEC_SMALL:
+ break;
+ case RET_BIG:
+ break;
+ case RET_VEC_BIG:
+ break;
+ case RET_DYN:
+ break;
+ case UPDATE_FRAME:
+ break;
+ case STOP_FRAME:
+ break;
+ case CATCH_FRAME:
+ break;
+ case SEQ_FRAME:
+ break;
+
+ case AP_UPD: /* same as PAPs */
+ case PAP:
+ /* Treat a PAP just like a section of stack, not forgetting to
+ * checkGraph the function pointer too...
+ */
+ {
+ StgPAP* pap = stgCast(StgPAP*,p);
+
+ checkGraph(pap->fun, rec_level-1);
+ break;
+ }
+
+ case ARR_WORDS:
+ break;
+
+ case MUT_ARR_PTRS:
+ /* follow everything */
+ {
+ StgPtr next;
+
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ checkGraph(*(StgClosure **)p, rec_level-1);
+ }
+ break;
+ }
+
+ case MUT_ARR_PTRS_FROZEN:
+ /* follow everything */
+ {
+ StgPtr start = p, next;
+
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ checkGraph(*(StgClosure **)p, rec_level-1);
+ }
+ break;
+ }
+
+ case TSO:
+ {
+ StgTSO *tso;
+
+ tso = (StgTSO *)p;
+ checkGraph((StgClosure *)tso->link, rec_level-1);
+ break;
+ }
+
+#if defined(GRAN) || defined(PAR)
+ case RBH:
+ break;
+#endif
+#if defined(PAR)
+ case BLOCKED_FETCH:
+ break;
+ case FETCH_ME:
+ break;
+ case FETCH_ME_BQ:
+ break;
+#endif
+ case EVACUATED:
+ barf("checkGraph: found EVACUATED closure %p (%s)",
+ p, info_type(p));
+ break;
+
+ default:
+ }
+}
+
#endif /* GRAN */
#endif /* GRAN || PAR */
/*
- Time-stamp: <Fri Jan 14 2000 13:47:43 Stardate: [-30]4202.87 hwloidl>
+ Time-stamp: <Tue Mar 14 2000 17:15:59 Stardate: [-30]4503.59 hwloidl>
Prototypes of all parallel debugging functions.
- */
+*/
#ifndef PARALLEL_DEBUG_H
#define PARALLEL_DEBUG_H
#if defined(GRAN) || defined(PAR)
char *display_info_type(StgClosure *closure, char *str);
+void info_hdr_type(StgClosure *closure, char *res);
+char *info_type(StgClosure *closure);
+char *info_type_by_ip(StgInfoTable *ip);
void PrintPacket(rtsPackBuffer *buffer);
void PrintGraph(StgClosure *p, int indent_level);
+void checkGraph(StgClosure *p, int rec_level);
+
+void checkPacket(rtsPackBuffer *packBuffer);
#endif /* GRAN || PAR */
/* --------------------------------------------------------------------------
- Time-stamp: <Wed Jan 12 2000 16:22:43 Stardate: [-30]4194.45 hwloidl>
- $Id: ParallelRts.h,v 1.2 2000/01/13 14:34:09 hwloidl Exp $
+ Time-stamp: <Wed Mar 29 2000 19:10:29 Stardate: [-30]4578.78 hwloidl>
+ $Id: ParallelRts.h,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
Variables and functions specific to the parallel RTS (i.e. GUM or GranSim)
----------------------------------------------------------------------- */
#if defined(GRAN) || defined(PAR)
-//@menu
-//* Packing routines::
-//* Spark handling routines::
-//* GC routines::
-//* Debugging routines::
-//* Generating .gr profiles::
-//* Common macros::
-//* Index::
-//@end menu
-
-#ifndef GRAN
-// Dummy def for NO_PRI if not in GranSim
-#define NO_PRI 0
-#endif
-
-//@node Packing routines, Spark handling routines
-//@subsection Packing routines
-
#if defined(GRAN)
+
/* Statistics info */
extern nat tot_packets, tot_packet_size, tot_cuts, tot_thunks;
-#endif
-#if defined(GRAN)
/* Pack.c */
rtsPackBuffer *PackNearbyGraph(StgClosure* closure, StgTSO* tso,
nat *packBufferSize);
StgClosure *convertToRBH(StgClosure *closure);
void convertFromRBH(StgClosure *closure);
+/* HLComms.c */
+rtsFetchReturnCode blockFetch(StgTSO* tso, PEs proc, StgClosure* bh);
+void blockThread(StgTSO *tso);
+
/* General closure predicates */
/*
{Parallel.h}Daq ngoqvam vIroQpu'
rtsBool IS_THUNK(StgClosure* closure);
*/
-#elif defined(PAR)
+#endif
+#if defined(PAR)
/* Pack.c */
rtsPackBuffer *PackNearbyGraph(StgClosure* closure, StgTSO* tso,
nat *packBufferSize);
-rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
-rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
-void PackFetchMe(StgClosure *closure);
-
/* Unpack.c */
void CommonUp(StgClosure *src, StgClosure *dst);
StgClosure *UnpackGraph(rtsPackBuffer *buffer, globalAddr **gamap,
StgClosure *convertToRBH(StgClosure *closure);
void convertToFetchMe(StgRBH *rbh, globalAddr *ga);
+/* HLComms.c */
+void blockFetch(StgBlockedFetch *bf, StgClosure *bh);
+void blockThread(StgTSO *tso);
+
+/* Global.c */
+void GALAdeprecate(globalAddr *ga);
+
/* General closure predicates */
/*
{Parallel.h}Daq ngoqvam vIroQpu'
*/
void doGlobalGC(void);
-//@node Spark handling routines, GC routines, Packing routines
-//@subsection Spark handling routines
-
-/* now in ../Sparks.c */
-
-#if 0
-
-#if defined(PAR)
-
-rtsSpark findLocalSpark(rtsBool forexport);
-StgTSO* activateSpark (rtsSpark spark);
-void disposeSpark(rtsSpark spark);
-rtsBool add_to_spark_queue(StgClosure *closure, rtsBool required);
-rtsBool initSparkPools (void);
-
-nat spark_queue_len(nat pool);
-void markSparkQueue(void);
-void print_sparkq(void);
-
-#elif defined(GRAN)
-
-void findLocalSpark (rtsEvent *event,
- rtsBool *found_res, rtsSparkQ *spark_res);
-rtsBool activateSpark (rtsEvent *event, rtsSparkQ spark);
-rtsSpark *newSpark (StgClosure *node, StgInt name, StgInt gran_info,
- StgInt size_info, StgInt par_info, StgInt local);
-void disposeSpark(rtsSpark *spark);
-void disposeSparkQ(rtsSparkQ spark);
-void add_to_spark_queue(rtsSpark *spark);
-void print_spark(rtsSpark *spark);
-nat spark_queue_len(PEs proc);
-rtsSpark *delete_from_sparkq (rtsSpark *spark, PEs p, rtsBool dispose_too);
-void markSparkQueue(void);
-void print_sparkq(PEs proc);
-void print_sparkq_stats(void);
-
-#endif
-#endif /* 0 */
-
//@node GC routines, Debugging routines, Spark handling routines
//@subsection GC routines
void printGA (globalAddr *ga);
void printGALA (GALA *gala);
void printLAGAtable(void);
+
+rtsBool isOnLiveIndTable(globalAddr *ga);
+rtsBool isOnRemoteGATable(globalAddr *ga);
+void checkFreeGALAList(void);
+void checkFreeIndirectionsList(void);
#endif
-//@node Generating .gr profiles, Common macros, Debugging routines
+//@node Generating .gr profiles, Index, Debugging routines
//@subsection Generating .gr profiles
#define STATS_FILENAME_MAXLEN 128
extern FILE *gr_file;
extern char gr_filename[STATS_FILENAME_MAXLEN];
+//@cindex init_gr_stats
//@cindex init_gr_simulation
//@cindex end_gr_simulation
+void init_gr_stats (void);
void init_gr_simulation(int rts_argc, char *rts_argv[],
int prog_argc, char *prog_argv[]);
void end_gr_simulation(void);
+// TODO: move fcts in here (as static inline)
+StgInfoTable* get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs, nat *vhs, char *info_hdr_ty);
+rtsBool IS_BLACK_HOLE(StgClosure* node);
+StgClosure *IS_INDIRECTION(StgClosure* node) ;
+StgClosure *UNWIND_IND (StgClosure *closure);
+
+
+#endif /* defined(PAR) || defined(GRAN) */
+
//@node Common macros, Index, Generating .gr profiles
//@subsection Common macros
-/*
- extracting specific info out of a closure; used in packing (GranSim, GUM)
+#define LOOKS_LIKE_PTR(r) \
+ (LOOKS_LIKE_STATIC_CLOSURE(r) || \
+ ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1)))
+
+/* see Sanity.c for this kind of test; doing this in these basic fcts
+ is paranoid (nuke it after debugging!)
*/
-//@cindex get_closure_info
-static inline StgInfoTable*
-get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
-StgClosure* node;
-nat *size, *ptrs, *nonptrs, *vhs;
-char *info_hdr_ty;
-{
- StgInfoTable *info;
-
- info = get_itbl(node);
- /* the switch shouldn't be necessary, really; just use default case */
- switch (info->type) {
- case RBH:
- {
- StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
- *size = sizeW_fromITBL(rip);
- *ptrs = (nat) (rip->layout.payload.ptrs);
- *nonptrs = (nat) (rip->layout.payload.nptrs);
- *vhs = (nat) 0; // unknown
-#if 0 /* DEBUG */
- info_hdr_type(node, info_hdr_ty);
-#else
- strcpy(info_hdr_ty, "UNKNOWN");
-#endif
- return rip; // NB: we return the reverted info ptr for a RBH!!!!!!
- }
-
- default:
- *size = sizeW_fromITBL(info);
- *ptrs = (nat) (info->layout.payload.ptrs);
- *nonptrs = (nat) (info->layout.payload.nptrs);
- *vhs = (nat) 0; // unknown
-#if 0 /* DEBUG */
- info_hdr_type(node, info_hdr_ty);
-#else
- strcpy(info_hdr_ty, "UNKNOWN");
-#endif
- return info;
- }
-}
-
-//@cindex IS_BLACK_HOLE
-static inline rtsBool
-IS_BLACK_HOLE(StgClosure* node)
-{
- StgInfoTable *info;
- switch (get_itbl(node)->type) {
- case BLACKHOLE:
- case BLACKHOLE_BQ:
- case RBH:
- case FETCH_ME:
- case FETCH_ME_BQ:
- return rtsTrue;
- default:
- return rtsFalse;
- }
-//return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
-}
-
-//@cindex IS_INDIRECTION
-static inline StgClosure *
-IS_INDIRECTION(StgClosure* node)
-{
- StgInfoTable *info;
- info = get_itbl(node);
- switch (info->type) {
- case IND:
- case IND_OLDGEN:
- case IND_PERM:
- case IND_OLDGEN_PERM:
- case IND_STATIC:
- /* relies on indirectee being at same place for all these closure types */
- return (((StgInd*)node) -> indirectee);
- default:
- return NULL;
- }
-}
-
-//@cindex unwindInd
-static inline StgClosure *
-UNWIND_IND (StgClosure *closure)
-{
- StgClosure *next;
-
- while ((next = IS_INDIRECTION((StgClosure *)closure)) != NULL)
- closure = next;
-
- ASSERT(next==(StgClosure *)NULL);
- return closure;
-}
-#endif /* defined(PAR) || defined(GRAN) */
+/* pathetic version of the check whether p can be a closure */
+#define LOOKS_LIKE_COOL_CLOSURE(p) 1
+
+//LOOKS_LIKE_GHC_INFO(get_itbl(p))
+
+ /* Is it a static closure (i.e. in the data segment)? */ \
+ /*
+#define LOOKS_LIKE_COOL_CLOSURE(p) \
+ ((LOOKS_LIKE_STATIC(p)) ? \
+ closure_STATIC(p) \
+ : !closure_STATIC(p) && LOOKS_LIKE_PTR(p))
+ */
#endif /* PARALLEL_RTS_H */
-//@node Index, , Common macros
+//@node Index, , Index
//@subsection Index
//@index
/*
- Time-stamp: <Sun Dec 12 1999 20:39:04 Stardate: [-30]4039.09 software>
+ Time-stamp: <Mon Mar 13 2000 18:50:36 Stardate: [-30]4498.92 hwloidl>
Revertible Black Hole Manipulation.
Used in GUM and GranSim during the packing of closures. These black holes
//* Conversion Functions::
//* Index::
//@end menu
-//*/
//@node Externs and prototypes, Conversion Functions
//@section Externs and prototypes
RBH_Save_N closures, with N being the number of pointers for this
closure. */
IF_GRAN_DEBUG(pack,
- belch(":* Converting closure %p (%s) into an RBH",
+ belch("*>:: Converting closure %p (%s) into an RBH",
closure, info_type(closure)));
IF_PAR_DEBUG(pack,
- belch(":* Converting closure %p (%s) into an RBH",
+ belch("*>:: Converting closure %p (%s) into an RBH",
closure, info_type(closure)));
ASSERT(closure_THUNK(closure));
/*
add closure to the mutable list!
do this after having turned the closure into an RBH, because an
- RBH is mutable but the think it was previously isn't
+ RBH is mutable but the closure it was before wasn't mutable
*/
- //recordMutable((StgMutClosure *)closure);
+ recordMutable((StgMutClosure *)closure);
//IF_GRAN_DEBUG(pack,
/* sanity check; make sure that reverting the RBH yields the
ASSERT(get_itbl(rbh)->type==RBH);
IF_PAR_DEBUG(pack,
- belch(":* Converting RBH %p (%s) into a FETCH_ME for GA ((%x, %d, %x))",
+ belch("**:: Converting RBH %p (%s) into a FETCH_ME for GA ((%x, %d, %x))",
rbh, info_type(rbh),
ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight));
/* put closure on mutables list, while it is still a RBH */
- //recordMutable((StgMutClosure *)rbh);
+ recordMutable((StgMutClosure *)rbh);
/* actually turn it into a FETCH_ME */
SET_INFO((StgClosure *)rbh, &FETCH_ME_info);
IF_PAR_DEBUG(pack,
if (get_itbl(bqe)->type==TSO || get_itbl(bqe)->type==BLOCKED_FETCH)
- belch(":* Awakening non-empty BQ of RBH closure %p (first TSO is %d (%p)",
+ belch("**:: Awakening non-empty BQ of RBH closure %p (first TSO is %d (%p)",
rbh, ((StgTSO *)bqe)->id, ((StgTSO *)bqe)));
/* awaken all TSOs and BLOCKED_FETCHES on the blocking queue */
if (get_itbl(bqe)->type==TSO || get_itbl(bqe)->type==BLOCKED_FETCH)
- awaken_blocked_queue(bqe, (StgClosure *)rbh);
+ awakenBlockedQueue(bqe, (StgClosure *)rbh);
}
# else /* GRAN */
/* Prototype */
((StgTSO *)bqe)->id, ((StgTSO *)bqe));
else
strcpy(str, "empty");
- belch(":* Reverting RBH %p (%s) into a ??? closure again; BQ start: %s",
+ belch("*<:: Reverting RBH %p (%s) into a ??? closure again; BQ start: %s",
closure, info_type(closure), str));
ASSERT(get_itbl(closure)->type==RBH);
- /* awaken_blocked_queue also restores the RBH_Save closure
+ /* awakenBlockedQueue also restores the RBH_Save closure
(have to call it even if there are no TSOs in the queue!) */
- awaken_blocked_queue(bqe, closure);
+ awakenBlockedQueue(bqe, closure);
/* Put back old info pointer (grabbed from the RBH's info table).
We do that *after* awakening the BQ to be sure node is an RBH when
- calling awaken_blocked_queue (different in GUM!)
+ calling awakenBlockedQueue (different in GUM!)
*/
SET_INFO(closure, REVERT_INFOPTR(get_itbl(closure)));
/* put closure on mutables list */
- //recordMutable((StgMutClosure *)closure);
+ recordMutable((StgMutClosure *)closure);
# if 0 /* rest of this fct */
/* ngoq ngo' */
/* ----------------------------------------------------------------------------
- Time-stamp: <Sat Dec 04 1999 19:29:57 Stardate: [-30]3999.06 hwloidl>
- $Id: SysMan.c,v 1.2 2000/01/13 14:34:09 hwloidl Exp $
+ Time-stamp: <Tue Mar 21 2000 20:25:55 Stardate: [-30]4539.25 hwloidl>
+ $Id: SysMan.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
GUM System Manager Program
Handles startup, shutdown and global synchronisation of the parallel system.
TOP = .
include $(TOP)/mk/boilerplate.mk
-NOT_THESE = CVS mk Makefile
+NOT_THESE = CVS mk Makefile make.log
NOT_THESE += hill_stk_oflow
# Correctly fails to terminate
# Deliberately causes divide by zero, and
# we can't catch that yet
+NOT_THESE += andy_cherry barton-mangler-bug callback cvh_unboxing dmgob_native1 dmgob_native2 fast2haskell fexport jtod_circint okeefe_neural
+# doesn't compile
+
+NOT_THESE += jeff-bug lennart_array
+# compiles but doesn't run
+
SUBDIRS = $(filter-out $(NOT_THESE), $(wildcard *))
include $(TOP)/mk/target.mk
projects / ghc-hetmet.git / commitdiff