Remove some directories that used to be used by GUM
authorIan Lynagh <ian@well-typed.com>
Sun, 17 Mar 2013 13:56:27 +0000 (13:56 +0000)
committerIan Lynagh <ian@well-typed.com>
Sun, 17 Mar 2013 13:56:27 +0000 (13:56 +0000)
This hasn't been used for some time

61 files changed:
rts/parallel/0Hash.c [deleted file]
rts/parallel/0Parallel.h [deleted file]
rts/parallel/0Unpack.c [deleted file]
rts/parallel/Dist.c [deleted file]
rts/parallel/Dist.h [deleted file]
rts/parallel/FetchMe.h [deleted file]
rts/parallel/FetchMe.hc [deleted file]
rts/parallel/Global.c [deleted file]
rts/parallel/GranSim.c [deleted file]
rts/parallel/GranSimRts.h [deleted file]
rts/parallel/HLC.h [deleted file]
rts/parallel/HLComms.c [deleted file]
rts/parallel/LLC.h [deleted file]
rts/parallel/LLComms.c [deleted file]
rts/parallel/PEOpCodes.h [deleted file]
rts/parallel/Pack.c [deleted file]
rts/parallel/ParInit.c [deleted file]
rts/parallel/ParInit.h [deleted file]
rts/parallel/ParTicky.c [deleted file]
rts/parallel/ParTicky.h [deleted file]
rts/parallel/ParTypes.h [deleted file]
rts/parallel/Parallel.c [deleted file]
rts/parallel/ParallelDebug.c [deleted file]
rts/parallel/ParallelDebug.h [deleted file]
rts/parallel/ParallelRts.h [deleted file]
rts/parallel/RBH.c [deleted file]
rts/parallel/SysMan.c [deleted file]
utils/parallel/AVG.pl [deleted file]
utils/parallel/GrAnSim.el [deleted file]
utils/parallel/Makefile [deleted file]
utils/parallel/RTS2gran.pl [deleted file]
utils/parallel/SN.pl [deleted file]
utils/parallel/SPLIT.pl [deleted file]
utils/parallel/avg-RTS.pl [deleted file]
utils/parallel/get_SN.pl [deleted file]
utils/parallel/ghc-fool-sort.pl [deleted file]
utils/parallel/ghc-unfool-sort.pl [deleted file]
utils/parallel/gp-ext-imp.pl [deleted file]
utils/parallel/gr2RTS.pl [deleted file]
utils/parallel/gr2ap.bash [deleted file]
utils/parallel/gr2gran.bash [deleted file]
utils/parallel/gr2java.pl [deleted file]
utils/parallel/gr2jv.bash [deleted file]
utils/parallel/gr2pe.pl [deleted file]
utils/parallel/gr2ps.bash [deleted file]
utils/parallel/gr2qp.pl [deleted file]
utils/parallel/gran-extr.pl [deleted file]
utils/parallel/grs2gr.pl [deleted file]
utils/parallel/par-aux.pl [deleted file]
utils/parallel/ps-scale-y.pl [deleted file]
utils/parallel/qp2ap.pl [deleted file]
utils/parallel/qp2ps.pl [deleted file]
utils/parallel/sn_filter.pl [deleted file]
utils/parallel/stats.pl [deleted file]
utils/parallel/template.pl [deleted file]
utils/parallel/tf.pl [deleted file]
utils/stat2resid/Makefile [deleted file]
utils/stat2resid/parse-gcstats.prl [deleted file]
utils/stat2resid/prefix.txt [deleted file]
utils/stat2resid/process-gcstats.prl [deleted file]
utils/stat2resid/stat2resid.prl [deleted file]

diff --git a/rts/parallel/0Hash.c b/rts/parallel/0Hash.c
deleted file mode 100644 (file)
index a471e30..0000000
+++ /dev/null
@@ -1,320 +0,0 @@
-/*-----------------------------------------------------------------------------
- *
- * (c) The AQUA Project, Glasgow University, 1995-1998
- * (c) The GHC Team, 1999
- *
- * Dynamically expanding linear hash tables, as described in
- * Per-\AAke Larson, ``Dynamic Hash Tables,'' CACM 31(4), April 1988,
- * pp. 446 -- 457.
- * -------------------------------------------------------------------------- */
-
-/* 
-   Replaced with ghc/rts/Hash.c in the new RTS
-*/
-
-#if 0
-
-#include "Rts.h"
-#include "Hash.h"
-#include "RtsUtils.h"
-
-#define HSEGSIZE    1024    /* Size of a single hash table segment */
-                           /* Also the minimum size of a hash table */
-#define HDIRSIZE    1024    /* Size of the segment directory */
-                           /* Maximum hash table size is HSEGSIZE * HDIRSIZE */
-#define HLOAD      5       /* Maximum average load of a single hash bucket */
-
-#define HCHUNK     (1024 * sizeof(W_) / sizeof(HashList))
-                           /* Number of HashList cells to allocate in one go */
-
-
-/* Linked list of (key, data) pairs for separate chaining */
-struct hashlist {
-    StgWord key;
-    void *data;
-    struct hashlist *next;  /* Next cell in bucket chain (same hash value) */
-};
-
-typedef struct hashlist HashList;
-
-struct hashtable {
-    int split;             /* Next bucket to split when expanding */
-    int max;               /* Max bucket of smaller table */
-    int mask1;             /* Mask for doing the mod of h_1 (smaller table) */
-    int mask2;             /* Mask for doing the mod of h_2 (larger table) */
-    int kcount;                    /* Number of keys */
-    int bcount;                    /* Number of buckets */
-    HashList **dir[HDIRSIZE];  /* Directory of segments */
-};
-
-/* -----------------------------------------------------------------------------
- * Hash first using the smaller table.  If the bucket is less than the
- * next bucket to be split, re-hash using the larger table.
- * -------------------------------------------------------------------------- */
-
-static int
-hash(HashTable *table, W_ key)
-{
-    int bucket;
-
-    /* Strip the boring zero bits */
-    key /= sizeof(StgWord);
-
-    /* Mod the size of the hash table (a power of 2) */
-    bucket = key & table->mask1;
-
-    if (bucket < table->split) {
-       /* Mod the size of the expanded hash table (also a power of 2) */
-       bucket = key & table->mask2;
-    }
-    return bucket;
-}
-
-/* -----------------------------------------------------------------------------
- * Allocate a new segment of the dynamically growing hash table.
- * -------------------------------------------------------------------------- */
-
-static void
-allocSegment(HashTable *table, int segment)
-{
-    table->dir[segment] = stgMallocBytes(HSEGSIZE * sizeof(HashList *), 
-                                        "allocSegment");
-}
-
-
-/* -----------------------------------------------------------------------------
- * Expand the larger hash table by one bucket, and split one bucket
- * from the smaller table into two parts.  Only the bucket referenced
- * by @table->split@ is affected by the expansion.
- * -------------------------------------------------------------------------- */
-
-static void
-expand(HashTable *table)
-{
-    int oldsegment;
-    int oldindex;
-    int newbucket;
-    int newsegment;
-    int newindex;
-    HashList *hl;
-    HashList *next;
-    HashList *old, *new;
-
-    if (table->split + table->max >= HDIRSIZE * HSEGSIZE)
-       /* Wow!  That's big.  Too big, so don't expand. */
-       return;
-
-    /* Calculate indices of bucket to split */
-    oldsegment = table->split / HSEGSIZE;
-    oldindex = table->split % HSEGSIZE;
-
-    newbucket = table->max + table->split;
-
-    /* And the indices of the new bucket */
-    newsegment = newbucket / HSEGSIZE;
-    newindex = newbucket % HSEGSIZE;
-
-    if (newindex == 0)
-       allocSegment(table, newsegment);
-
-    if (++table->split == table->max) {
-       table->split = 0;
-       table->max *= 2;
-       table->mask1 = table->mask2;
-       table->mask2 = table->mask2 << 1 | 1;
-    }
-    table->bcount++;
-
-    /* Split the bucket, paying no attention to the original order */
-
-    old = new = NULL;
-    for (hl = table->dir[oldsegment][oldindex]; hl != NULL; hl = next) {
-       next = hl->next;
-       if (hash(table, hl->key) == newbucket) {
-           hl->next = new;
-           new = hl;
-       } else {
-           hl->next = old;
-           old = hl;
-       }
-    }
-    table->dir[oldsegment][oldindex] = old;
-    table->dir[newsegment][newindex] = new;
-
-    return;
-}
-
-void *
-lookupHashTable(HashTable *table, StgWord key)
-{
-    int bucket;
-    int segment;
-    int index;
-    HashList *hl;
-
-    bucket = hash(table, key);
-    segment = bucket / HSEGSIZE;
-    index = bucket % HSEGSIZE;
-
-    for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next)
-       if (hl->key == key)
-           return hl->data;
-
-    /* It's not there */
-    return NULL;
-}
-
-/* -----------------------------------------------------------------------------
- * We allocate the hashlist cells in large chunks to cut down on malloc
- * overhead.  Although we keep a free list of hashlist cells, we make
- * no effort to actually return the space to the malloc arena.
- * -------------------------------------------------------------------------- */
-
-static HashList *freeList = NULL;
-
-static HashList *
-allocHashList(void)
-{
-    HashList *hl, *p;
-
-    if ((hl = freeList) != NULL) {
-       freeList = hl->next;
-    } else {
-        hl = stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList");
-
-       freeList = hl + 1;
-       for (p = freeList; p < hl + HCHUNK - 1; p++)
-           p->next = p + 1;
-       p->next = NULL;
-    }
-    return hl;
-}
-
-static void
-freeHashList(HashList *hl)
-{
-    hl->next = freeList;
-    freeList = hl;
-}
-
-void
-insertHashTable(HashTable *table, StgWord key, void *data)
-{
-    int bucket;
-    int segment;
-    int index;
-    HashList *hl;
-
-    /* We want no duplicates */
-    ASSERT(lookupHashTable(table, key) == NULL);
-    
-    /* When the average load gets too high, we expand the table */
-    if (++table->kcount >= HLOAD * table->bcount)
-       expand(table);
-
-    bucket = hash(table, key);
-    segment = bucket / HSEGSIZE;
-    index = bucket % HSEGSIZE;
-
-    hl = allocHashList();
-
-    hl->key = key;
-    hl->data = data;
-    hl->next = table->dir[segment][index];
-    table->dir[segment][index] = hl;
-
-}
-
-void *
-removeHashTable(HashTable *table, StgWord key, void *data)
-{
-    int bucket;
-    int segment;
-    int index;
-    HashList *hl;
-    HashList *prev = NULL;
-
-    bucket = hash(table, key);
-    segment = bucket / HSEGSIZE;
-    index = bucket % HSEGSIZE;
-
-    for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) {
-       if (hl->key == key && (data == NULL || hl->data == data)) {
-           if (prev == NULL)
-               table->dir[segment][index] = hl->next;
-           else
-               prev->next = hl->next;
-           table->kcount--;
-           return hl->data;
-       }
-       prev = hl;
-    }
-
-    /* It's not there */
-    ASSERT(data == NULL);
-    return NULL;
-}
-
-/* -----------------------------------------------------------------------------
- * When we free a hash table, we are also good enough to free the
- * data part of each (key, data) pair, as long as our caller can tell
- * us how to do it.
- * -------------------------------------------------------------------------- */
-
-void
-freeHashTable(HashTable *table, void (*freeDataFun)(void *) )
-{
-    long segment;
-    long index;
-    HashList *hl;
-    HashList *next;
-
-    /* The last bucket with something in it is table->max + table->split - 1 */
-    segment = (table->max + table->split - 1) / HSEGSIZE;
-    index = (table->max + table->split - 1) % HSEGSIZE;
-
-    while (segment >= 0) {
-       while (index >= 0) {
-           for (hl = table->dir[segment][index]; hl != NULL; hl = next) {
-               next = hl->next;
-               if (freeDataFun != NULL)
-                   (*freeDataFun)(hl->data);
-               freeHashList(hl);
-           }
-           index--;
-       }
-       free(table->dir[segment]);
-       segment--;
-       index = HSEGSIZE - 1;
-    }
-    free(table);
-}
-
-/* -----------------------------------------------------------------------------
- * When we initialize a hash table, we set up the first segment as well,
- * initializing all of the first segment's hash buckets to NULL.
- * -------------------------------------------------------------------------- */
-
-HashTable *
-allocHashTable(void)
-{
-    HashTable *table;
-    HashList **hb;
-
-    table = stgMallocBytes(sizeof(HashTable),"allocHashTable");
-
-    allocSegment(table, 0);
-
-    for (hb = table->dir[0]; hb < table->dir[0] + HSEGSIZE; hb++)
-       *hb = NULL;
-
-    table->split = 0;
-    table->max = HSEGSIZE;
-    table->mask1 = HSEGSIZE - 1;
-    table->mask2 = 2 * HSEGSIZE - 1;
-    table->kcount = 0;
-    table->bcount = HSEGSIZE;
-
-    return table;
-}
-#endif
diff --git a/rts/parallel/0Parallel.h b/rts/parallel/0Parallel.h
deleted file mode 100644 (file)
index de84fca..0000000
+++ /dev/null
@@ -1,414 +0,0 @@
-/*
-  Time-stamp: <Mon Oct 04 1999 14:50:28 Stardate: [-30]3692.88 hwloidl>
-  Definitions for parallel machines.
-
-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
-
-#if defined(PAR) || defined(GRAN)        /* whole file */
-
-#include "Rts.h"
-#include "GranSim.h"
-//#include "ClosureTypes.h"
-
-//@menu
-//* Basic definitions::                
-//* Externs and types::                
-//* Dummy defs::               
-//* Par specific fixed headers::  
-//* Parallel only heap objects::  
-//* Packing definitions::      
-//* End of File::              
-//@end menu
-//*/
-
-//@node Basic definitions, Externs and types
-//@section Basic definitions
-
-/* SET_PAR_HDR and SET_STATIC_PAR_HDR now live in ClosureMacros.h */
-
-/* Needed for dumping routines */
-#if defined(PAR)
-# define TIME                      StgWord64
-# define CURRENT_TIME              msTime()
-# define TIME_ON_PROC(p)           msTime()
-# define CURRENT_PROC              thisPE
-# define BINARY_STATS              RtsFlags.ParFlags.granSimStats_Binary
-#elif defined(GRAN)
-# define TIME                      rtsTime
-# define CURRENT_TIME              CurrentTime[CurrentProc]
-# define TIME_ON_PROC(p)           CurrentTime[p]
-# define CURRENT_PROC              CurrentProc
-# define BINARY_STATS              RtsFlags.GranFlags.granSimStats_Binary
-#endif
-
-#if defined(PAR)
-#  define MAX_PES      256             /* Maximum number of processors */
-       /* MAX_PES is enforced by SysMan, which does not
-          allow more than this many "processors".
-          This is important because PackGA [GlobAddr.lc]
-          **assumes** that a PE# can fit in 8+ bits.
-       */
-#endif
-
-//@node Externs and types, Dummy defs, Basic definitions
-//@section Externs and types
-
-#if defined(PAR)
-/* GUM: one spark queue on each PE, and each PE sees only its own spark queue */
-extern rtsSparkQ pending_sparks_hd;
-extern rtsSparkQ pending_sparks_tl;
-#elif defined(GRAN)
-/* GranSim: a globally visible array of spark queues */
-extern rtsSparkQ pending_sparks_hds[];
-extern rtsSparkQ pending_sparks_tls[];
-#endif
-extern unsigned int /* nat */ spark_queue_len(PEs proc);
-
-extern StgInt SparksAvail;     /* How many sparks are available */
-
-/* prototypes of spark routines */
-/* ToDo: check whether all have to be visible -- HWL */
-#if defined(GRAN)
-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 delete_from_spark_queue (rtsSpark *spark);
-#endif
-
-#define STATS_FILENAME_MAXLEN  128
-
-/* Where to write the log file */
-//extern FILE *gr_file;
-extern char gr_filename[STATS_FILENAME_MAXLEN];
-
-#if defined(GRAN)
-int init_gr_simulation(char *rts_argv[], int rts_argc, char *prog_argv[], int prog_argc);
-void end_gr_simulation(void);
-#endif 
-
-#if defined(PAR)
-extern I_ do_sp_profile;
-
-extern P_ PendingFetches;
-extern GLOBAL_TASK_ID *PEs;
-
-extern rtsBool IAmMainThread, GlobalStopPending;
-extern rtsBool fishing;
-extern GLOBAL_TASK_ID SysManTask;
-extern int seed;                       /*pseudo-random-number generator seed:*/
-                                       /*Initialised in ParInit*/
-extern I_ threadId;                     /*Number of Threads that have existed on a PE*/
-extern GLOBAL_TASK_ID mytid;
-
-extern int  nPEs;
-
-extern rtsBool InGlobalGC;     /* Are we in the midst of performing global GC */
-
-extern HashTable *pGAtoGALAtable;
-extern HashTable *LAtoGALAtable;
-extern GALA *freeIndirections;
-extern GALA *liveIndirections;
-extern GALA *freeGALAList;
-extern GALA *liveRemoteGAs;
-extern int thisPE;
-
-void RunParallelSystem (StgPtr program_closure);
-void initParallelSystem();
-void SynchroniseSystem();
-
-void registerTask (GLOBAL_TASK_ID gtid);
-globalAddr *LAGAlookup (P_ addr);
-P_ GALAlookup (globalAddr *ga);
-globalAddr *MakeGlobal (P_ addr, rtsBool preferred);
-globalAddr *setRemoteGA (P_ addr, globalAddr *ga, rtsBool preferred);
-void splitWeight (globalAddr *to, globalAddr *from);
-globalAddr *addWeight (globalAddr *ga);
-void initGAtables();
-W_ taskIDtoPE (GLOBAL_TASK_ID gtid);
-void RebuildLAGAtable();
-
-void *lookupHashTable (HashTable *table, StgWord key);
-void insertHashTable (HashTable *table, StgWord key, void *data);
-void freeHashTable (HashTable *table, void (*freeDataFun) ((void *data)));
-HashTable *allocHashTable();
-void *removeHashTable (HashTable *table, StgWord key, void *data);
-#endif /* PAR */
-
-/* Interface for dumping routines (i.e. writing to log file) */
-void DumpGranEvent(GranEventType name, StgTSO *tso);
-void DumpRawGranEvent(PEs proc, PEs p, GranEventType name, 
-                     StgTSO *tso, StgClosure *node, StgInt sparkname, StgInt len);
-//void DumpEndEvent(PEs proc, StgTSO *tso, rtsBool mandatory_thread);
-
-//@node Dummy defs, Par specific fixed headers, Externs and types
-//@section Dummy defs
-
-/*
-Get this out of the way.  These are all null definitions.
-*/
-
-
-//#  define GA_HDR_SIZE                        0 
-//#  define GA(closure)                        /*nothing */ 
-  
-//#  define SET_GA(closure,ga)         /* nothing */ 
-//#  define SET_STATIC_GA(closure)     /* nothing */ 
-//#  define SET_GRAN_HDR(closure,pe)      /* nothing */ 
-//#  define SET_STATIC_PROCS(closure)  /* nothing */ 
-  
-//#  define SET_TASK_ACTIVITY(act)     /* nothing */ 
-
-#if defined(GRAN)
-
-#  define GA_HDR_SIZE                  1
-
-#  define PROCS_HDR_POSN               PAR_HDR_POSN
-#  define PROCS_HDR_SIZE               1
-
-/* Accessing components of the field */
-#  define PROCS(closure)               ((closure)->header.gran.procs)
-/* SET_PROCS is now SET_GRAN_HEADER in ClosureMacros.h. */
-#endif
-
-
-//@node Par specific fixed headers, Parallel only heap objects, Dummy defs
-//@section Par specific fixed headers
-
-/*
-Definitions relating to the entire parallel-only fixed-header field.
-
-On GUM, the global addresses for each local closure are stored in a separate
-hash table, rather then with the closure in the heap.  We call @getGA@ to
-look up the global address associated with a local closure (0 is returned
-for local closures that have no global address), and @setGA@ to store a new
-global address for a local closure which did not previously have one.
-*/
-
-#if defined(PAR) 
-
-#  define GA_HDR_SIZE                  0
-  
-#  define GA(closure)                  getGA(closure)
-  
-#  define SET_GA(closure, ga)             setGA(closure,ga)
-#  define SET_STATIC_GA(closure)
-#  define SET_GRAN_HDR(closure,pe)
-#  define SET_STATIC_PROCS(closure)
-  
-#  define MAX_GA_WEIGHT                        0       /* Treat as 2^n */
-  
-W_ PackGA ((W_, int));
-   /* There was a PACK_GA macro here; but we turned it into the PackGA
-      routine [GlobAddr.lc] (because it needs to do quite a bit of
-      paranoia checking.  Phil & Will (95/08)
-   */
-
-/* At the moment, there is no activity profiling for GUM.  This may change. */
-#  define SET_TASK_ACTIVITY(act)        /* nothing */
-#endif
-
-//@node Parallel only heap objects, Packing definitions, Par specific fixed headers
-//@section Parallel only heap objects
-
-// NB: The following definitons are BOTH for GUM and GrAnSim -- HWL
-
-/*   All in Closures.h and CLosureMacros.h */
-
-//@node Packing definitions, End of File, Parallel only heap objects
-//@section Packing definitions
-
-//@menu
-//* GUM::                      
-//* GranSim::                  
-//@end menu
-//*/
-
-//@node GUM, GranSim, Packing definitions, Packing definitions
-//@subsection GUM
-
-#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.
-*/
-
-//@menu
-//* Externs::                  
-//* Prototypes::               
-//* Macros::                   
-//@end menu
-//*/
-
-//@node Externs, Prototypes, GUM, GUM
-//@subsubsection Externs
-
-extern W_      *PackBuffer;      /* size: can be set via option */
-extern long *buffer;             /* HWL_ */
-extern W_ *freeBuffer;           /* HWL_ */
-extern W_ *packBuffer;           /* HWL_ */
-
-extern void    InitPackBuffer(STG_NO_ARGS);
-extern void    InitMoreBuffers(STG_NO_ARGS);
-extern void    InitPendingGABuffer(W_ size); 
-extern void    AllocClosureQueue(W_ size);
-
-//@node Prototypes, Macros, Externs, GUM
-//@subsubsection Prototypes
-
-void   InitPackBuffer();
-P_      PackTSO (P_ tso, W_ *size);
-P_      PackStkO (P_ stko, W_ *size);
-P_     AllocateHeap (W_ size);          /* Doesn't belong */
-
-void    InitClosureQueue ();
-P_      DeQueueClosure();
-void    QueueClosure (P_ closure);
-rtsBool QueueEmpty();
-void    PrintPacket (P_ buffer);
-
-P_      get_closure_info (P_ closure, W_ *size, W_ *ptrs, W_ *nonptrs, W_ *vhs, char *type);
-
-rtsBool isOffset (globalAddr *ga),
-       isFixed (globalAddr *ga);
-
-void    doGlobalGC();
-
-P_      PackNearbyGraph (P_ closure,W_ *size);
-P_      UnpackGraph (W_ *buffer, globalAddr **gamap, W_ *nGAs);
-
-
-//@node Macros,  , Prototypes, GUM
-//@subsubsection Macros
-
-#    define PACK_HEAP_REQUIRED  \
-      ((RtsFlags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 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_HDR_SIZE        1       /* Words of header in a packet */
-
-#  define PACK_PLC_SIZE        2       /* Size of a packed PLC in words */
-
-#endif /* PAR */
-
-//@node GranSim,  , GUM, Packing definitions
-//@subsection GranSim
-
-#if defined(GRAN)
-/* ToDo: Check which of the PAR routines are needed in GranSim -- HWL */
-
-//@menu
-//* Types::                    
-//* Prototypes::               
-//* Macros::                   
-//@end menu
-//*/
-
-//@node Types, Prototypes, GranSim, GranSim
-//@subsubsection Types
-
-typedef struct rtsPackBuffer_ {
-  StgInt /* nat */           size;
-  StgInt /* nat */           unpacked_size;
-  StgTSO       *tso;
-  StgClosure  **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 */
-
-//StgInfoTable *get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs, nat *vhs, char *info_hdr_ty);
-int IS_BLACK_HOLE(StgClosure* node);
-StgClosure *IS_INDIRECTION(StgClosure* node);
-int IS_THUNK(StgClosure* closure);
-char *display_info_type(StgClosure* closure, char *str);
-
-/* 
-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
-
-/* These are needed in the packing code to get the size of the packet
-   right. The closures itself are never built in GrAnSim. */
-#  define FETCHME_VHS                          IND_VHS
-#  define FETCHME_HS                           IND_HS
-  
-#  define FETCHME_GA_LOCN                       FETCHME_HS
-  
-#  define FETCHME_CLOSURE_SIZE(closure)                IND_CLOSURE_SIZE(closure)
-#  define FETCHME_CLOSURE_NoPTRS(closure)              0L
-#  define FETCHME_CLOSURE_NoNONPTRS(closure)   (IND_CLOSURE_SIZE(closure)-IND_VHS)
-  
-#  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_HDR_SIZE        4       /* Words of header in a packet */
-
-#    define PACK_HEAP_REQUIRED  \
-      (RtsFlags.GranFlags.packBufferSize * sizeofW(StgClosure*) + \
-      2 * sizeofW(StgInt) + sizeofW(StgTSO*))
-
-#    define PACK_FLAG_LOCN           0  
-#    define PACK_TSO_LOCN            1
-#    define PACK_UNPACKED_SIZE_LOCN  2
-#    define PACK_SIZE_LOCN           3
-#    define MAGIC_PACK_FLAG          0xfabc
-
-#endif   /* GRAN */
-
-//@node End of File,  , Packing definitions
-//@section End of File
-
-#endif /* defined(PAR) || defined(GRAN)         whole file */
-#endif /* Parallel_H */
-
-
diff --git a/rts/parallel/0Unpack.c b/rts/parallel/0Unpack.c
deleted file mode 100644 (file)
index fc4a8e5..0000000
+++ /dev/null
@@ -1,440 +0,0 @@
-/*
-  Time-stamp: <Wed Jan 12 2000 13:29:08 Stardate: [-30]4193.85 hwloidl>
-
-  Unpacking closures which have been exported to remote processors
-
-  This module defines routines for unpacking closures in the parallel
-  runtime system (GUM).
-
-  In the case of GrAnSim, this module defines routines for *simulating* the
-  unpacking of closures as it is done in the parallel runtime system.
-*/
-
-/* 
-   Code in this file has been merged with Pack.c 
-*/
-
-#if 0
-
-//@node Unpacking closures, , ,
-//@section Unpacking closures
-
-//@menu
-//* Includes::                 
-//* Prototypes::               
-//* GUM code::                 
-//* GranSim Code::             
-//* Index::                    
-//@end menu
-//*/
-
-//@node Includes, Prototypes, Unpacking closures, Unpacking closures
-//@subsection Includes
-
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "GranSimRts.h"
-#include "ParallelRts.h"
-#include "ParallelDebug.h"
-#include "FetchMe.h"
-#include "Storage.h"
-
-//@node Prototypes, GUM code, Includes, Unpacking closures
-//@subsection Prototypes
-
-void     InitPacking(void);
-# if defined(PAR)
-void            InitPackBuffer(void);
-# endif
-/* Interface for ADT of closure queues */
-void             AllocClosureQueue(nat size);
-void             InitClosureQueue(void);
-rtsBool          QueueEmpty(void);
-void             QueueClosure(StgClosure *closure);
-StgClosure *DeQueueClosure(void);
-
-StgPtr AllocateHeap(nat size);
-
-//@node GUM code, GranSim Code, Prototypes, Unpacking closures
-//@subsection GUM code
-
-#if defined(PAR) 
-
-//@node Local Definitions,  , GUM code, GUM code
-//@subsubsection Local Definitions
-
-//@cindex PendingGABuffer
-static globalAddr *PendingGABuffer;  
-/* is initialised in main; */
-
-//@cindex InitPendingGABuffer
-void
-InitPendingGABuffer(size)
-nat size; 
-{
-  PendingGABuffer = (globalAddr *) 
-                      stgMallocBytes((size-PACK_HDR_SIZE)*2*sizeof(globalAddr),
-                                    "InitPendingGABuffer");
-}
-
-/*
-  @CommonUp@ commons up two closures which we have discovered to be
-  variants of the same object.  One is made an indirection to the other.  */
-
-//@cindex CommonUp
-void
-CommonUp(StgClosure *src, StgClosure *dst)
-{
-  StgBlockingQueueElement *bqe;
-
-  ASSERT(src != dst);
-  switch (get_itbl(src)->type) {
-  case BLACKHOLE_BQ:
-    bqe = ((StgBlockingQueue *)src)->blocking_queue;
-    break;
-
-  case FETCH_ME_BQ:
-    bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
-    break;
-    
-  case RBH:
-    bqe = ((StgRBH *)src)->blocking_queue;
-    break;
-    
-  case BLACKHOLE:
-  case FETCH_ME:
-    bqe = END_BQ_QUEUE;
-    break;
-
-  default:
-    /* Don't common up anything else */
-    return;
-  }
-  /* We do not use UPD_IND because that would awaken the bq, too */
-  // UPD_IND(src, dst);
-  updateWithIndirection(get_itbl(src), src, dst);
-  //ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
-  if (bqe != END_BQ_QUEUE)
-    awaken_blocked_queue(bqe, src);
-}
-
-/*
-  @UnpackGraph@ unpacks the graph contained in a message buffer.  It
-  returns a pointer to the new graph.  The @gamap@ parameter is set to
-  point to an array of (oldGA,newGA) pairs which were created as a result
-  of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
-  were created.
-
-  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;
-{
-  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;
-  char str[80];
-
-  InitPackBuffer();                  /* in case it isn't already init'd */
-  graphroot = (StgClosure *)NULL;
-
-  gaga = PendingGABuffer;
-
-  InitClosureQueue();
-
-  /* Unpack the header */
-  bufsize = packBuffer->size;
-  buffer = packBuffer->buffer;
-  bufptr = buffer;
-
-  /* allocate heap */
-  if (bufsize > 0) {
-    graph = allocate(bufsize);
-    ASSERT(graph != NULL);
-  }
-
-  parent = (StgClosure *)NULL;
-
-  do {
-    /* This is where we will ultimately save the closure's address */
-    slotptr = bufptr;
-
-    /* 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++;
-    
-    /* Now unpack the closure body, if there is one */
-    if (isFixed(&ga)) {
-      /* No more to unpack; just set closure to local address */
-      IF_PAR_DEBUG(pack,
-                  belch("Unpacked PLC at %x", ga.payload.plc)); 
-      closure = ga.payload.plc;
-    } else if (isOffset(&ga)) {
-      /* No more to unpack; just set closure to cached address */
-      ASSERT(parent != (StgClosure *)NULL);
-      closure = (StgClosure *) buffer[ga.payload.gc.slot];
-    } else {
-      /* Now we have to build something. */
-
-      ASSERT(bufsize > 0);
-
-      /*
-       * 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 < FIXED_HS; i++)
-       ((StgPtr)graph)[i] = *bufptr++;
-
-      if (ip->type == FETCH_ME)
-       size = ptrs = nonptrs = vhs = 0;
-
-      /* Fill in the packed variable header */
-      for (i = 0; i < vhs; i++)
-       ((StgPtr)graph)[FIXED_HS + i] = *bufptr++;
-
-      /* Pointers will be filled in later */
-
-      /* Fill in the packed non-pointers */
-      for (i = 0; i < nonptrs; i++)
-       ((StgPtr)graph)[FIXED_HS + i + vhs + ptrs] = *bufptr++;
-                
-      /* Indirections are never packed */
-      // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
-
-      /* Add to queue for processing */
-      QueueClosure(graph);
-       
-      /*
-       * Common up the new closure with any existing closure having the same
-       * GA
-       */
-
-      if ((existing = GALAlookup(&ga)) == NULL) {
-       globalAddr *newGA;
-       /* Just keep the new object */
-       IF_PAR_DEBUG(pack,
-                    belch("Unpacking new (%x, %d, %x)\n", 
-                          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 || IS_BLACK_HOLE(existing)) &&
-           ip->type != FETCH_ME) {
-
-         /* What we had wasn't worth keeping */
-         closure = graph;
-         CommonUp(existing, graph);
-       } 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 (%x, %d, %x), keeping %#lx", 
-                            ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight,
-                            existing));
-
-         closure = existing;
-       }
-       /* Pool the total weight in the stored ga */
-       (void) addWeight(&ga);
-      }
-
-      /* Sort out the global address mapping */
-      if ((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);
-       
-       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++;
-      }
-      graph += FIXED_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)[FIXED_HS + pvhs + pptr] = (StgWord) closure;
-
-    /* Save closure pointer for resolving offsets */
-    *slotptr = (StgWord) closure;
-
-    /* Locate next parent pointer */
-    pptr++;
-    while (pptr + 1 > pptrs) {
-      parent = DeQueueClosure();
-
-      if (parent == NULL)
-       break;
-      else {
-       (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
-                                       &pvhs, str);
-       pptr = 0;
-      }
-    }
-  } while (parent != NULL);
-
-  ASSERT(bufsize == 0 || graph - 1 <= SAVE_Hp);
-
-  *gamap = PendingGABuffer;
-  *nGAs = (gaga - PendingGABuffer) / 2;
-
-  /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
-  ASSERT(graphroot!=NULL);
-  return (graphroot);
-}
-#endif  /* PAR */
-
-//@node GranSim Code, Index, GUM code, Unpacking closures
-//@subsection GranSim Code
-
-/*
-   For GrAnSim: In general no actual unpacking should be necessary. We just
-   have to walk over the graph and set the bitmasks appropriately. -- HWL */
-
-//@node Unpacking,  , GranSim Code, GranSim Code
-//@subsubsection Unpacking
-
-#if defined(GRAN)
-void
-CommonUp(StgClosure *src, StgClosure *dst)
-{
-  barf("CommonUp: should never be entered in a GranSim setup");
-}
-
-/* This code fakes the unpacking of a somewhat virtual buffer */
-StgClosure*
-UnpackGraph(buffer)
-rtsPackBuffer* buffer;
-{
-  nat size, ptrs, nonptrs, vhs,
-      bufptr = 0;
-  StgClosure *closure, *graphroot, *graph;
-  StgInfoTable *ip;
-  StgWord bufsize, unpackedsize,
-          pptr = 0, pptrs = 0, pvhs;
-  StgTSO* tso;
-  char str[240], str1[80];
-  int i;
-
-  bufptr = 0;
-  graphroot = buffer->buffer[0];
-
-  tso = buffer->tso;
-
-  /* Unpack the header */
-  unpackedsize = buffer->unpacked_size;
-  bufsize = buffer->size;
-
-  IF_GRAN_DEBUG(pack,
-               belch("<<< Unpacking <<%d>> (buffer @ %p):\n    (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
-                     buffer->id, buffer, graphroot, where_is(graphroot), 
-                     bufsize, tso->id, tso, 
-                     where_is((StgClosure *)tso)));
-
-  do {
-    closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
-      
-    /* Actually only ip is needed; rest is useful for TESTING -- HWL */
-    ip = get_closure_info(closure, 
-                         &size, &ptrs, &nonptrs, &vhs, str);
-      
-    IF_GRAN_DEBUG(pack,
-                 sprintf(str, "**    (%p): Changing bitmask[%s]: 0x%x ",
-                         closure, (closure_HNF(closure) ? "NF" : "__"),
-                         PROCS(closure)));
-
-    if (ip->type == RBH) {
-      closure->header.gran.procs = PE_NUMBER(CurrentProc);    /* Move node */
-      
-      IF_GRAN_DEBUG(pack,
-                   strcat(str, " (converting RBH) ")); 
-
-      convertFromRBH(closure);   /* In GUM that's done by convertToFetchMe */
-    } else if (IS_BLACK_HOLE(closure)) {
-      closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
-    } else if ( closure->header.gran.procs & PE_NUMBER(CurrentProc) == 0 ) {
-      if (closure_HNF(closure))
-       closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
-      else
-       closure->header.gran.procs = PE_NUMBER(CurrentProc);  /* Move node */
-    }
-
-    IF_GRAN_DEBUG(pack,
-                 sprintf(str1, "0x%x",   PROCS(closure)); strcat(str, str1));
-    IF_GRAN_DEBUG(pack, belch(str));
-    
-  } while (bufptr<buffer->size) ;   /*  (parent != NULL);  */
-
-  /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
-  free(buffer->buffer);
-  free(buffer);
-
-  IF_GRAN_DEBUG(pack,
-               belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
-
-  return (graphroot);
-}
-#endif  /* GRAN */
-#endif
-
-//@node Index,  , GranSim Code, Unpacking closures
-//@subsection Index
-
-//@index
-//* CommonUp::  @cindex\s-+CommonUp
-//* InitPendingGABuffer::  @cindex\s-+InitPendingGABuffer
-//* PendingGABuffer::  @cindex\s-+PendingGABuffer
-//* UnpackGraph::  @cindex\s-+UnpackGraph
-//@end index
diff --git a/rts/parallel/Dist.c b/rts/parallel/Dist.c
deleted file mode 100644 (file)
index eeec780..0000000
+++ /dev/null
@@ -1,117 +0,0 @@
-#include "Dist.h"
-
-#ifdef DIST /* whole file */
-
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "ParallelRts.h"
-#include "Parallel.h" // nPEs,allPEs,mytid 
-#include "HLC.h" //for sendReval
-#include "LLC.h" //for pvm stuff
-#include "FetchMe.h"     // for BLOCKED_FETCH_info 
-#include "Storage.h"       // for recordMutable
-
-/* hopefully the result>0  */
-StgWord32 cGetPECount(void)
-{ return nPEs;
-} 
-
-/* return taskID, n is 1..count, n=1 is always the mainPE */
-StgPEId cGetPEId(StgWord32 n)
-{ return allPEs[n-1];
-}
-
-/* return the taskID */
-StgPEId cGetMyPEId(void)
-{ return mytid;
-}
-
-/* return the taskID of the owning PE of an MVar/TSO:
-- MVAR/TSOs get converted to REMOTE_REFs when shipped, and
-  there is no mechanism for using these REMOTE_REFs 
-  apart from this code.
-*/   
-
-StgPEId cGetCertainOwner(StgClosure *mv)
-{ globalAddr *ga; 
-  switch(get_itbl(mv)->type)
-  { case TSO:
-    case MVAR:
-      return  mytid; // must be local 
-    case REMOTE_REF:
-      ga = LAGAlookup(mv);
-      ASSERT(ga);
-      return ga->payload.gc.gtid; // I know its global address
-  }   
-  barf("Dist.c:cGetCertainOwner() wrong closure type %s",info_type(mv));
-}
-
-/* for some additional fun, lets look up a certain host... */
-StgPEId cGetHostOwner(StgByteArray h) //okay h is a C string 
-{ int nArch,nHost,nTask,i;
-  StgPEId dtid;
-  struct pvmhostinfo *host;   
-  struct pvmtaskinfo *task;
-  
-  dtid=0;
-  pvm_config(&nHost,&nArch,&host); 
-  for(i=0;i<nHost;i++)
-    if(strcmp(host[i].hi_name,h)==0) 
-    { dtid=host[i].hi_tid;
-      break;
-    } 
-  if(dtid==0) return 0; // no host of that name
-  
-  for(i=0;i<nPEs;i++)
-  { pvm_tasks(allPEs[i],&nTask,&task);
-    ASSERT(nTask==1); //cause we lookup a single task
-    if(task[0].ti_host==dtid)
-      return allPEs[i];
-  }  
-  return 0;  //know host, put no PE on it
-}
-
-void cRevalIO(StgClosure *job,StgPEId p)
-{ nat size;
-  rtsPackBuffer *buffer=NULL;
-      
-  ASSERT(get_itbl(job)->type==MVAR);  
-  job=((StgMVar*)job)->value; // extract the job from the MVar
-
-  ASSERT(closure_THUNK(job)); // must be a closure!!!!!
-  ASSERT(p!=mytid);
-  
-  buffer = PackNearbyGraph(job, END_TSO_QUEUE, &size,p);
-  ASSERT(buffer != (rtsPackBuffer *)NULL);
-  ASSERT(get_itbl(job)->type==RBH);  
-  
-  IF_PAR_DEBUG(verbose,
-               belch("@;~) %x doing revalIO to %x\n",
-                    mytid,p)); 
-
-  sendReval(p,size,buffer);  
-  
-  if (RtsFlags.ParFlags.ParStats.Global &&
-      RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-    globalParStats.tot_reval_mess++;
-  }
-  
-  /* 
-     We turn job into a FETCHME_BQ so that the thread will block
-     when it enters it.
-     
-     Note: it will not receive an ACK, thus no GA.   
-  */
-  
-  ASSERT(get_itbl(job)->type==RBH);  
-   /* put closure on mutables list, while it is still a RBH */
-  recordMutable((StgMutClosure *)job);
-
-  /* actually turn it into a FETCH_ME_BQ */
-  SET_INFO(job, &FETCH_ME_BQ_info);
-  ((StgFetchMe *)job)->ga = 0;     //hope this won't make anyone barf!!!
-  ((StgBlockingQueue*)job)->blocking_queue=END_BQ_QUEUE;
-}
-
-#endif
diff --git a/rts/parallel/Dist.h b/rts/parallel/Dist.h
deleted file mode 100644 (file)
index c67cce2..0000000
+++ /dev/null
@@ -1,20 +0,0 @@
-#ifndef __DIST_H
-#define __DIST_H
-
-#ifdef DIST 
-
-#include "Rts.h"
-
-typedef StgWord32 StgPEId;
-
-// interface functions for Haskell Language calls
-StgWord32 cGetPECount(void);
-StgPEId cGetPEId(StgWord32 n);
-StgPEId cGetMyPEId(void);
-StgPEId cGetCertainOwner(StgClosure *mv);
-void cRevalIO(StgClosure *job,StgPEId p);
-StgPEId cGetHostOwner(StgByteArray h);
-
-#endif /* DIST */
-
-#endif /* __DIST_H */
diff --git a/rts/parallel/FetchMe.h b/rts/parallel/FetchMe.h
deleted file mode 100644 (file)
index be5cbf6..0000000
+++ /dev/null
@@ -1,24 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * Closure types for the parallel system.
- *
- * ---------------------------------------------------------------------------*/
-
-EI_(stg_FETCH_ME_info);
-EF_(stg_FETCH_ME_entry);
-
-EI_(stg_FETCH_ME_BQ_info);
-EF_(stg_FETCH_ME_BQ_entry);
-
-EI_(stg_BLOCKED_FETCH_info);
-EF_(stg_BLOCKED_FETCH_entry);
-
-EI_(stg_REMOTE_REF_info);
-EF_(stg_REMOTE_REF_entry);
-
-EI_(stg_RBH_Save_0_info);
-EF_(stg_RBH_Save_0_entry);
-EI_(stg_RBH_Save_1_info);
-EF_(stg_RBH_Save_1_entry);
-EI_(stg_RBH_Save_2_info);
-EF_(stg_RBH_Save_2_entry);
diff --git a/rts/parallel/FetchMe.hc b/rts/parallel/FetchMe.hc
deleted file mode 100644 (file)
index f142e9e..0000000
+++ /dev/null
@@ -1,180 +0,0 @@
-/* ----------------------------------------------------------------------------
- Time-stamp: <Tue Mar 06 2001 17:01:46 Stardate: [-30]6288.54 hwloidl>
-
- Entry code for a FETCH_ME closure
-
- This module defines routines for handling remote pointers (@FetchMe@s)
- in GUM.  It is threaded (@.hc@) because @FetchMe_entry@ will be
- called during evaluation.
-
- * --------------------------------------------------------------------------*/
-#ifdef PAR /* all of it */
-
-//@menu
-//* Includes::                 
-//* Info tables::              
-//* Index::                    
-//@end menu
-
-//@node Includes, Info tables
-//@subsection Includes
-
-#include "Stg.h"
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "Storage.h"
-#include "GranSim.h"
-#include "GranSimRts.h"
-#include "Parallel.h"
-#include "ParallelRts.h"
-#include "FetchMe.h"
-#include "HLC.h"
-#include "StgRun.h"    /* for StgReturn and register saving */
-
-/* --------------------------------------------------------------------------
-   FETCH_ME closures.
-
-   A FETCH_ME closure represents data that currently resides on
-   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).
-   ------------------------------------------------------------------------ */
-
-//@node Info tables, Index, Includes
-//@subsection Info tables
-
-//@cindex FETCH_ME_info
-INFO_TABLE(stg_FETCH_ME_info, stg_FETCH_ME_entry, 0,2, FETCH_ME,, EF_,"FETCH_ME","FETCH_ME");
-//@cindex FETCH_ME_entry
-STGFUN(stg_FETCH_ME_entry)
-{
-  FB_
-    TICK_ENT_BH();
-
-    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.
-     */
-    // ((StgFetchMeBlockingQueue *)R1.cl)->header.info = &FETCH_ME_BQ_info; // does the same as SET_INFO
-    SET_INFO((StgClosure *)R1.cl, &stg_FETCH_ME_BQ_info);
-  
-    /* Remember GA as a global var (used in blockThread); NB: not thread safe! */
-    ASSERT(theGlobalFromGA.payload.gc.gtid == (GlobalTaskId)0);
-    theGlobalFromGA = *((StgFetchMe *)R1.p)->ga; 
-
-    /* Put ourselves on the blocking queue for this black hole */
-    ASSERT(looks_like_ga(((StgFetchMe *)R1.p)->ga));
-    CurrentTSO->link = 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;
-    /* closure is mutable since something has just been added to its BQ */
-    //recordMutable((StgMutClosure *)R1.cl);
-
-    /* sendFetch etc is now done in blockThread, which is called from the
-       scheduler -- HWL */
-
-    BLOCK_NP(1); 
-  FE_
-}
-
-/* ---------------------------------------------------------------------------
-   FETCH_ME_BQ
-   
-   On the first entry of a FETCH_ME closure, we turn the closure into
-   a FETCH_ME_BQ, which behaves just like a BLACKHOLE_BQ.  Any thread
-   entering the FETCH_ME_BQ will be placed in the blocking queue.
-   When the data arrives from the remote PE, all waiting threads are
-   woken up and the FETCH_ME_BQ is overwritten with the fetched data.
-
-   FETCH_ME_BQ_entry is almost identical to BLACKHOLE_BQ_entry -- HWL
-   ------------------------------------------------------------------------ */
-
-INFO_TABLE(stg_FETCH_ME_BQ_info, stg_FETCH_ME_BQ_entry,0,2,FETCH_ME_BQ,,EF_,"FETCH_ME_BQ","FETCH_ME_BQ");
-//@cindex FETCH_ME_BQ_info
-STGFUN(stg_FETCH_ME_BQ_entry)
-{
-  FB_
-    TICK_ENT_BH();
-
-    /* Put ourselves on the blocking queue for this node */
-    CurrentTSO->link = (StgTSO*)((StgBlockingQueue *)R1.p)->blocking_queue;
-    ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
-
-    /* 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);
-  FE_
-}
-
-/* ---------------------------------------------------------------------------
-   BLOCKED_FETCH_BQ
-   
-   A BLOCKED_FETCH closure only ever exists in the blocking queue of a
-   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 awakenBlockedQueue
-   and blockFetch (for putting BLOCKED_FETCH closure into a BQ).
-   ------------------------------------------------------------------------ */
-
-//@cindex BLOCKED_FETCH_info
-INFO_TABLE(stg_BLOCKED_FETCH_info, stg_BLOCKED_FETCH_entry,0,2,BLOCKED_FETCH,,EF_,"BLOCKED_FETCH","BLOCKED_FETCH");
-//@cindex BLOCKED_FETCH_entry
-STGFUN(stg_BLOCKED_FETCH_entry)
-{
-  FB_
-    /* see NON_ENTERABLE_ENTRY_CODE in StgMiscClosures.hc */
-    STGCALL2(fprintf,stderr,"BLOCKED_FETCH object entered!\n");
-    STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);
-  FE_
-}
-
-
-/* ---------------------------------------------------------------------------
-   REMOTE_REF
-   
-   A REMOTE_REF closure is generated whenever we wish to refer to a sticky
-   object on another PE.
-   ------------------------------------------------------------------------ */
-
-//@cindex REMOTE_REF_info
-INFO_TABLE(stg_REMOTE_REF_info, stg_REMOTE_REF_entry,0,2,REMOTE_REF,,EF_,"REMOTE_REF","REMOTE_REF");
-//@cindex REMOTE_REF_entry
-STGFUN(stg_REMOTE_REF_entry)
-{
-  FB_
-    /* see NON_ENTERABLE_ENTRY_CODE in StgMiscClosures.hc */
-    STGCALL2(fprintf,stderr,"REMOTE REF object entered!\n");
-    STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);
-  FE_
-}
-
-#endif /* PAR */
-
-//@node Index,  , Info tables
-//@subsection Index
-
-//@index
-//* BLOCKED_FETCH_entry::  @cindex\s-+BLOCKED_FETCH_entry
-//* BLOCKED_FETCH_info::  @cindex\s-+BLOCKED_FETCH_info
-//* FETCH_ME_BQ_info::  @cindex\s-+FETCH_ME_BQ_info
-//* FETCH_ME_entry::  @cindex\s-+FETCH_ME_entry
-//* FETCH_ME_info::  @cindex\s-+FETCH_ME_info
-//@end index
diff --git a/rts/parallel/Global.c b/rts/parallel/Global.c
deleted file mode 100644 (file)
index aea3f8a..0000000
+++ /dev/null
@@ -1,1090 +0,0 @@
-/* ---------------------------------------------------------------------------
-   Time-stamp: <2009-12-02 12:26:23 simonmar>
-
-   (c) The AQUA/Parade Projects, Glasgow University, 1995
-       The GdH/APART 624 Projects, Heriot-Watt University, Edinburgh, 1999
-
-   Global Address Manipulation.
-   
-   The GALA and LAGA tables for mapping global addresses to local addresses 
-   (i.e. heap pointers) are defined here. We use the generic hash tables
-   defined in Hash.c.
-   ------------------------------------------------------------------------- */
-
-#ifdef PAR /* whole file */
-
-//@menu
-//* Includes::                 
-//* Global tables and lists::  
-//* Fcts on GALA tables::      
-//* Interface to taskId-PE table::  
-//* Interface to LAGA table::  
-//* Interface to GALA table::  
-//* GC functions for GALA tables::  
-//* Index::                    
-//@end menu
-//*/
-
-//@node Includes, Global tables and lists, Global Address Manipulation, Global Address Manipulation
-//@subsection Includes
-
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "Storage.h"
-#include "Hash.h"
-#include "HLC.h"
-#include "ParallelRts.h"
-#if defined(DEBUG)
-# include "sm/Sanity.h"
-#include "ParallelDebug.h"
-#endif
-#if defined(DIST)
-# include "Dist.h"
-#endif
-
-/*
-  @globalAddr@ structures are allocated in chunks to reduce malloc overhead.
-*/
-
-//@node Global tables and lists, Fcts on GALA tables, Includes, Global Address Manipulation
-//@subsection Global tables and lists
-
-//@cindex thisPE
-nat thisPE;
-
-//@menu
-//* Free lists::               
-//* Hash tables::              
-//@end menu
-
-//@node Free lists, Hash tables, Global tables and lists, Global tables and lists
-//@subsubsection Free lists
-
-/* Free list of GALA entries */
-GALA *freeGALAList = NULL;
-
-/* Number of globalAddr cells to allocate in one go */
-#define GCHUNK     (1024 * sizeof(StgWord) / sizeof(GALA))
-
-/* Free list of indirections */
-
-//@cindex nextIndirection
-static StgInt nextIndirection = 0;
-//@cindex freeIndirections
-GALA *freeIndirections = NULL;
-
-/* The list of live indirections has to be marked for GC (see makeGlobal) */
-//@cindex liveIndirections
-GALA *liveIndirections = NULL;
-
-/* The list of remote indirections has to be marked for GC (see setRemoteGA) */
-//@cindex liveRemoteGAs
-GALA *liveRemoteGAs = NULL;
-
-//@node Hash tables,  , Free lists, Global tables and lists
-//@subsubsection Hash tables
-
-/* Mapping global task ids PEs */
-//@cindex taskIDtoPEtable
-HashTable *taskIDtoPEtable = NULL;
-
-static int nextPE = 0;
-
-/* LAGA table: StgClosure* -> globalAddr*
-               (Remember: globalAddr = (GlobalTaskId, Slot, Weight))
-   Mapping local to global addresses (see interface below) 
-*/
-
-//@cindex LAtoGALAtable
-HashTable *LAtoGALAtable = NULL;
-
-/* GALA table: globalAddr* -> StgClosure*
-               (Remember: globalAddr = (GlobalTaskId, Slot, Weight))
-   Mapping global to local addresses (see interface below) 
-*/
-
-//@cindex pGAtoGALAtable
-HashTable *pGAtoGALAtable = NULL;
-
-//@node Fcts on GALA tables, Interface to taskId-PE table, Global tables and lists, Global Address Manipulation
-//@subsection Fcts on GALA tables
-
-//@cindex allocGALA
-static GALA *
-allocGALA(void)
-{
-  GALA *gl, *p;
-
-  if ((gl = freeGALAList) != NULL) {
-    IF_DEBUG(sanity,
-            ASSERT(gl->ga.weight==0xdead0add);
-             ASSERT(gl->la==(StgPtr)0xdead00aa));
-    freeGALAList = gl->next;
-  } else {
-    gl = (GALA *) stgMallocBytes(GCHUNK * sizeof(GALA), "allocGALA");
-
-    freeGALAList = gl + 1;
-    for (p = freeGALAList; p < gl + GCHUNK - 1; p++) {
-      p->next = p + 1;
-      IF_DEBUG(sanity,
-              p->ga.weight=0xdead0add;
-               p->la=(StgPtr)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=(StgPtr)0xdead00aa);
-  }
-  IF_DEBUG(sanity,
-          gl->ga.weight=0xdead0add;
-           gl->la=(StgPtr)0xdead00aa);
-  return gl;
-}
-
-//@node Interface to taskId-PE table, Interface to LAGA table, Fcts on GALA tables, Global Address Manipulation
-//@subsection Interface to taskId-PE table
-
-/*
-  We don't really like GLOBAL_TASK_ID, so we keep a table of TASK_ID to
-  PE mappings.  The idea is that a PE identifier will fit in 16 bits, whereas 
-  a TASK_ID may not.
-*/
-
-//@cindex taskIDtoPE
-PEs
-taskIDtoPE(GlobalTaskId gtid)
-{
-  return ((PEs) lookupHashTable(taskIDtoPEtable, gtid));
-}
-
-//@cindex registerTask
-void 
-registerTask(GlobalTaskId gtid) { 
-  nextPE++;               //start counting from 1
-  if (gtid == mytid)
-    thisPE = nextPE;
-
-  insertHashTable(taskIDtoPEtable, gtid, (void *) (StgWord) nextPE);
-}
-
-//@node Interface to LAGA table, Interface to GALA table, Interface to taskId-PE table, Global Address Manipulation
-//@subsection Interface to LAGA table
-
-/*
-  The local address to global address mapping returns a globalAddr structure
-  (pe task id, slot, weight) for any closure in the local heap which has a
-  global identity.  Such closures may be copies of normal form objects with
-  a remote `master' location, @FetchMe@ nodes referencing remote objects, or
-  globally visible objects in the local heap (for which we are the master).
-*/
-
-//@cindex LAGAlookup
-globalAddr *
-LAGAlookup(addr)
-StgClosure *addr;
-{
-  GALA *gala;
-
-  /* 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
-    return &(gala->ga);
-}
-
-//@node Interface to GALA table, GC functions for GALA tables, Interface to LAGA table, Global Address Manipulation
-//@subsection Interface to GALA table
-
-/*
-  We also manage a mapping of global addresses to local addresses, so that
-  we can ``common up'' multiple references to the same object as they arrive
-  in data packets from remote PEs.
-
-  The global address to local address mapping is actually managed via a
-  ``packed global address'' to GALA hash table.  The packed global
-  address takes the interesting part of the @globalAddr@ structure
-  (i.e. the pe and slot fields) and packs them into a single word
-  suitable for hashing.
-*/
-
-//@cindex GALAlookup
-StgClosure *
-GALAlookup(ga)
-globalAddr *ga;
-{
-  StgWord pga = PackGA(taskIDtoPE(ga->payload.gc.gtid), ga->payload.gc.slot);
-  GALA *gala;
-
-  if ((gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga)) == NULL)
-    return NULL;
-  else {
-    /* 
-     * Bypass any indirections when returning a local closure to
-     * the caller.  Note that we do not short-circuit the entry in
-     * the GALA tables right now, because we would have to do a
-     * hash table delete and insert in the LAtoGALAtable to keep
-     * that table up-to-date for preferred GALA pairs.  That's
-     * probably a bit expensive.
-     */
-    return UNWIND_IND((StgClosure *)(gala->la));
-  }
-}
-
-/* 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
-  of local garbage collections, but its global identity is determined by its
-  slot in the indirection table, which never changes.
-
-  The indirection table is maintained implicitly as part of the global
-  address to local address table.  We need only keep track of the
-  highest numbered indirection index allocated so far, along with a free
-  list of lower numbered indices no longer in use.
-*/
-
-/* 
-   Allocate an indirection slot for the closure currently at address @addr@.
-*/
-
-//@cindex allocIndirection
-static GALA *
-allocIndirection(StgClosure *closure)
-{
-  GALA *gala;
-  
-  if ((gala = freeIndirections) != NULL) {
-    IF_DEBUG(sanity,
-            ASSERT(gala->ga.weight==0xdead0add);
-             ASSERT(gala->la==(StgPtr)0xdead00aa));
-    freeIndirections = gala->next;
-  } else {
-    gala = allocGALA();
-    IF_DEBUG(sanity,
-            ASSERT(gala->ga.weight==0xdead0add);
-             ASSERT(gala->la==(StgPtr)0xdead00aa));
-    gala->ga.payload.gc.gtid = mytid;
-    gala->ga.payload.gc.slot = nextIndirection++;
-    IF_DEBUG(sanity,
-            if (nextIndirection>=MAX_SLOTS)
-              barf("Cannot handle more than %d slots for GA in a sanity-checking setup (this is no error)"));
-  }
-  gala->ga.weight = MAX_GA_WEIGHT;
-  gala->la = (StgPtr)closure;
-  IF_DEBUG(sanity,
-          gala->next=(struct gala *)0xcccccccc);
-  return gala;
-}
-
-/* 
-   This is only used for sanity checking (see LOOKS_LIKE_SLOT)
-*/
-StgInt
-highest_slot (void) { return nextIndirection; }
-
-/*
-  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(closure, preferred)
-StgClosure *closure;
-rtsBool preferred;
-{
-  /* 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(closure);
-  StgWord pga = PackGA(thisPE, newGALA->ga.payload.gc.slot);
-
-  IF_DEBUG(sanity,
-          ASSERT(newGALA->next==(struct gala *)0xcccccccc););
-  // ASSERT(HEAP_ALLOCED(closure)); // check that closure might point into the heap; might be static, though
-  ASSERT(GALAlookup(&(newGALA->ga)) == NULL);
-  
-  /* global statistics gathering */
-  if (RtsFlags.ParFlags.ParStats.Global &&
-      RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-    globalParStats.local_alloc_GA++;
-  }
-
-  newGALA->la = (StgPtr)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) closure, (void *) oldGALA);
-    }
-    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;
-  
-  insertHashTable(pGAtoGALAtable, pga, (void *) newGALA);
-  
-  return &(newGALA->ga);
-}
-
-/*
-  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(local_closure, remote_ga, preferred)
-StgClosure *local_closure;
-globalAddr *remote_ga;
-rtsBool preferred;
-{
-  /* 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(remote_ga->payload.gc.gtid), 
-                      remote_ga->payload.gc.slot);
-
-  ASSERT(remote_ga->payload.gc.gtid != mytid);
-  ASSERT(remote_ga->weight > 0);
-  ASSERT(GALAlookup(remote_ga) == NULL);
-
-  newGALA->ga = *remote_ga;
-  newGALA->la = (StgPtr)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) local_closure, (void *) oldGALA);
-    }
-    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);
-  
-  /*
-    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);
-}
-
-/*
-  Give me a bit of weight to give away on a new reference to a particular
-  global address.  If we run down to nothing, we have to assign a new GA.  
-*/
-
-//@cindex splitWeight
-#if 0
-void
-splitWeight(to, from)
-globalAddr *to, *from;
-{
-  /* Make sure we have enough weight to split */
-  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 == 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.
-*/
-
-//@cindex addWeight
-globalAddr *
-addWeight(ga)
-globalAddr *ga;
-{
-  StgWord pga;
-  GALA *gala;
-
-  ASSERT(LOOKS_LIKE_GA(ga));
-
-  pga = PackGA(taskIDtoPE(ga->payload.gc.gtid), ga->payload.gc.slot);
-  gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
-
-  IF_PAR_DEBUG(weight,
-              fprintf(stderr, "@* Adding weight %x to ", ga->weight);
-              printGA(&(gala->ga));
-              fputc('\n', stderr));
-
-  gala->ga.weight += ga->weight;    
-  ga->weight = 0;
-
-  return &(gala->ga);
-}
-
-/*
-  Initialize all of the global address structures: the task ID to PE id
-  map, the local address to global address map, the global address to
-  local address map, and the indirection table.
-*/
-
-//@cindex initGAtables
-void
-initGAtables(void)
-{
-  taskIDtoPEtable = allocHashTable();
-  LAtoGALAtable = allocHashTable();
-  pGAtoGALAtable = allocHashTable();
-}
-
-//@cindex PackGA
-StgWord
-PackGA (pe, slot)
-StgWord pe;
-int slot;
-{
-  int pe_shift = (BITS_IN(StgWord)*3)/4;
-  int pe_bits  = BITS_IN(StgWord) - pe_shift;
-
-  if ( pe_bits < 8 || slot >= (1L << pe_shift) ) { /* big trouble */
-    fflush(stdout);
-    fprintf(stderr, "PackGA: slot# too big (%d) or not enough pe_bits (%d)\n",
-           slot,pe_bits);
-    stg_exit(EXIT_FAILURE);
-  }
-
-  return((((StgWord)(pe)) << pe_shift) | ((StgWord)(slot)));
-       
-    /* the idea is to use 3/4 of the bits (e.g., 24) for indirection-
-       table "slot", and 1/4 for the pe# (e.g., 8).
-       
-       We check for too many bits in "slot", and double-check (at
-       compile-time?) that we have enough bits for "pe".  We *don't*
-       check for too many bits in "pe", because SysMan enforces a
-       MAX_PEs limit at the very very beginning.
-
-       Phil & Will 95/08
-    */
-}
-
-//@node GC functions for GALA tables, Debugging routines, Interface to GALA table, Global Address Manipulation
-//@subsection GC functions for GALA tables
-
-/*
-  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
-markLocalGAs(rtsBool full)
-{
-  GALA *gala, *next, *prev = NULL;
-  StgPtr old_la, new_la;
-  nat n=0, m=0; // debugging only
-  double start_time_GA; // stats only
-
-  IF_PAR_DEBUG(tables,
-          belch("@@%%%% markLocalGAs (full=%d): Marking LIVE INDIRECTIONS in GALA table starting with GALA at %p\n",
-                full, liveIndirections);
-          printLAGAtable());
-
-  PAR_TICKY_MARK_LOCAL_GAS_START();
-
-  for (gala = liveIndirections, m=0; gala != NULL; gala = next, m++) {
-    IF_PAR_DEBUG(tables,
-                fputs("@@ ",stderr);
-                printGA(&(gala->ga));
-                fprintf(stderr, ";@ %d: LA: %p (%s) ",
-                        m, (void*)gala->la, info_type((StgClosure*)gala->la)));
-    next = gala->next;
-    old_la = gala->la;
-    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 */
-      if (get_itbl((StgClosure *)old_la)->type == EVACUATED) {
-       /* somebody else already evacuated this closure */
-       new_la = (StgPtr)((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++;
-
-       new_la = (StgPtr) MarkRoot(foo);
-       IF_PAR_DEBUG(tables,
-                    belch(" evacuated %p to %p", foo, new_la));
-       /* ToDo: is this the right assertion to check that new_la is in to-space?
-       ASSERT(!HEAP_ALLOCED(new_la) || 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((StgClosure*)new_la));
-                        printGA(&(q->ga));
-                        fputc('\n', stderr)); 
-         }
-       } else {
-         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 if(LOOKS_LIKE_STATIC_CLOSURE(gala->la)) {
-      /* to handle the CAFs, is this all?*/
-      MarkRoot(gala->la);
-      IF_PAR_DEBUG(tables,
-                  belch(" processed static closure"));
-      n++;
-      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);
-      
-      IF_PAR_DEBUG(free,
-                  belch("@@!! Freeing slot %d", 
-                        gala->ga.payload.gc.slot));
-      /* put gala on free indirections list */
-      gala->next = freeIndirections;
-      freeIndirections = gala;
-      (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
-      if (/* !full && */ gala->preferred)
-       (void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
-
-      IF_DEBUG(sanity,
-              gala->ga.weight = 0xdead0add;
-              gala->la = (StgPtr) 0xdead00aa);
-    }
-  } /* for gala ... */
-  liveIndirections = prev;  /* list has been reversed during the marking */
-
-
-  PAR_TICKY_MARK_LOCAL_GAS_END(n);
-
-  IF_PAR_DEBUG(tables,
-              belch("@@%%%% markLocalGAs: %d of %d GALAs marked on PE %x",
-                    n, m, mytid));
-}
-
-/*
-  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
-rebuildGAtables(rtsBool full)
-{
-  GALA *gala, *next, *prev;
-  StgClosure *closure;
-  nat n = 0, size_GA = 0; // stats only (no. of GAs, and their heap size in bytes)
-
-  IF_PAR_DEBUG(tables,
-          belch("@@%%%% rebuildGAtables (full=%d): rebuilding LIVE REMOTE GAs in GALA table starting with GALA at %p\n",
-                full, liveRemoteGAs));
-
-  PAR_TICKY_REBUILD_GA_TABLES_START();
-
-  prepareFreeMsgBuffers();
-
-  for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
-    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_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 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.
-    */
-
-    //ASSERT(!HEAP_ALLOCED(closure) || !(Bdescr((StgPtr)closure)->evacuated));
-    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);
-
-      /* check that the block containing this closure is not in to-space */
-      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-1, &(gala->ga)); //-1 cause ids start at 1... not 0
-      gala->next = freeGALAList;
-      freeGALAList = gala;
-      IF_DEBUG(sanity,
-              gala->ga.weight = 0xdead0add;
-              gala->la = (StgPtr)0xdead00aa);
-      continue;
-    }
-    gala->la = (StgPtr)closure;
-    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((StgClosure*)gala->la));
-                        printGA(&(q->ga));
-                        fputc('\n', stderr)); 
-       }
-      } else {
-       insertHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
-      }
-    }
-    gala->next = prev;
-    prev = gala;
-    /* Global statistics: count GAs and total size
-    if (RtsFlags.ParFlags.ParStats.Global &&
-       RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-      StgInfoTable *info;
-      nat size, ptrs, nonptrs, vhs, i;
-      char str[80];
-
-      info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
-
-      size_GA += size ;
-      n++; // stats: count number of GAs we add to the new table
-    }
-    */
-  }
-  liveRemoteGAs = prev; /* list is reversed during marking */
-
-  /* If we have any remaining FREE messages to send off, do so now */
-  sendFreeMessages();
-
-  PAR_TICKY_CNT_FREE_GA();
-
-  IF_DEBUG(sanity,
-          checkFreeGALAList();
-          checkFreeIndirectionsList());
-
-  rebuildLAGAtable();
-
-#if defined(PAR_TICKY)
-  getLAGAtableSize(&n, &size_GA);        // determine no of GAs and global heap
-  PAR_TICKY_REBUILD_GA_TABLES_END(n, size_GA); // record these values
-#endif
-
-  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
-void
-rebuildLAGAtable(void)
-{
-  GALA *gala;
-  nat n=0, m=0; // debugging
-
-  /* The old LA->GA table is worthless */
-  freeHashTable(LAtoGALAtable, NULL);
-  LAtoGALAtable = allocHashTable();
-
-  IF_PAR_DEBUG(tables,
-          belch("@@%%%% rebuildLAGAtable: new LAGA table at %p",
-                LAtoGALAtable)); 
-  
-  for (gala = liveIndirections; gala != NULL; gala = gala->next) {
-    n++;
-    if (gala->preferred) {
-      GALA *q;
-      if ((q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la))!=NULL) {
-       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((StgClosure*)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) {
-      GALA *q;
-      if ((q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la))!=NULL) {
-       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 ",
-                              (StgClosure*)gala->la, info_type((StgClosure*)gala->la));
-                      printGA(&(q->ga));
-                      fputc('\n', stderr)); 
-       }
-      }
-      insertHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
-    }
-  }
-
-  IF_PAR_DEBUG(tables,
-          belch("@@%%%% rebuildLAGAtable: inserted %d entries from liveIndirections and %d entries from liveRemoteGAs",
-                n,m)); 
-}
-
-/*
-  Determine the size of the LAGA and GALA tables.
-  Has to be done after rebuilding the tables. 
-  Only used for global statistics gathering.
-*/
-
-//@cindex getLAGAtableSize
-void
-getLAGAtableSize(nat *nP, nat *sizeP)
-{
-  GALA *gala;
-  // nat n=0, tot_size=0;
-  StgClosure *closure;
-  StgInfoTable *info;
-  nat size, ptrs, nonptrs, vhs, i;
-  char str[80];
-  /* IN order to avoid counting closures twice we maintain a hash table
-     of all closures seen so far.
-     ToDo: collect this data while rebuilding the GALA table and make use
-           of the existing hash tables;
-  */
-  HashTable *closureTable;  // hash table for closures encountered already
-
-  closureTable = allocHashTable();
-
-  (*nP) = (*sizeP) = 0;
-  for (gala = liveIndirections; gala != NULL; gala = gala->next) {
-    closure = (StgClosure*) gala->la;
-    if (lookupHashTable(closureTable, (StgWord)closure)==NULL) { // not seen yet
-      insertHashTable(closureTable, (StgWord)closure, (void *)1);
-      info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
-      (*sizeP) += size ;   // stats: measure total heap size of global closures
-      (*nP)++;             // stats: count number of GAs
-    }
-  }
-
-  for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
-    closure = (StgClosure*) gala->la;
-    if (lookupHashTable(closureTable, (StgWord)closure)==NULL) { // not seen yet
-      insertHashTable(closureTable, (StgWord)closure, (void *)1);
-      info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
-      (*sizeP) += size ;   // stats: measure total heap size of global closures
-      (*nP)++;             // stats: count number of GAs
-    }
-  }
-
-  freeHashTable(closureTable, NULL);
-}
-
-//@node Debugging routines, Index, GC functions for GALA tables, Global Address Manipulation
-//@subsection Debugging routines
-
-//@cindex printGA
-void
-printGA (globalAddr *ga)
-{
-  fprintf(stderr, "((%x, %d, %x))", 
-         ga->payload.gc.gtid,
-         ga->payload.gc.slot,
-         ga->weight);
-}
-
-//@cindex printGALA
-void 
-printGALA (GALA *gala)
-{
-  printGA(&(gala->ga));
-  fprintf(stderr, " -> %p (%s)",
-         (StgClosure*)gala->la, info_type((StgClosure*)gala->la));
-  fprintf(stderr, " %s",
-         (gala->preferred) ? "PREF" : "____");
-}
-
-/*
-  Printing the LA->GA table.
-*/
-
-//@cindex printLiveIndTable
-void
-printLiveIndTable(void)
-{
-  GALA *gala, *q;
-  nat n=0; // debugging
-
-  belch("@@%%%%:: logical LiveIndTable (%p) (liveIndirections=%p):",
-       LAtoGALAtable, liveIndirections); 
-  
-  for (gala = liveIndirections; gala != NULL; gala = gala->next) {
-    n++;
-    printGALA(gala);
-    /* 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);
-    /* 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 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==(StgPtr)0xdead00aa);
-  }
-}
-
-void
-checkFreeIndirectionsList(void) {
-  GALA *gl;
-
-  for (gl=freeIndirections; gl != NULL; gl=gl->next) {
-    ASSERT(gl->ga.weight==0xdead0add);
-    ASSERT(gl->la==(StgPtr)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
-//* addWeight::  @cindex\s-+addWeight
-//* allocGALA::  @cindex\s-+allocGALA
-//* allocIndirection::  @cindex\s-+allocIndirection
-//* freeIndirections::  @cindex\s-+freeIndirections
-//* initGAtables::  @cindex\s-+initGAtables
-//* liveIndirections::  @cindex\s-+liveIndirections
-//* liveRemoteGAs::  @cindex\s-+liveRemoteGAs
-//* makeGlobal::  @cindex\s-+makeGlobal
-//* 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
-//* taskIDtoPE::  @cindex\s-+taskIDtoPE
-//* taskIDtoPEtable::  @cindex\s-+taskIDtoPEtable
-//* thisPE::  @cindex\s-+thisPE
-//@end index
diff --git a/rts/parallel/GranSim.c b/rts/parallel/GranSim.c
deleted file mode 100644 (file)
index 7f7ad44..0000000
+++ /dev/null
@@ -1,3015 +0,0 @@
-/* 
-   Time-stamp: <2009-07-06 21:48:36 simonmar>
-
-   Variables and functions specific to GranSim the parallelism simulator
-   for GPH.
-*/
-
-//@node GranSim specific code, , ,
-//@section GranSim specific code
-
-/*
-   Macros for dealing with the new and improved GA field for simulating
-   parallel execution. Based on @CONCURRENT@ package. The GA field now
-   contains a mask, where the n-th bit stands for the n-th processor, where
-   this data can be found. In case of multiple copies, several bits are
-   set. The total number of processors is bounded by @MAX_PROC@, which
-   should be <= the length of a word in bits.  -- HWL 
-*/
-
-//@menu
-//* Includes::                 
-//* Prototypes and externs::   
-//* Constants and Variables::  
-//* Initialisation::           
-//* Global Address Operations::         
-//* Global Event Queue::       
-//* Spark queue functions::    
-//* Scheduling functions::     
-//* Thread Queue routines::    
-//* GranSim functions::                
-//* GranSimLight routines::    
-//* Code for Fetching Nodes::  
-//* Idle PEs::                 
-//* Routines directly called from Haskell world::  
-//* Emiting profiling info for GrAnSim::  
-//* Dumping routines::         
-//* Index::                    
-//@end menu
-
-//@node Includes, Prototypes and externs, GranSim specific code, GranSim specific code
-//@subsection Includes
-
-#if defined(GRAN)
-
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "StgMiscClosures.h"
-#include "StgTypes.h"
-#include "Storage.h"       // for recordMutable
-#include "Schedule.h"
-#include "SchedAPI.h"       // for pushClosure
-#include "GranSimRts.h"
-#include "GranSim.h"
-#include "ParallelRts.h"
-#include "ParallelDebug.h"
-#include "Sparks.h"
-
-
-//@node Prototypes and externs, Constants and Variables, Includes, GranSim specific code
-//@subsection Prototypes and externs
-
-/* Prototypes */
-static inline PEs      ga_to_proc(StgWord);
-static inline rtsBool  any_idle(void);
-static inline nat      idlers(void);
-       PEs             where_is(StgClosure *node);
-
-static rtsBool         stealSomething(PEs proc, rtsBool steal_spark, rtsBool steal_thread);
-static rtsBool         stealSpark(PEs proc);
-static rtsBool         stealThread(PEs proc);
-static rtsBool         stealSparkMagic(PEs proc);
-static rtsBool         stealThreadMagic(PEs proc);
-/* subsumed by stealSomething
-static void            stealThread(PEs proc); 
-static void            stealSpark(PEs proc);
-*/
-static rtsTime         sparkStealTime(void);
-static nat             natRandom(nat from, nat to);
-static PEs             findRandomPE(PEs proc);
-static void            sortPEsByTime (PEs proc, PEs *pes_by_time, 
-                                     nat *firstp, nat *np);
-
-void GetRoots(void);
-
-#endif /* GRAN */
-
-//@node Constants and Variables, Initialisation, Prototypes and externs, GranSim specific code
-//@subsection Constants and Variables
-
-#if defined(GRAN) || defined(PAR)
-/* See GranSim.h for the definition of the enum gran_event_types */
-char *gran_event_names[] = {
-    "START", "START(Q)",
-    "STEALING", "STOLEN", "STOLEN(Q)",
-    "FETCH", "REPLY", "BLOCK", "RESUME", "RESUME(Q)",
-    "SCHEDULE", "DESCHEDULE",
-    "END",
-    "SPARK", "SPARKAT", "USED", "PRUNED", "EXPORTED", "ACQUIRED",
-    "ALLOC",
-    "TERMINATE",
-    "SYSTEM_START", "SYSTEM_END",           /* only for debugging */
-    "??"
-};
-#endif
-
-#if defined(GRAN)                                              /* whole file */
-char *proc_status_names[] = {
-  "Idle", "Sparking", "Starting", "Fetching", "Fishing", "Busy", 
-  "UnknownProcStatus"
-};
-
-/* For internal use (event statistics) only */
-char *event_names[] =
-    { "ContinueThread", "StartThread", "ResumeThread", 
-      "MoveSpark", "MoveThread", "FindWork",
-      "FetchNode", "FetchReply",
-      "GlobalBlock", "UnblockThread"
-    };
-
-//@cindex CurrentProc
-PEs CurrentProc = 0;
-
-/*
-  ToDo: Create a structure for the processor status and put all the 
-        arrays below into it. 
-  -- HWL */
-
-//@cindex CurrentTime
-/* One clock for each PE */
-rtsTime CurrentTime[MAX_PROC];  
-
-/* Useful to restrict communication; cf fishing model in GUM */
-nat OutstandingFetches[MAX_PROC], OutstandingFishes[MAX_PROC];
-
-/* Status of each PE (new since but independent of GranSim Light) */
-rtsProcStatus procStatus[MAX_PROC];
-
-# if defined(GRAN) && defined(GRAN_CHECK)
-/* To check if the RTS ever tries to run a thread that should be blocked
-   because of fetching remote data */
-StgTSO *BlockedOnFetch[MAX_PROC];
-# define FETCH_MASK_TSO  0x08000000      /* only bits 0, 1, 2 should be used */
-# endif
-
-nat SparksAvail = 0;     /* How many sparks are available */
-nat SurplusThreads = 0;  /* How many excess threads are there */
-
-/* Do we need to reschedule following a fetch? */
-rtsBool NeedToReSchedule = rtsFalse, IgnoreEvents = rtsFalse, IgnoreYields = rtsFalse; 
-rtsTime TimeOfNextEvent, TimeOfLastEvent, EndOfTimeSlice; /* checked from the threaded world! */
-
-//@cindex spark queue
-/* GranSim: a globally visible array of spark queues */
-rtsSparkQ pending_sparks_hds[MAX_PROC];
-rtsSparkQ pending_sparks_tls[MAX_PROC];
-
-nat sparksIgnored = 0, sparksCreated = 0;
-
-GlobalGranStats globalGranStats;
-
-nat gran_arith_cost, gran_branch_cost, gran_load_cost, 
-    gran_store_cost, gran_float_cost;
-
-/*
-Old comment from 0.29. ToDo: Check and update -- HWL
-
-The following variables control the behaviour of GrAnSim. In general, there
-is one RTS option for enabling each of these features. In getting the
-desired setup of GranSim the following questions have to be answered:
-\begin{itemize}
-\item {\em Which scheduling algorithm} to use (@RtsFlags.GranFlags.DoFairSchedule@)? 
-      Currently only unfair scheduling is supported.
-\item What to do when remote data is fetched (@RtsFlags.GranFlags.DoAsyncFetch@)? 
-      Either block and wait for the
-      data or reschedule and do some other work.
-      Thus, if this variable is true, asynchronous communication is
-      modelled. Block on fetch mainly makes sense for incremental fetching.
-
-      There is also a simplified fetch variant available
-      (@RtsFlags.GranFlags.SimplifiedFetch@). This variant does not use events to model
-      communication. It is faster but the results will be less accurate.
-\item How aggressive to be in getting work after a reschedule on fetch
-      (@RtsFlags.GranFlags.FetchStrategy@)?
-      This is determined by the so-called {\em fetching
-      strategy\/}. Currently, there are four possibilities:
-      \begin{enumerate}
-       \item Only run a runnable thread.
-       \item Turn a spark into a thread, if necessary.
-       \item Steal a remote spark, if necessary.
-       \item Steal a runnable thread from another processor, if necessary.
-      \end{itemize}
-      The variable @RtsFlags.GranFlags.FetchStrategy@ determines how far to go in this list
-      when rescheduling on a fetch.
-\item Should sparks or threads be stolen first when looking for work
-      (@RtsFlags.GranFlags.DoStealThreadsFirst@)? 
-      The default is to steal sparks first (much cheaper).
-\item Should the RTS use a lazy thread creation scheme
-      (@RtsFlags.GranFlags.DoAlwaysCreateThreads@)?  By default yes i.e.\ sparks are only
-      turned into threads when work is needed. Also note, that sparks
-      can be discarded by the RTS (this is done in the case of an overflow
-      of the spark pool). Setting @RtsFlags.GranFlags.DoAlwaysCreateThreads@  to @True@ forces
-      the creation of threads at the next possibility (i.e.\ when new work
-      is demanded the next time).
-\item Should data be fetched closure-by-closure or in packets
-      (@RtsFlags.GranFlags.DoBulkFetching@)? The default strategy is a GRIP-like incremental 
-      (i.e.\ closure-by-closure) strategy. This makes sense in a
-      low-latency setting but is bad in a high-latency system. Setting 
-      @RtsFlags.GranFlags.DoBulkFetching@ to @True@ enables bulk (packet) fetching. Other
-      parameters determine the size of the packets (@pack_buffer_size@) and the number of
-      thunks that should be put into one packet (@RtsFlags.GranFlags.ThunksToPack@).
-\item If there is no other possibility to find work, should runnable threads
-      be moved to an idle processor (@RtsFlags.GranFlags.DoThreadMigration@)? In any case, the
-      RTS tried to get sparks (either local or remote ones) first. Thread
-      migration is very expensive, since a whole TSO has to be transferred
-      and probably data locality becomes worse in the process. Note, that
-      the closure, which will be evaluated next by that TSO is not
-      transferred together with the TSO (that might block another thread).
-\item Should the RTS distinguish between sparks created by local nodes and
-      stolen sparks (@RtsFlags.GranFlags.PreferSparksOfLocalNodes@)?  The idea is to improve 
-      data locality by preferring sparks of local nodes (it is more likely
-      that the data for those sparks is already on the local processor). 
-      However, such a distinction also imposes an overhead on the spark
-      queue management, and typically a large number of sparks are
-      generated during execution. By default this variable is set to @False@.
-\item Should the RTS use granularity control mechanisms? The idea of a 
-      granularity control mechanism is to make use of granularity
-      information provided via annotation of the @par@ construct in order
-      to prefer bigger threads when either turning a spark into a thread or
-      when choosing the next thread to schedule. Currently, three such
-      mechanisms are implemented:
-      \begin{itemize}
-        \item Cut-off: The granularity information is interpreted as a
-              priority. If a threshold priority is given to the RTS, then
-              only those sparks with a higher priority than the threshold 
-              are actually created. Other sparks are immediately discarded.
-              This is similar to a usual cut-off mechanism often used in 
-              parallel programs, where parallelism is only created if the 
-              input data is lage enough. With this option, the choice is 
-              hidden in the RTS and only the threshold value has to be 
-              provided as a parameter to the runtime system.
-        \item Priority Sparking: This mechanism keeps priorities for sparks
-              and chooses the spark with the highest priority when turning
-              a spark into a thread. After that the priority information is
-              discarded. The overhead of this mechanism comes from
-              maintaining a sorted spark queue.
-        \item Priority Scheduling: This mechanism keeps the granularity
-              information for threads, to. Thus, on each reschedule the 
-              largest thread is chosen. This mechanism has a higher
-              overhead, as the thread queue is sorted, too.
-       \end{itemize}  
-\end{itemize}
-*/
-
-//@node Initialisation, Global Address Operations, Constants and Variables, GranSim specific code
-//@subsection Initialisation
-
-void 
-init_gr_stats (void) {
-  memset(&globalGranStats, '\0', sizeof(GlobalGranStats));
-#if 0
-  /* event stats */
-  globalGranStats.noOfEvents = 0;
-  for (i=0; i<MAX_EVENT; i++) globalGranStats.event_counts[i]=0;
-
-  /* communication stats */
-  globalGranStats.fetch_misses = 0;
-  globalGranStats.tot_low_pri_sparks = 0;
-
-  /* obscure stats */  
-  globalGranStats.rs_sp_count = 0;
-  globalGranStats.rs_t_count = 0;
-  globalGranStats.ntimes_total = 0, 
-  globalGranStats.fl_total = 0;
-  globalGranStats.no_of_steals = 0;
-
-  /* spark queue stats */
-  globalGranStats.tot_sq_len = 0, 
-  globalGranStats.tot_sq_probes = 0; 
-  globalGranStats.tot_sparks = 0;
-  globalGranStats.withered_sparks = 0;
-  globalGranStats.tot_add_threads = 0;
-  globalGranStats.tot_tq_len = 0;
-  globalGranStats.non_end_add_threads = 0;
-
-  /* thread stats */
-  globalGranStats.tot_threads_created = 0;
-  for (i=0; i<MAX_PROC; i++) globalGranStats.threads_created_on_PE[i]=0;
-#endif /* 0 */
-}
-
-//@node Global Address Operations, Global Event Queue, Initialisation, GranSim specific code
-//@subsection Global Address Operations
-/*
-  ----------------------------------------------------------------------
-  Global Address Operations
-
-  These functions perform operations on the global-address (ga) part of a
-  closure. The ga is the only new field (1 word) in a closure introduced by
-  GrAnSim. It serves as a bitmask, indicating on which processor the
-  closure is residing. Since threads are described by Thread State Object
-  (TSO), which is nothing but another kind of closure, this scheme allows
-  gives placement information about threads.
-
-  A ga is just a bitmask, so the operations on them are mainly bitmask
-  manipulating functions. Note, that there are important macros like PROCS,
-  IS_LOCAL_TO etc. They are defined in @GrAnSim.lh@.
-
-  NOTE: In GrAnSim-light we don't maintain placement information. This
-  allows to simulate an arbitrary number of processors. The price we have
-  to be is the lack of costing any communication properly. In short,
-  GrAnSim-light is meant to reveal the maximal parallelism in a program.
-  From an implementation point of view the important thing is: {\em
-  GrAnSim-light does not maintain global-addresses}.  */
-
-/* ga_to_proc returns the first processor marked in the bitmask ga.
-   Normally only one bit in ga should be set. But for PLCs all bits
-   are set. That shouldn't hurt since we only need IS_LOCAL_TO for PLCs */
-//@cindex ga_to_proc
-
-static inline PEs
-ga_to_proc(StgWord ga)
-{
-    PEs i;
-    for (i = 0; i < RtsFlags.GranFlags.proc && !IS_LOCAL_TO(ga, i); i++);
-    ASSERT(i<RtsFlags.GranFlags.proc);
-    return (i);
-}
-
-/* NB: This takes a *node* rather than just a ga as input */
-//@cindex where_is
-PEs
-where_is(StgClosure *node)
-{ return (ga_to_proc(PROCS(node))); }
-
-// debugging only
-//@cindex is_unique
-rtsBool
-is_unique(StgClosure *node)
-{ 
-  PEs i;
-  rtsBool unique = rtsFalse;
-
-  for (i = 0; i < RtsFlags.GranFlags.proc ; i++)
-    if (IS_LOCAL_TO(PROCS(node), i))
-      if (unique)          // exactly 1 instance found so far
-       return rtsFalse;   // found a 2nd instance => not unique
-      else 
-       unique = rtsTrue;  // found 1st instance 
-  ASSERT(unique);          // otherwise returned from within loop
-  return (unique);
-}
-
-//@cindex any_idle
-static inline rtsBool
-any_idle(void) { /* any (map (\ i -> procStatus[i] == Idle)) [0,..,MAX_PROC] */
- PEs i; 
- rtsBool any_idle; 
- for(i=0, any_idle=rtsFalse; 
-     !any_idle && i<RtsFlags.GranFlags.proc; 
-     any_idle = any_idle || procStatus[i] == Idle, i++) 
- {} ;
-}
-
-//@cindex idlers
-static inline nat
-idlers(void) {  /* number of idle PEs */
- PEs i, j; 
- for(i=0, j=0;
-     i<RtsFlags.GranFlags.proc; 
-     j += (procStatus[i] == Idle) ? 1 : 0, i++) 
- {} ;
- return j;
-}
-
-//@node Global Event Queue, Spark queue functions, Global Address Operations, GranSim specific code
-//@subsection Global Event Queue
-/*
-The following routines implement an ADT of an event-queue (FIFO). 
-ToDo: Put that in an own file(?)
-*/
-
-/* Pointer to the global event queue; events are currently malloc'ed */
-rtsEventQ EventHd = NULL;
-
-//@cindex get_next_event
-rtsEvent *
-get_next_event(void)
-{
-  static rtsEventQ entry = NULL;
-
-  if (EventHd == NULL) {
-    barf("No next event. This may be caused by a circular data dependency in the program.");
-  }
-
-  if (entry != NULL)
-    free((char *)entry);
-
-  if (RtsFlags.GranFlags.GranSimStats.Global) {     /* count events */
-    globalGranStats.noOfEvents++;
-    globalGranStats.event_counts[EventHd->evttype]++;
-  }
-
-  entry = EventHd;
-
-  IF_GRAN_DEBUG(event_trace,
-          print_event(entry));
-
-  EventHd = EventHd->next;
-  return(entry);
-}
-
-/* When getting the time of the next event we ignore CONTINUETHREAD events:
-   we don't want to be interrupted before the end of the current time slice
-   unless there is something important to handle. 
-*/
-//@cindex get_time_of_next_event
-rtsTime
-get_time_of_next_event(void)
-{ 
-  rtsEventQ event = EventHd;
-
-  while (event != NULL && event->evttype==ContinueThread) {
-    event = event->next;
-  }
-  if(event == NULL)
-      return ((rtsTime) 0);
-  else
-      return (event->time);
-}
-
-/* ToDo: replace malloc/free with a free list */
-//@cindex insert_event
-void
-insert_event(newentry)
-rtsEvent *newentry;
-{
-  rtsEventType evttype = newentry->evttype;
-  rtsEvent *event, **prev;
-
-  /* if(evttype >= CONTINUETHREAD1) evttype = CONTINUETHREAD; */
-
-  /* Search the queue and insert at the right point:
-     FINDWORK before everything, CONTINUETHREAD after everything.
-
-     This ensures that we find any available work after all threads have
-     executed the current cycle.  This level of detail would normally be
-     irrelevant, but matters for ridiculously low latencies...
-  */
-
-  /* Changed the ordering: Now FINDWORK comes after everything but 
-     CONTINUETHREAD. This makes sure that a MOVESPARK comes before a 
-     FINDWORK. This is important when a GranSimSparkAt happens and
-     DoAlwaysCreateThreads is turned on. Also important if a GC occurs
-     when trying to build a new thread (see much_spark)  -- HWL 02/96  */
-
-  if(EventHd == NULL)
-    EventHd = newentry;
-  else {
-    for (event = EventHd, prev=(rtsEvent**)&EventHd; 
-        event != NULL; 
-         prev = (rtsEvent**)&(event->next), event = event->next) {
-      switch (evttype) {
-        case FindWork: if ( event->time < newentry->time ||
-                            ( (event->time == newentry->time) &&
-                             (event->evttype != ContinueThread) ) )
-                         continue;
-                       else
-                         break;
-        case ContinueThread: if ( event->time <= newentry->time )
-                              continue;
-                            else
-                               break;
-        default: if ( event->time < newentry->time || 
-                     ((event->time == newentry->time) &&
-                      (event->evttype == newentry->evttype)) )
-                  continue;
-                else
-                   break;
-       }
-       /* Insert newentry here (i.e. before event) */
-       *prev = newentry;
-       newentry->next = event;
-       break;
-    }
-    if (event == NULL)
-      *prev = newentry;
-  }
-}
-
-//@cindex new_event
-void
-new_event(proc,creator,time,evttype,tso,node,spark)
-PEs proc, creator;
-rtsTime time;
-rtsEventType evttype;
-StgTSO *tso;
-StgClosure *node;
-rtsSpark *spark;
-{
-  rtsEvent *newentry = (rtsEvent *) stgMallocBytes(sizeof(rtsEvent), "new_event");
-
-  newentry->proc     = proc;
-  newentry->creator  = creator;
-  newentry->time     = time;
-  newentry->evttype  = evttype;
-  newentry->tso      = tso;
-  newentry->node     = node;
-  newentry->spark    = spark;
-  newentry->gc_info  = 0;
-  newentry->next     = NULL;
-
-  insert_event(newentry);
-
-  IF_DEBUG(gran, 
-          fprintf(stderr, "GRAN: new_event: \n"); 
-          print_event(newentry));
-}
-
-//@cindex prepend_event
-void
-prepend_event(event)       /* put event at beginning of EventQueue */
-rtsEvent *event;
-{                                /* only used for GC! */
- event->next = EventHd;
- EventHd = event;
-}
-
-//@cindex grab_event
-rtsEventQ
-grab_event(void)             /* undo prepend_event i.e. get the event */
-{                       /* at the head of EventQ but don't free anything */
- rtsEventQ event = EventHd;
-
- if (EventHd == NULL) {
-   barf("No next event (in grab_event). This may be caused by a circular data dependency in the program.");
- }
-
- EventHd = EventHd->next;
- return (event);
-}
-
-//@cindex traverse_eventq_for_gc
-void 
-traverse_eventq_for_gc(void)
-{
- rtsEventQ event = EventHd;
- StgWord bufsize;
- StgClosure *closurep;
- StgTSO *tsop;
- StgPtr buffer, bufptr;
- PEs proc, creator;
-
- /* Traverse eventq and replace every FETCHREPLY by a FETCHNODE for the
-    orig closure (root of packed graph). This means that a graph, which is
-    between processors at the time of GC is fetched again at the time when
-    it would have arrived, had there been no GC. Slightly inaccurate but
-    safe for GC.
-    This is only needed for GUM style fetchng. -- HWL */
- if (!RtsFlags.GranFlags.DoBulkFetching)
-   return;
-
- for(event = EventHd; event!=NULL; event=event->next) {
-   if (event->evttype==FetchReply) {
-     buffer = stgCast(StgPtr,event->node);
-     ASSERT(buffer[PACK_FLAG_LOCN]==MAGIC_PACK_FLAG);  /* It's a pack buffer */
-     bufsize = buffer[PACK_SIZE_LOCN];
-     closurep = stgCast(StgClosure*,buffer[PACK_HDR_SIZE]);
-     tsop = stgCast(StgTSO*,buffer[PACK_TSO_LOCN]);
-     proc = event->proc;
-     creator = event->creator;                 /* similar to unpacking */
-     for (bufptr=buffer+PACK_HDR_SIZE; 
-         bufptr<(buffer+bufsize);
-         bufptr++) {
-        // if ( (INFO_TYPE(INFO_PTR(*bufptr)) == INFO_SPEC_RBH_TYPE) ||
-        //      (INFO_TYPE(INFO_PTR(*bufptr)) == INFO_GEN_RBH_TYPE) ) {
-          if ( GET_INFO(stgCast(StgClosure*,bufptr)) ) {
-            convertFromRBH(stgCast(StgClosure *,bufptr));
-        }
-     }
-     free(buffer);
-     event->evttype = FetchNode;
-     event->proc    = creator;
-     event->creator = proc;
-     event->node    = closurep;
-     event->tso     = tsop;
-     event->gc_info = 0;
-   }
- }
-}
-
-void
-markEventQueue(void)
-{ 
-  StgClosure *MarkRoot(StgClosure *root); // prototype
-
-  rtsEventQ event = EventHd;
-  nat len;
-
-  /* iterate over eventq and register relevant fields in event as roots */
-  for(event = EventHd, len =  0; event!=NULL; event=event->next, len++) {
-    switch (event->evttype) {
-      case ContinueThread:  
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       break;
-      case StartThread: 
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
-       break;
-      case ResumeThread:
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
-       break;
-      case MoveSpark:
-       event->spark->node = (StgClosure *)MarkRoot((StgClosure *)event->spark->node);
-       break;
-      case MoveThread:
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       break;
-      case FindWork:
-       break;
-      case FetchNode: 
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
-       break;
-      case FetchReply:
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       if (RtsFlags.GranFlags.DoBulkFetching)
-         // ToDo: traverse_eventw_for_gc if GUM-Fetching!!! HWL
-         belch("ghuH: packets in BulkFetching not marked as roots; mayb be fatal");
-       else
-         event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
-       break;
-      case GlobalBlock:
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
-       break;
-      case UnblockThread:
-       event->tso = (StgTSO *)MarkRoot((StgClosure *)event->tso);
-       event->node = (StgClosure *)MarkRoot((StgClosure *)event->node);
-       break;
-      default:
-       barf("markEventQueue: trying to mark unknown event @ %p", event);
-    }}
-  IF_DEBUG(gc,
-          belch("GC: markEventQueue: %d events in queue", len));
-}
-
-/*
-  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 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.  
-*/
-//@cindex prune_eventq 
-void 
-prune_eventq(tso, node) 
-StgTSO *tso; 
-StgClosure *node; 
-{ rtsEventQ prev = (rtsEventQ)NULL, event = EventHd;
-
-  /* node unused for now */ 
-  ASSERT(node==NULL); 
-  /* tso must be valid, then */
-  ASSERT(tso!=END_TSO_QUEUE);
-  while (event != NULL) {
-    if (event->evttype==ContinueThread && 
-       (event->tso==tso)) {
-      IF_GRAN_DEBUG(event_trace, // ToDo: use another debug flag
-                   belch("prune_eventq: pruning ContinueThread event for TSO %d (%p) on PE %d @ %lx (%p)",
-                         event->tso->id, event->tso, event->proc, event->time, event));
-      if (prev==(rtsEventQ)NULL) { // beginning of eventq
-       EventHd = event->next;
-       free(event); 
-       event = EventHd;
-      } else {
-       prev->next = event->next;
-       free(event); 
-       event = prev->next;
-      }
-    } else { // no pruning necessary; go to next event
-      prev = event;
-      event = event->next;
-    }
-  }
-}
-
-//@cindex print_event
-void
-print_event(event)
-rtsEvent *event;
-{
-  char str_tso[16], str_node[16];
-  StgThreadID tso_id;
-
-  if (event->tso==END_TSO_QUEUE) {
-    strcpy(str_tso, "______");
-    tso_id = 0;
-  } else { 
-    sprintf(str_tso, "%p", event->tso);
-    tso_id = (event->tso==NULL) ? 0 : event->tso->id;
-  }
-  if  (event->node==(StgClosure*)NULL) {
-    strcpy(str_node, "______");
-  } else {
-    sprintf(str_node, "%p", event->node);
-  }
-  // HWL: shouldn't be necessary; ToDo: nuke
-  //str_tso[6]='\0';
-  //str_node[6]='\0';
-
-  if (event==NULL)
-    fprintf(stderr,"Evt: NIL\n");
-  else
-    fprintf(stderr, "Evt: %s (%u), PE %u [%u], Time %lu, TSO %d (%s), Node %s\n", //"Evt: %s (%u), PE %u [%u], Time %u, TSO %s (%#l), Node %s\n",
-             event_names[event->evttype], event->evttype,
-              event->proc, event->creator, event->time, 
-             tso_id, str_tso, str_node
-             /*, event->spark, event->next */ );
-
-}
-
-//@cindex print_eventq
-void
-print_eventq(hd)
-rtsEvent *hd;
-{
-  rtsEvent *x;
-
-  fprintf(stderr,"Event Queue with root at %p:\n", hd);
-  for (x=hd; x!=NULL; x=x->next) {
-    print_event(x);
-  }
-}
-
-/* 
-   Spark queue functions are now all  in Sparks.c!!
-*/
-//@node Scheduling functions, Thread Queue routines, Spark queue functions, GranSim specific code
-//@subsection Scheduling functions
-
-/* 
-   These functions are variants of thread initialisation and therefore
-   related to initThread and friends in Schedule.c. However, they are
-   specific to a GranSim setup in storing more info in the TSO's statistics
-   buffer and sorting the thread queues etc.  
-*/
-
-/*
-   A large portion of startThread deals with maintaining a sorted thread
-   queue, which is needed for the Priority Sparking option. Without that
-   complication the code boils down to FIFO handling.  
-*/
-//@cindex insertThread
-void
-insertThread(tso, proc)
-StgTSO*     tso;
-PEs         proc;
-{
-  StgTSO *prev = NULL, *next = NULL;
-  nat count = 0;
-  rtsBool found = rtsFalse;
-
-  ASSERT(CurrentProc==proc);
-  ASSERT(!is_on_queue(tso,proc));
-  /* Idle proc: put the thread on the run queue
-     same for pri spark and basic version */
-  if (run_queue_hds[proc] == END_TSO_QUEUE)
-    {
-      /* too strong!
-      ASSERT((CurrentProc==MainProc &&   
-             CurrentTime[MainProc]==0 &&
-             procStatus[MainProc]==Idle) ||
-            procStatus[proc]==Starting);
-      */
-      run_queue_hds[proc] = run_queue_tls[proc] = tso;
-
-      CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadqueuetime;
-
-      /* new_event of ContinueThread has been moved to do_the_startthread */
-
-      /* too strong!
-      ASSERT(procStatus[proc]==Idle || 
-             procStatus[proc]==Fishing || 
-             procStatus[proc]==Starting);
-      procStatus[proc] = Busy;
-      */
-      return;
-    }
-
-  if (RtsFlags.GranFlags.Light)
-    GranSimLight_insertThread(tso, proc);
-
-  /* Only for Pri Scheduling: find place where to insert tso into queue */
-  if (RtsFlags.GranFlags.DoPriorityScheduling && tso->gran.pri!=0)
-    /* {add_to_spark_queue}vo' jInIHta'; Qu' wa'DIch yIleghQo' */
-    for (prev = run_queue_hds[proc], next = run_queue_hds[proc]->link, count=0;
-        (next != END_TSO_QUEUE) && 
-        !(found = tso->gran.pri >= next->gran.pri);
-        prev = next, next = next->link, count++) 
-      { 
-       ASSERT((prev!=(StgTSO*)NULL || next==run_queue_hds[proc]) &&
-             (prev==(StgTSO*)NULL || prev->link==next));
-      }
-
-  ASSERT(!found || next != END_TSO_QUEUE);
-  ASSERT(procStatus[proc]!=Idle);
-  if (found) {
-     /* found can only be rtsTrue if pri scheduling enabled */ 
-     ASSERT(RtsFlags.GranFlags.DoPriorityScheduling);
-     if (RtsFlags.GranFlags.GranSimStats.Global) 
-       globalGranStats.non_end_add_threads++;
-     /* Add tso to ThreadQueue between prev and next */
-     tso->link = next;
-     if ( next == (StgTSO*)END_TSO_QUEUE ) {
-       run_queue_tl = tso;
-     } else {
-       /* no back link for TSO chain */
-     }
-     
-     if ( prev == (StgTSO*)END_TSO_QUEUE ) {
-       /* Never add TSO as first elem of thread queue; the first */
-       /* element should be the one that is currently running -- HWL */
-       IF_DEBUG(gran,
-               belch("GRAN: Qagh: NewThread (w/ PriorityScheduling): Trying to add TSO %p (PRI=%d) as first elem of threadQ (%p) on proc %u (@ %u)\n",
-                   tso, tso->gran.pri, run_queue_hd, proc,
-                   CurrentTime[proc]));
-     } else {
-      prev->link = tso;
-     }
-  } else { /* !found */ /* or not pri sparking! */
-    /* Add TSO to the end of the thread queue on that processor */
-    run_queue_tls[proc]->link = tso;
-    run_queue_tls[proc] = tso;
-  }
-  ASSERT(RtsFlags.GranFlags.DoPriorityScheduling || count==0);
-  CurrentTime[proc] += count * RtsFlags.GranFlags.Costs.pri_sched_overhead +
-                       RtsFlags.GranFlags.Costs.threadqueuetime;
-
-  /* ToDo: check if this is still needed -- HWL 
-  if (RtsFlags.GranFlags.DoThreadMigration)
-    ++SurplusThreads;
-
-  if (RtsFlags.GranFlags.GranSimStats.Full &&
-      !(( event_type == GR_START || event_type == GR_STARTQ) && 
-       RtsFlags.GranFlags.labelling) )
-    DumpRawGranEvent(proc, creator, event_type+1, tso, node, 
-                    tso->gran.sparkname, spark_queue_len(proc));
-  */
-
-# if defined(GRAN_CHECK)
-  /* Check if thread queue is sorted. Only for testing, really!  HWL */
-  if ( RtsFlags.GranFlags.DoPriorityScheduling && 
-       (RtsFlags.GranFlags.Debug.sortedQ) ) {
-    rtsBool sorted = rtsTrue;
-    StgTSO *prev, *next;
-
-    if (run_queue_hds[proc]==END_TSO_QUEUE || 
-       run_queue_hds[proc]->link==END_TSO_QUEUE) {
-      /* just 1 elem => ok */
-    } else {
-      /* Qu' wa'DIch yIleghQo' (ignore first elem)! */
-      for (prev = run_queue_hds[proc]->link, next = prev->link;
-          (next != END_TSO_QUEUE) ;
-          prev = next, next = prev->link) {
-       ASSERT((prev!=(StgTSO*)NULL || next==run_queue_hds[proc]) &&
-              (prev==(StgTSO*)NULL || prev->link==next));
-       sorted = sorted && 
-                (prev->gran.pri >= next->gran.pri);
-      }
-    }
-    if (!sorted) {
-      fprintf(stderr,"Qagh: THREADQ on PE %d is not sorted:\n",
-             CurrentProc);
-      G_THREADQ(run_queue_hd,0x1);
-    }
-  }
-# endif
-}
-
-/*
-  insertThread, which is only used for GranSim Light, is similar to
-  startThread in that it adds a TSO to a thread queue. However, it assumes
-  that the thread queue is sorted by local clocks and it inserts the TSO at
-  the right place in the queue. Don't create any event, just insert.  
-*/
-//@cindex GranSimLight_insertThread
-rtsBool
-GranSimLight_insertThread(tso, proc)
-StgTSO* tso;
-PEs proc;
-{
-  StgTSO *prev, *next;
-  nat count = 0;
-  rtsBool found = rtsFalse;
-
-  ASSERT(RtsFlags.GranFlags.Light);
-
-  /* In GrAnSim-Light we always have an idle `virtual' proc.
-     The semantics of the one-and-only thread queue is different here:
-     all threads in the queue are running (each on its own virtual processor);
-     the queue is only needed internally in the simulator to interleave the
-     reductions of the different processors.
-     The one-and-only thread queue is sorted by the local clocks of the TSOs.
-  */
-  ASSERT(run_queue_hds[proc] != END_TSO_QUEUE);
-  ASSERT(tso->link == END_TSO_QUEUE);
-
-  /* If only one thread in queue so far we emit DESCHEDULE in debug mode */
-  if (RtsFlags.GranFlags.GranSimStats.Full &&
-      (RtsFlags.GranFlags.Debug.checkLight) && 
-      (run_queue_hd->link == END_TSO_QUEUE)) {
-    DumpRawGranEvent(proc, proc, GR_DESCHEDULE,
-                    run_queue_hds[proc], (StgClosure*)NULL, 
-                    tso->gran.sparkname, spark_queue_len(proc)); // ToDo: check spar_queue_len
-    // resched = rtsTrue;
-  }
-
-  /* this routine should only be used in a GrAnSim Light setup */
-  /* && CurrentProc must be 0 in GrAnSim Light setup */
-  ASSERT(RtsFlags.GranFlags.Light && CurrentProc==0);
-
-  /* Idle proc; same for pri spark and basic version */
-  if (run_queue_hd==END_TSO_QUEUE)
-    {
-      run_queue_hd = run_queue_tl = tso;
-      /* MAKE_BUSY(CurrentProc); */
-      return rtsTrue;
-    }
-
-  for (prev = run_queue_hds[proc], next = run_queue_hds[proc]->link, count = 0;
-       (next != END_TSO_QUEUE) && 
-       !(found = (tso->gran.clock < next->gran.clock));
-       prev = next, next = next->link, count++) 
-    { 
-       ASSERT((prev!=(StgTSO*)NULL || next==run_queue_hds[proc]) &&
-             (prev==(StgTSO*)NULL || prev->link==next));
-    }
-
-  /* found can only be rtsTrue if pri sparking enabled */ 
-  if (found) {
-     /* Add tso to ThreadQueue between prev and next */
-     tso->link = next;
-     if ( next == END_TSO_QUEUE ) {
-       run_queue_tls[proc] = tso;
-     } else {
-       /* no back link for TSO chain */
-     }
-     
-     if ( prev == END_TSO_QUEUE ) {
-       run_queue_hds[proc] = tso;
-     } else {
-       prev->link = tso;
-     }
-  } else { /* !found */ /* or not pri sparking! */
-    /* Add TSO to the end of the thread queue on that processor */
-    run_queue_tls[proc]->link = tso;
-    run_queue_tls[proc] = tso;
-  }
-
-  if ( prev == END_TSO_QUEUE ) {        /* new head of queue */
-    new_event(proc, proc, CurrentTime[proc],
-             ContinueThread,
-             tso, (StgClosure*)NULL, (rtsSpark*)NULL);
-  }
-  /*
-  if (RtsFlags.GranFlags.GranSimStats.Full && 
-      !(( event_type == GR_START || event_type == GR_STARTQ) && 
-       RtsFlags.GranFlags.labelling) )
-    DumpRawGranEvent(proc, creator, gr_evttype, tso, node,
-                    tso->gran.sparkname, spark_queue_len(proc));
-  */
-  return rtsTrue;
-}
-
-/*
-  endThread is responsible for general clean-up after the thread tso has
-  finished. This includes emitting statistics into the profile etc.  
-*/
-void
-endThread(StgTSO *tso, PEs proc) 
-{
-  ASSERT(procStatus[proc]==Busy);        // coming straight out of STG land
-  ASSERT(tso->what_next==ThreadComplete);
-  // ToDo: prune ContinueThreads for this TSO from event queue
-  DumpEndEvent(proc, tso, rtsFalse /* not mandatory */);
-
-  /* if this was the last thread on this PE then make it Idle */
-  if (run_queue_hds[proc]==END_TSO_QUEUE) {
-    procStatus[CurrentProc] = Idle;
-  }
-}
-
-//@node Thread Queue routines, GranSim functions, Scheduling functions, GranSim specific code
-//@subsection Thread Queue routines
-
-/* 
-   Check whether given tso resides on the run queue of the current processor.
-   Only used for debugging.
-*/
-   
-//@cindex is_on_queue
-rtsBool
-is_on_queue (StgTSO *tso, PEs proc) 
-{
-  StgTSO *t;
-  rtsBool found;
-
-  for (t=run_queue_hds[proc], found=rtsFalse; 
-       t!=END_TSO_QUEUE && !(found = t==tso);
-       t=t->link)
-    /* nothing */ ;
-
-  return found;
-}
-
-/* This routine  is only  used for keeping   a statistics  of thread  queue
-   lengths to evaluate the impact of priority scheduling. -- HWL 
-   {spark_queue_len}vo' jInIHta'
-*/
-//@cindex thread_queue_len
-nat
-thread_queue_len(PEs proc) 
-{
- StgTSO *prev, *next;
- nat len;
-
- for (len = 0, prev = END_TSO_QUEUE, next = run_queue_hds[proc];
-      next != END_TSO_QUEUE; 
-      len++, prev = next, next = prev->link)
-   {}
-
- return (len);
-}
-
-//@node GranSim functions, GranSimLight routines, Thread Queue routines, GranSim specific code
-//@subsection GranSim functions
-
-/* -----------------------------------------------------------------  */
-/* The main event handling functions; called from Schedule.c (schedule) */
-/* -----------------------------------------------------------------  */
-//@cindex do_the_globalblock
-
-void 
-do_the_globalblock(rtsEvent* event)
-{ 
-  PEs proc          = event->proc;        /* proc that requested node */
-  StgTSO *tso       = event->tso;         /* tso that requested node */
-  StgClosure  *node = event->node;        /* requested, remote node */
-
-  IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the GlobalBlock\n"));
-  /* There should be no GLOBALBLOCKs in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-  /* GlobalBlock events only valid with GUM fetching */
-  ASSERT(RtsFlags.GranFlags.DoBulkFetching);
-
-  IF_GRAN_DEBUG(bq, // globalBlock,
-    if (IS_LOCAL_TO(PROCS(node),proc)) {
-      belch("## Qagh: GlobalBlock: Blocking TSO %d (%p) on LOCAL node %p (PE %d).\n",
-           tso->id, tso, node, proc);
-    });
-
-  /* CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.munpacktime; */
-  if ( blockFetch(tso,proc,node) != 0 )
-    return;                     /* node has become local by now */
-
-#if 0
- ToDo: check whether anything has to be done at all after blockFetch -- HWL
-
-  if (!RtsFlags.GranFlags.DoAsyncFetch) { /* head of queue is next thread */
-    StgTSO* tso = run_queue_hds[proc];       /* awaken next thread */
-    if (tso != (StgTSO*)NULL) {
-      new_event(proc, proc, CurrentTime[proc],
-               ContinueThread,
-               tso, (StgClosure*)NULL, (rtsSpark*)NULL);
-      CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadcontextswitchtime;
-      if (RtsFlags.GranFlags.GranSimStats.Full)
-        DumpRawGranEvent(proc, CurrentProc, GR_SCHEDULE, tso,
-                        (StgClosure*)NULL, tso->gran.sparkname, spark_queue_len(CurrentProc));  // ToDo: check sparkname and spar_queue_len
-      procStatus[proc] = Busy;                  /* might have been fetching */
-    } else {
-      procStatus[proc] = Idle;                     /* no work on proc now */
-    }
-  } else {  /* RtsFlags.GranFlags.DoAsyncFetch i.e. block-on-fetch */
-             /* other thread is already running */
-             /* 'oH 'utbe' 'e' vIHar ; I think that's not needed -- HWL 
-             new_event(proc,proc,CurrentTime[proc],
-                      CONTINUETHREAD,EVENT_TSO(event),
-                      (RtsFlags.GranFlags.DoBulkFetching ? closure :
-                      EVENT_NODE(event)),NULL);
-             */
-  }
-#endif
-}
-
-//@cindex do_the_unblock
-
-void 
-do_the_unblock(rtsEvent* event) 
-{
-  PEs proc = event->proc,       /* proc that requested node */
-      creator = event->creator; /* proc that requested node */
-  StgTSO* tso = event->tso;     /* tso that requested node */
-  StgClosure* node = event->node;  /* requested, remote node */
-  
-  IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the UnBlock\n"))
-  /* There should be no UNBLOCKs in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-  /* UnblockThread means either FetchReply has arrived or
-     a blocking queue has been awakened;
-     ToDo: check with assertions
-  ASSERT(procStatus[proc]==Fetching || IS_BLACK_HOLE(event->node));
-  */
-  if (!RtsFlags.GranFlags.DoAsyncFetch) {  /* block-on-fetch */
-    /* We count block-on-fetch as normal block time */    
-    tso->gran.blocktime += CurrentTime[proc] - tso->gran.blockedat;
-    /* Dumping now done when processing the event
-       No costs for contextswitch or thread queueing in this case 
-       if (RtsFlags.GranFlags.GranSimStats.Full)
-         DumpRawGranEvent(proc, CurrentProc, GR_RESUME, tso, 
-                          (StgClosure*)NULL, tso->gran.sparkname, spark_queue_len(CurrentProc));
-    */
-    /* Maybe do this in FetchReply already 
-    if (procStatus[proc]==Fetching)
-      procStatus[proc] = Busy;
-    */
-    /*
-    new_event(proc, proc, CurrentTime[proc],
-             ContinueThread,
-             tso, node, (rtsSpark*)NULL);
-    */
-  } else {
-    /* Asynchr comm causes additional costs here: */
-    /* Bring the TSO from the blocked queue into the threadq */
-  }
-  /* In all cases, the UnblockThread causes a ResumeThread to be scheduled */
-  new_event(proc, proc, 
-           CurrentTime[proc]+RtsFlags.GranFlags.Costs.threadqueuetime,
-           ResumeThread,
-           tso, node, (rtsSpark*)NULL);
-}
-
-//@cindex do_the_fetchnode
-
-void
-do_the_fetchnode(rtsEvent* event)
-{
-  PEs proc = event->proc,       /* proc that holds the requested node */
-      creator = event->creator; /* proc that requested node */
-  StgTSO* tso = event->tso;
-  StgClosure* node = event->node;  /* requested, remote node */
-  rtsFetchReturnCode rc;
-
-  ASSERT(CurrentProc==proc);
-  /* There should be no FETCHNODEs in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-
-  IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the FetchNode\n"));
-
-  CurrentTime[proc] += RtsFlags.GranFlags.Costs.munpacktime;
-
-  /* ToDo: check whether this is the right place for dumping the event */
-  if (RtsFlags.GranFlags.GranSimStats.Full)
-    DumpRawGranEvent(creator, proc, GR_FETCH, tso, node, (StgInt)0, 0);
-
-  do {
-    rc = handleFetchRequest(node, proc, creator, tso);
-    if (rc == OutOfHeap) {                                   /* trigger GC */
-# if defined(GRAN_CHECK)  && defined(GRAN)
-     if (RtsFlags.GcFlags.giveStats)
-       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, rtsFalse); 
-     // HWL: ToDo: check whether a ContinueThread has to be issued
-     // HWL old: ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
-# 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);  ???
-       fprintf(stderr,"*****      No. of packets so far: %d (total size: %d)\n", 
-               globalGranStats.tot_packets, globalGranStats.tot_packet_size);
-     }
-# endif 
-     event = grab_event();
-     // Hp -= PACK_HEAP_REQUIRED; // ???
-
-     /* GC knows that events are special and follows the pointer i.e. */
-     /* events are valid even if they moved. An EXIT is triggered */
-     /* if there is not enough heap after GC. */
-    }
-  } while (rc == OutOfHeap);
-}
-
-//@cindex do_the_fetchreply
-void 
-do_the_fetchreply(rtsEvent* event)
-{
-  PEs proc = event->proc,       /* proc that requested node */
-      creator = event->creator; /* proc that holds the requested node */
-  StgTSO* tso = event->tso;
-  StgClosure* node = event->node;  /* requested, remote node */
-  StgClosure* closure=(StgClosure*)NULL;
-
-  ASSERT(CurrentProc==proc);
-  ASSERT(RtsFlags.GranFlags.DoAsyncFetch || procStatus[proc]==Fetching);
-
-  IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the FetchReply\n"));
-  /* There should be no FETCHREPLYs in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-
-  /* assign message unpack costs *before* dumping the event */
-  CurrentTime[proc] += RtsFlags.GranFlags.Costs.munpacktime;
-  
-  /* ToDo: check whether this is the right place for dumping the event */
-  if (RtsFlags.GranFlags.GranSimStats.Full)
-    DumpRawGranEvent(proc, creator, GR_REPLY, tso, node, 
-                     tso->gran.sparkname, spark_queue_len(proc));
-
-  /* THIS SHOULD NEVER HAPPEN 
-     If tso is in the BQ of node this means that it actually entered the 
-     remote closure, due to a missing GranSimFetch at the beginning of the 
-     entry code; therefore, this is actually a faked fetch, triggered from 
-     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 awakenBlockedQueue, since the BQ magically moved.
-  */
-  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));
-    // unlink_from_bq(tso, node);
-  }
-    
-  if (RtsFlags.GranFlags.DoBulkFetching) {      /* bulk (packet) fetching */
-    rtsPackBuffer *buffer = (rtsPackBuffer*)node;
-    nat size = buffer->size;
-  
-    /* NB: Fetch misses can't occur with GUM fetching, as */
-    /* updatable closure are turned into RBHs and therefore locked */
-    /* for other processors that try to grab them. */
-  
-    closure = UnpackGraph(buffer);
-    CurrentTime[proc] += size * RtsFlags.GranFlags.Costs.munpacktime;
-  } else  // incremental fetching
-      /* Copy or  move node to CurrentProc */
-      if (fetchNode(node, creator, proc)) {
-        /* Fetch has failed i.e. node has been grabbed by another PE */
-        PEs p = where_is(node);
-        rtsTime fetchtime;
-     
-       if (RtsFlags.GranFlags.GranSimStats.Global)
-         globalGranStats.fetch_misses++;
-
-       IF_GRAN_DEBUG(thunkStealing,
-                belch("== Qu'vatlh! fetch miss @ %u: node %p is at proc %u (rather than proc %u)\n",
-                      CurrentTime[proc],node,p,creator));
-
-       CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mpacktime;
-       
-       /* Count fetch again !? */
-       ++(tso->gran.fetchcount);
-       tso->gran.fetchtime += RtsFlags.GranFlags.Costs.fetchtime;
-        
-       fetchtime = stg_max(CurrentTime[CurrentProc],CurrentTime[p]) +
-                   RtsFlags.GranFlags.Costs.latency;
-       
-       /* Chase the grabbed node */
-       new_event(p, proc, fetchtime,
-                 FetchNode,
-                 tso, node, (rtsSpark*)NULL);
-
-# if 0 && defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
-       IF_GRAN_DEBUG(blockOnFetch,
-                    BlockedOnFetch[CurrentProc] = tso;) /*-rtsTrue;-*/
-       
-       IF_GRAN_DEBUG(blockOnFetch_sanity,
-                    tso->type |= FETCH_MASK_TSO;)
-# endif
-
-        CurrentTime[proc] += RtsFlags.GranFlags.Costs.mtidytime;
-       
-        return; /* NB: no REPLy has been processed; tso still sleeping */
-    }
-
-    /* -- Qapla'! Fetch has been successful; node is here, now  */
-    ++(event->tso->gran.fetchcount);
-    event->tso->gran.fetchtime += RtsFlags.GranFlags.Costs.fetchtime;
-
-    /* this is now done at the beginning of this routine
-    if (RtsFlags.GranFlags.GranSimStats.Full)
-       DumpRawGranEvent(proc,event->creator, GR_REPLY, event->tso,
-                       (RtsFlags.GranFlags.DoBulkFetching ? 
-                              closure : 
-                              event->node),
-                        tso->gran.sparkname, spark_queue_len(proc));
-    */
-
-    ASSERT(OutstandingFetches[proc] > 0);
-    --OutstandingFetches[proc];
-    new_event(proc, proc, CurrentTime[proc],
-             ResumeThread,
-             event->tso, (RtsFlags.GranFlags.DoBulkFetching ? 
-                          closure : 
-                          event->node),
-             (rtsSpark*)NULL);
-}
-
-//@cindex do_the_movethread
-
-void
-do_the_movethread(rtsEvent* event) {
-  PEs proc = event->proc,       /* proc that requested node */
-      creator = event->creator; /* proc that holds the requested node */
-  StgTSO* tso = event->tso;
-
- IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the MoveThread\n"));
-
- ASSERT(CurrentProc==proc);
- /* There should be no MOVETHREADs in GrAnSim Light setup */
- ASSERT(!RtsFlags.GranFlags.Light);
- /* MOVETHREAD events should never occur without -bM */
- ASSERT(RtsFlags.GranFlags.DoThreadMigration);
- /* Bitmask of moved thread should be 0 */
- ASSERT(PROCS(tso)==0);
- ASSERT(procStatus[proc] == Fishing ||
-       RtsFlags.GranFlags.DoAsyncFetch);
- ASSERT(OutstandingFishes[proc]>0);
-
- /* ToDo: exact costs for unpacking the whole TSO  */
- CurrentTime[proc] +=  5l * RtsFlags.GranFlags.Costs.munpacktime;
-
- /* ToDo: check whether this is the right place for dumping the event */
- if (RtsFlags.GranFlags.GranSimStats.Full)
-   DumpRawGranEvent(proc, creator, 
-                   GR_STOLEN, tso, (StgClosure*)NULL, (StgInt)0, 0);
-
- // ToDo: check cost functions
- --OutstandingFishes[proc];
- SET_GRAN_HDR(tso, ThisPE);         // adjust the bitmask for the TSO
- insertThread(tso, proc);
-
- if (procStatus[proc]==Fishing)
-   procStatus[proc] = Idle;
-
- if (RtsFlags.GranFlags.GranSimStats.Global)
-   globalGranStats.tot_TSOs_migrated++;
-}
-
-//@cindex do_the_movespark
-
-void
-do_the_movespark(rtsEvent* event) {
- PEs proc = event->proc,       /* proc that requested spark */
-     creator = event->creator; /* proc that holds the requested spark */
- StgTSO* tso = event->tso;
- rtsSparkQ spark = event->spark;
-
- IF_DEBUG(gran, fprintf(stderr, "GRAN: doing the MoveSpark\n"))
-
- ASSERT(CurrentProc==proc);
- ASSERT(spark!=NULL);
- ASSERT(procStatus[proc] == Fishing ||
-       RtsFlags.GranFlags.DoAsyncFetch);
- ASSERT(OutstandingFishes[proc]>0); 
-
- CurrentTime[proc] += RtsFlags.GranFlags.Costs.munpacktime;
-          
- /* record movement of spark only if spark profiling is turned on */
- if (RtsFlags.GranFlags.GranSimStats.Sparks)
-    DumpRawGranEvent(proc, creator,
-                    SP_ACQUIRED,
-                    tso, spark->node, spark->name, spark_queue_len(proc));
-
- /* global statistics */
- if ( RtsFlags.GranFlags.GranSimStats.Global &&
-      !closure_SHOULD_SPARK(spark->node))
-   globalGranStats.withered_sparks++;
-   /* Not adding the spark to the spark queue would be the right */
-   /* thing here, but it also would be cheating, as this info can't be */
-   /* available in a real system. -- HWL */
-
- --OutstandingFishes[proc];
-
- add_to_spark_queue(spark);
-
- IF_GRAN_DEBUG(randomSteal, // ToDo: spark-distribution flag
-              print_sparkq_stats());
-
- /* Should we treat stolen sparks specially? Currently, we don't. */
-
- if (procStatus[proc]==Fishing)
-   procStatus[proc] = Idle;
-
- /* add_to_spark_queue will increase the time of the current proc. */
- /*
-   If proc was fishing, it is Idle now with the new spark in its spark
-   pool. This means that the next time handleIdlePEs is called, a local
-   FindWork will be created on this PE to turn the spark into a thread. Of
-   course another PE might steal the spark in the meantime (that's why we
-   are using events rather than inlining all the operations in the first
-   place). */
-}
-
-/*
-  In the Constellation class version of GranSim the semantics of StarThread
-  events has changed. Now, StartThread has to perform 3 basic operations:
-   - create a new thread (previously this was done in ActivateSpark);
-   - insert the thread into the run queue of the current processor
-   - generate a new event for actually running the new thread
-  Note that the insertThread is called via createThread. 
-*/
-  
-//@cindex do_the_startthread
-
-void
-do_the_startthread(rtsEvent *event)
-{
-  PEs proc          = event->proc;        /* proc that requested node */
-  StgTSO *tso       = event->tso;         /* tso that requested node */
-  StgClosure  *node = event->node;        /* requested, remote node */
-  rtsSpark *spark   = event->spark;
-  GranEventType gr_evttype;
-
-  ASSERT(CurrentProc==proc);
-  ASSERT(!RtsFlags.GranFlags.Light || CurrentProc==0);
-  ASSERT(event->evttype == ResumeThread || event->evttype == StartThread);
-  /* if this was called via StartThread: */
-  ASSERT(event->evttype!=StartThread || tso == END_TSO_QUEUE); // not yet created
-  // ToDo: check: ASSERT(event->evttype!=StartThread || procStatus[proc]==Starting);
-  /* if this was called via ResumeThread: */
-  ASSERT(event->evttype!=ResumeThread || 
-          RtsFlags.GranFlags.DoAsyncFetch ||!is_on_queue(tso,proc)); 
-
-  /* startThread may have been called from the main event handler upon
-     finding either a ResumeThread or a StartThread event; set the
-     gr_evttype (needed for writing to .gr file) accordingly */
-  // gr_evttype = (event->evttype == ResumeThread) ? GR_RESUME : GR_START;
-
-  if ( event->evttype == StartThread ) {
-    GranEventType gr_evttype = (run_queue_hds[proc]==END_TSO_QUEUE) ? 
-                                 GR_START : GR_STARTQ;
-
-    tso = createThread(BLOCK_SIZE_W, spark->gran_info);// implicit insertThread!
-    pushClosure(tso, node);
-
-    // 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;
-
-    ASSERT(CurrentProc==proc);
-    if (RtsFlags.GranFlags.GranSimStats.Full)
-      DumpGranEvent(gr_evttype,tso);
-
-    CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadcreatetime;
-  } else { // event->evttype == ResumeThread
-    GranEventType gr_evttype = (run_queue_hds[proc]==END_TSO_QUEUE) ? 
-                                 GR_RESUME : GR_RESUMEQ;
-
-    insertThread(tso, proc);
-
-    ASSERT(CurrentProc==proc);
-    if (RtsFlags.GranFlags.GranSimStats.Full)
-      DumpGranEvent(gr_evttype,tso);
-  }
-
-  ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE); // non-empty run queue
-  procStatus[proc] = Busy;
-  /* make sure that this thread is actually run */
-  new_event(proc, proc, 
-           CurrentTime[proc],
-           ContinueThread,
-           tso, node, (rtsSpark*)NULL);
-  
-  /* A wee bit of statistics gathering */
-  if (RtsFlags.GranFlags.GranSimStats.Global) {
-    globalGranStats.tot_add_threads++;
-    globalGranStats.tot_tq_len += thread_queue_len(CurrentProc);
-  }
-
-}
-
-//@cindex do_the_findwork
-void
-do_the_findwork(rtsEvent* event) 
-{
-  PEs proc = event->proc,       /* proc to search for work */
-      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"));
-
-  /* If GUM style fishing is enabled, the contents of the spark field says
-     what to steal (spark(1) or thread(2)); */
-  ASSERT(!(RtsFlags.GranFlags.Fishing && event->spark==(rtsSpark*)0));
-
-  /* Make sure that we have enough heap for creating a new
-     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)");)
-      GarbageCollect(GetRoots);
-      // ReallyPerformThreadGC(req_heap, rtsFalse);   old -- HWL
-      Hp -= req_heap;
-      if (procStatus[CurrentProc]==Sparking) 
-       procStatus[CurrentProc]=Idle;
-      return;
-  }
-#endif
-  
-  if ( RtsFlags.GranFlags.DoAlwaysCreateThreads ||
-       RtsFlags.GranFlags.Fishing ||
-       ((procStatus[proc]==Idle || procStatus[proc]==Sparking) &&
-       (RtsFlags.GranFlags.FetchStrategy >= 2 || 
-        OutstandingFetches[proc] == 0)) ) 
-   {
-    rtsBool found;
-    rtsSparkQ  prev, spark;
-    
-    /* ToDo: check */
-    ASSERT(procStatus[proc]==Sparking ||
-          RtsFlags.GranFlags.DoAlwaysCreateThreads ||
-          RtsFlags.GranFlags.Fishing);
-    
-    /* SImmoHwI' yInej! Search spark queue! */
-    /* gimme_spark (event, &found, &spark); */
-    findLocalSpark(event, &found, &spark);
-
-    if (!found) { /* pagh vumwI' */
-      /*
-        If no spark has been found this can mean 2 things:
-        1/ The FindWork was a fish (i.e. a message sent by another PE) and 
-           the spark pool of the receiver is empty
-           --> the fish has to be forwarded to another PE
-         2/ The FindWork was local to this PE (i.e. no communication; in this
-            case creator==proc) and the spark pool of the PE is not empty 
-           contains only sparks of closures that should not be sparked 
-           (note: if the spark pool were empty, handleIdlePEs wouldn't have 
-           generated a FindWork in the first place)
-           --> the PE has to be made idle to trigger stealing sparks the next
-               time handleIdlePEs is performed
-      */ 
-
-      ASSERT(pending_sparks_hds[proc]==(rtsSpark*)NULL);
-      if (creator==proc) {
-       /* local FindWork */
-       if (procStatus[proc]==Busy) {
-         belch("ghuH: PE %d in Busy state while processing local FindWork (spark pool is empty!) @ %lx",
-               proc, CurrentTime[proc]);
-         procStatus[proc] = Idle;
-       }
-      } else {
-       /* global FindWork i.e. a Fish */
-       ASSERT(RtsFlags.GranFlags.Fishing);
-       /* actually this generates another request from the originating PE */
-       ASSERT(OutstandingFishes[creator]>0);
-       OutstandingFishes[creator]--;
-       /* ToDo: assign costs for sending fish to proc not to creator */
-       stealSpark(creator); /* might steal from same PE; ToDo: fix */
-       ASSERT(RtsFlags.GranFlags.maxFishes!=1 || procStatus[creator] == Fishing);
-       /* any assertions on state of proc possible here? */
-      }
-    } else {
-      /* DaH chu' Qu' yIchen! Now create new work! */ 
-      IF_GRAN_DEBUG(findWork,
-                   belch("+- munching spark %p; creating thread for node %p",
-                         spark, spark->node));
-      activateSpark (event, spark);
-      ASSERT(spark != (rtsSpark*)NULL);
-      spark = delete_from_sparkq (spark, proc, rtsTrue);
-    }
-
-    IF_GRAN_DEBUG(findWork,
-                 belch("+- Contents of spark queues at the end of FindWork @ %lx",
-                       CurrentTime[proc]); 
-                 print_sparkq_stats());
-
-    /* ToDo: check ; not valid if GC occurs in ActivateSpark */
-    ASSERT(!found ||
-           /* forward fish  or */
-           (proc!=creator ||
-           /* local spark  or */
-            (proc==creator && procStatus[proc]==Starting)) || 
-          //(!found && procStatus[proc]==Idle) ||
-          RtsFlags.GranFlags.DoAlwaysCreateThreads); 
-   } else {
-    IF_GRAN_DEBUG(findWork,
-                 belch("+- RTS refuses to findWork on PE %d @ %lx",
-                       proc, CurrentTime[proc]);
-                 belch("  procStatus[%d]=%s, fetch strategy=%d, outstanding fetches[%d]=%d", 
-                       proc, proc_status_names[procStatus[proc]],
-                       RtsFlags.GranFlags.FetchStrategy, 
-                       proc, OutstandingFetches[proc]));
-   }  
-}
-//@node GranSimLight routines, Code for Fetching Nodes, GranSim functions, GranSim specific code
-//@subsection GranSimLight routines
-
-/* 
-   This code is called from the central scheduler after having rgabbed a
-   new event and is only needed for GranSim-Light. It mainly adjusts the
-   ActiveTSO so that all costs that have to be assigned from within the
-   scheduler are assigned to the right TSO. The choice of ActiveTSO depends
-   on the type of event that has been found.  
-*/
-
-void
-GranSimLight_enter_system(event, ActiveTSOp)
-rtsEvent *event;
-StgTSO **ActiveTSOp;
-{
-  StgTSO *ActiveTSO = *ActiveTSOp;
-
-  ASSERT (RtsFlags.GranFlags.Light);
-  
-  /* Restore local clock of the virtual processor attached to CurrentTSO.
-     All costs will be associated to the `virt. proc' on which the tso
-     is living. */
-  if (ActiveTSO != NULL) {                     /* already in system area */
-    ActiveTSO->gran.clock = CurrentTime[CurrentProc];
-    if (RtsFlags.GranFlags.DoFairSchedule)
-      {
-       if (RtsFlags.GranFlags.GranSimStats.Full &&
-           RtsFlags.GranFlags.Debug.checkLight)
-         DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
-      }
-  }
-  switch (event->evttype)
-    { 
-    case ContinueThread: 
-    case FindWork:       /* inaccurate this way */
-      ActiveTSO = run_queue_hd;
-      break;
-    case ResumeThread:   
-    case StartThread:
-    case MoveSpark:      /* has tso of virt proc in tso field of event */
-      ActiveTSO = event->tso;
-      break;
-    default: barf("Illegal event type %s (%d) in GrAnSim Light setup\n",
-                 event_names[event->evttype],event->evttype);
-    }
-  CurrentTime[CurrentProc] = ActiveTSO->gran.clock;
-  if (RtsFlags.GranFlags.DoFairSchedule) {
-      if (RtsFlags.GranFlags.GranSimStats.Full &&
-         RtsFlags.GranFlags.Debug.checkLight)
-       DumpGranEvent(GR_SYSTEM_START,ActiveTSO);
-  }
-}
-
-void
-GranSimLight_leave_system(event, ActiveTSOp)
-rtsEvent *event;
-StgTSO **ActiveTSOp;
-{
-  StgTSO *ActiveTSO = *ActiveTSOp;
-
-  ASSERT(RtsFlags.GranFlags.Light);
-
-  /* Save time of `virt. proc' which was active since last getevent and
-     restore time of `virt. proc' where CurrentTSO is living on. */
-  if(RtsFlags.GranFlags.DoFairSchedule) {
-    if (RtsFlags.GranFlags.GranSimStats.Full &&
-       RtsFlags.GranFlags.Debug.checkLight) // ToDo: clean up flags
-      DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
-  }
-  ActiveTSO->gran.clock = CurrentTime[CurrentProc];
-  ActiveTSO = (StgTSO*)NULL;
-  CurrentTime[CurrentProc] = CurrentTSO->gran.clock;
-  if (RtsFlags.GranFlags.DoFairSchedule /* &&  resched */ ) {
-    // resched = rtsFalse;
-    if (RtsFlags.GranFlags.GranSimStats.Full &&
-       RtsFlags.GranFlags.Debug.checkLight)
-      DumpGranEvent(GR_SCHEDULE,run_queue_hd);
-  }
-  /* 
-     if (TSO_LINK(ThreadQueueHd)!=PrelBase_Z91Z93_closure &&
-     (TimeOfNextEvent == 0 ||
-     TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000<TimeOfNextEvent)) {
-     new_event(CurrentProc,CurrentProc,TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000,
-     CONTINUETHREAD,TSO_LINK(ThreadQueueHd),PrelBase_Z91Z93_closure,NULL);
-     TimeOfNextEvent = get_time_of_next_event();
-     }
-  */
-}
-
-//@node Code for Fetching Nodes, Idle PEs, GranSimLight routines, GranSim specific code
-//@subsection Code for Fetching Nodes
-
-/*
-   The following GrAnSim routines simulate the fetching of nodes from a
-   remote processor. We use a 1 word bitmask to indicate on which processor
-   a node is lying. Thus, moving or copying a node from one processor to
-   another just requires an appropriate change in this bitmask (using
-   @SET_GA@).  Additionally, the clocks have to be updated.
-
-   A special case arises when the node that is needed by processor A has
-   been moved from a processor B to a processor C between sending out a
-   @FETCH@ (from A) and its arrival at B. In that case the @FETCH@ has to
-   be forwarded to C. This is simulated by issuing another FetchNode event
-   on processor C with A as creator.
-*/
-/* ngoqvam che' {GrAnSim}! */
-
-/* Fetch node "node" to processor "p" */
-
-//@cindex fetchNode
-
-rtsFetchReturnCode
-fetchNode(node,from,to)
-StgClosure* node;
-PEs from, to;
-{
-  /* In case of RtsFlags.GranFlags.DoBulkFetching this fct should never be 
-     entered! Instead, UnpackGraph is used in ReSchedule */
-  StgClosure* closure;
-
-  ASSERT(to==CurrentProc);
-  /* Should never be entered  in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-  /* fetchNode should never be entered with DoBulkFetching */
-  ASSERT(!RtsFlags.GranFlags.DoBulkFetching);
-
-  /* Now fetch the node */
-  if (!IS_LOCAL_TO(PROCS(node),from) &&
-      !IS_LOCAL_TO(PROCS(node),to) ) 
-    return NodeHasMoved;
-  
-  if (closure_HNF(node))                /* node already in head normal form? */
-    node->header.gran.procs |= PE_NUMBER(to);           /* Copy node */
-  else
-    node->header.gran.procs = PE_NUMBER(to);            /* Move node */
-
-  return Ok;
-}
-
-/* 
-   Process a fetch request. 
-   
-   Cost of sending a packet of size n = C + P*n
-   where C = packet construction constant, 
-         P = cost of packing one word into a packet
-   [Should also account for multiple packets].
-*/
-
-//@cindex handleFetchRequest
-
-rtsFetchReturnCode
-handleFetchRequest(node,to,from,tso)
-StgClosure* node;   // the node which is requested
-PEs to, from;       // fetch request: from -> to
-StgTSO* tso;        // the tso which needs the node
-{
-  ASSERT(!RtsFlags.GranFlags.Light);
-  /* ToDo: check assertion */
-  ASSERT(OutstandingFetches[from]>0);
-
-  /* probably wrong place; */
-  ASSERT(CurrentProc==to);
-
-  if (IS_LOCAL_TO(PROCS(node), from)) /* Somebody else moved node already => */
-    {                                 /* start tso */
-      IF_GRAN_DEBUG(thunkStealing,
-                   fprintf(stderr,"ghuH: handleFetchRequest entered with local node %p (%s) (PE %d)\n", 
-                           node, info_type(node), from));
-
-      if (RtsFlags.GranFlags.DoBulkFetching) {
-       nat size;
-       rtsPackBuffer *graph;
-
-       /* Create a 1-node-buffer and schedule a FETCHREPLY now */
-       graph = PackOneNode(node, tso, &size); 
-       new_event(from, to, CurrentTime[to],
-                 FetchReply,
-                 tso, (StgClosure *)graph, (rtsSpark*)NULL);
-      } else {
-       new_event(from, to, CurrentTime[to],
-                 FetchReply,
-                 tso, node, (rtsSpark*)NULL);
-      }
-      IF_GRAN_DEBUG(thunkStealing,
-                   belch("== majQa'! closure %p is local on PE %d already (this is a good thing)", node, from));
-      return (NodeIsLocal);
-    }
-  else if (IS_LOCAL_TO(PROCS(node), to) )   /* Is node still here? */
-    {
-      if (RtsFlags.GranFlags.DoBulkFetching) { /* {GUM}vo' ngoqvam vInIHta' */
-       nat size;                              /* (code from GUM) */
-       StgClosure* graph;
-
-       if (IS_BLACK_HOLE(node)) {   /* block on BH or RBH */
-         new_event(from, to, CurrentTime[to],
-                   GlobalBlock,
-                   tso, node, (rtsSpark*)NULL);
-         /* Note: blockFetch is done when handling GLOBALBLOCK event; 
-                  make sure the TSO stays out of the run queue */
-          /* When this thread is reawoken it does the usual: it tries to 
-             enter the updated node and issues a fetch if it's remote.
-             It has forgotten that it has sent a fetch already (i.e. a
-             FETCHNODE is swallowed by a BH, leaving the thread in a BQ) */
-          --OutstandingFetches[from];
-
-         IF_GRAN_DEBUG(thunkStealing,
-                       belch("== majQa'! closure %p on PE %d is a BH (demander=PE %d); faking a FMBQ", 
-                             node, to, from));
-         if (RtsFlags.GranFlags.GranSimStats.Global) {
-           globalGranStats.tot_FMBQs++;
-         }
-         return (NodeIsBH);
-       }
-
-       /* The tso requesting the node is blocked and cannot be on a run queue */
-       ASSERT(!is_on_queue(tso, from));
-       
-       // ToDo: check whether graph is ever used as an rtsPackBuffer!!
-       if ((graph = (StgClosure *)PackNearbyGraph(node, tso, &size, 0)) == NULL) 
-         return (OutOfHeap);  /* out of heap */
-
-       /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
-       /* Send a reply to the originator */
-       /* ToDo: Replace that by software costs for doing graph packing! */
-       CurrentTime[to] += size * RtsFlags.GranFlags.Costs.mpacktime;
-
-       new_event(from, to,
-                 CurrentTime[to]+RtsFlags.GranFlags.Costs.latency,
-                 FetchReply,
-                 tso, (StgClosure *)graph, (rtsSpark*)NULL);
-        
-       CurrentTime[to] += RtsFlags.GranFlags.Costs.mtidytime;
-       return (Ok);
-      } else {                   /* incremental (single closure) fetching */
-       /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
-       /* Send a reply to the originator */
-       CurrentTime[to] += RtsFlags.GranFlags.Costs.mpacktime;
-
-       new_event(from, to,
-                 CurrentTime[to]+RtsFlags.GranFlags.Costs.latency,
-                 FetchReply,
-                 tso, node, (rtsSpark*)NULL);
-      
-       CurrentTime[to] += RtsFlags.GranFlags.Costs.mtidytime;
-       return (Ok);
-      }
-    }
-  else       /* Qu'vatlh! node has been grabbed by another proc => forward */
-    {    
-      PEs node_loc = where_is(node);
-      rtsTime fetchtime;
-
-      IF_GRAN_DEBUG(thunkStealing,
-                   belch("== Qu'vatlh! node %p has been grabbed by PE %d from PE %d (demander=%d) @ %d\n",
-                         node,node_loc,to,from,CurrentTime[to]));
-      if (RtsFlags.GranFlags.GranSimStats.Global) {
-       globalGranStats.fetch_misses++;
-      }
-
-      /* Prepare FORWARD message to proc p_new */
-      CurrentTime[to] += RtsFlags.GranFlags.Costs.mpacktime;
-      
-      fetchtime = stg_max(CurrentTime[to], CurrentTime[node_loc]) +
-                  RtsFlags.GranFlags.Costs.latency;
-          
-      new_event(node_loc, from, fetchtime,
-               FetchNode,
-               tso, node, (rtsSpark*)NULL);
-
-      CurrentTime[to] += RtsFlags.GranFlags.Costs.mtidytime;
-
-      return (NodeHasMoved);
-    }
-}
-
-/*
-   blockFetch blocks a BlockedFetch node on some kind of black hole.
-
-   Taken from gum/HLComms.lc.   [find a  better  place for that ?] --  HWL  
-
-   {\bf Note:} In GranSim we don't have @FETCHME@ nodes and therefore don't
-   create @FMBQ@'s (FetchMe blocking queues) to cope with global
-   blocking. Instead, non-local TSO are put into the BQ in the same way as
-   local TSOs. However, we have to check if a TSO is local or global in
-   order to account for the latencies involved and for keeping track of the
-   number of fetches that are really going on.  
-*/
-
-//@cindex blockFetch
-
-rtsFetchReturnCode
-blockFetch(tso, proc, bh)
-StgTSO* tso;                        /* TSO which gets blocked */
-PEs proc;                           /* PE where that tso was running */
-StgClosure* bh;                     /* closure to block on (BH, RBH, BQ) */
-{
-  StgInfoTable *info;
-
-  IF_GRAN_DEBUG(bq,
-               fprintf(stderr,"## blockFetch: blocking TSO %p (%d)[PE %d] on node %p (%s) [PE %d]. No graph is packed!\n", 
-               tso, tso->id, proc, bh, info_type(bh), where_is(bh)));
-
-    if (!IS_BLACK_HOLE(bh)) {                      /* catches BHs and RBHs */
-      IF_GRAN_DEBUG(bq,
-                   fprintf(stderr,"## blockFetch: node %p (%s) is not a BH => awakening TSO %p (%d) [PE %u]\n", 
-                           bh, info_type(bh), tso, tso->id, proc));
-
-      /* No BH anymore => immediately unblock tso */
-      new_event(proc, proc, CurrentTime[proc],
-               UnblockThread,
-                tso, bh, (rtsSpark*)NULL);
-
-      /* Is this always a REPLY to a FETCH in the profile ? */
-      if (RtsFlags.GranFlags.GranSimStats.Full)
-       DumpRawGranEvent(proc, proc, GR_REPLY, tso, bh, (StgInt)0, 0);
-      return (NodeIsNoBH);
-    }
-
-    /* DaH {BQ}Daq Qu' Suq 'e' wISov!
-       Now we know that we have to put the tso into the BQ.
-       2 cases: If block-on-fetch, tso is at head of threadq => 
-                => take it out of threadq and into BQ
-                If reschedule-on-fetch, tso is only pointed to be event
-                => just put it into BQ
-
-    ngoq ngo'!!
-    if (!RtsFlags.GranFlags.DoAsyncFetch) {
-      GranSimBlock(tso, proc, bh);
-    } else {
-      if (RtsFlags.GranFlags.GranSimStats.Full)
-       DumpRawGranEvent(proc, where_is(bh), GR_BLOCK, tso, bh, (StgInt)0, 0);
-      ++(tso->gran.blockcount);
-      tso->gran.blockedat = CurrentTime[proc];
-    }
-    */
-
-    /* after scheduling the GlobalBlock event the TSO is not put into the
-       run queue again; it is only pointed to via the event we are
-       processing now; in GranSim 4.xx there is no difference between
-       synchr and asynchr comm here */
-    ASSERT(!is_on_queue(tso, proc));
-    ASSERT(tso->link == END_TSO_QUEUE);
-
-    GranSimBlock(tso, proc, bh);  /* GranSim statistics gathering */
-
-    /* Now, put tso into BQ (similar to blocking entry codes) */
-    info = get_itbl(bh);
-    switch (info -> type) {
-      case RBH:
-      case BLACKHOLE:
-      case CAF_BLACKHOLE: // ToDo: check whether this is a possibly ITBL here
-      case SE_BLACKHOLE:   // ToDo: check whether this is a possibly ITBL here
-      case SE_CAF_BLACKHOLE:// ToDo: check whether this is a possibly ITBL here
-       /* basically an inlined version of BLACKHOLE_entry -- HWL */
-       /* Change the BLACKHOLE into a BLACKHOLE_BQ */
-       ((StgBlockingQueue *)bh)->header.info = &BLACKHOLE_BQ_info;
-       /* 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->block_info.closure = bh;
-       recordMutable((StgMutClosure *)bh);
-       break;
-
-    case BLACKHOLE_BQ:
-       /* basically an inlined version of BLACKHOLE_BQ_entry -- HWL */
-       tso->link = (StgTSO *) (((StgBlockingQueue*)bh)->blocking_queue); 
-       ((StgBlockingQueue*)bh)->blocking_queue = (StgBlockingQueueElement *)tso;
-       recordMutable((StgMutClosure *)bh);
-
-# if 0 && defined(GC_MUT_REQUIRED)
-       ToDo: check whether recordMutable is necessary -- HWL
-       /*
-        * 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) = (W_) StorageMgrInfo.OldMutables;
-           StorageMgrInfo.OldMutables = bh;
-       } else
-           MUT_LINK(bh) = MUT_NOT_LINKED;
-# endif
-       break;
-
-    case FETCH_ME_BQ:
-       barf("Qagh: FMBQ closure (%p) found in GrAnSim (TSO=%p (%d))\n",
-            bh, tso, tso->id);
-
-    default:
-       {
-         G_PRINT_NODE(bh);
-         barf("Qagh: thought %p was a black hole (IP %p (%s))",
-                 bh, info, info_type(bh));
-       }
-      }
-    return (Ok);
-}
-
-
-//@node Idle PEs, Routines directly called from Haskell world, Code for Fetching Nodes, GranSim specific code
-//@subsection Idle PEs
-
-/*
-   Export work to idle PEs. This function is called from @ReSchedule@
-   before dispatching on the current event. @HandleIdlePEs@ iterates over
-   all PEs, trying to get work for idle PEs. Note, that this is a
-   simplification compared to GUM's fishing model. We try to compensate for
-   that by making the cost for stealing work dependent on the number of
-   idle processors and thereby on the probability with which a randomly
-   sent fish would find work.  
-*/
-
-//@cindex handleIdlePEs
-
-void
-handleIdlePEs(void)
-{
-  PEs p;
-
-  IF_DEBUG(gran, fprintf(stderr, "GRAN: handling Idle PEs\n"))
-
-  /* Should never be entered in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-
-  /* Could check whether there are idle PEs if it's a cheap check */
-  for (p = 0; p < RtsFlags.GranFlags.proc; p++) 
-    if (procStatus[p]==Idle)  /*  && IS_SPARKING(p) && IS_STARTING(p) */
-      /* First look for local work i.e. examine local spark pool! */
-      if (pending_sparks_hds[p]!=(rtsSpark *)NULL) {
-       new_event(p, p, CurrentTime[p],
-                 FindWork,
-                 (StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
-       procStatus[p] = Sparking;
-      } else if ((RtsFlags.GranFlags.maxFishes==0 ||
-                 OutstandingFishes[p]<RtsFlags.GranFlags.maxFishes) ) {
-
-       /* If no local work then try to get remote work! 
-          Qu' Hopbe' pagh tu'lu'pu'chugh Qu' Hop yISuq ! */
-       if (RtsFlags.GranFlags.DoStealThreadsFirst && 
-           (RtsFlags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[p] == 0))
-         {
-           if (SurplusThreads > 0l)                    /* Steal a thread */
-             stealThread(p);
-          
-           if (procStatus[p]!=Idle)
-             break;
-         }
-       
-       if (SparksAvail > 0 && 
-           (RtsFlags.GranFlags.FetchStrategy >= 3 || OutstandingFetches[p] == 0)) /* Steal a spark */
-         stealSpark(p);
-       
-       if (SurplusThreads > 0 && 
-           (RtsFlags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[p] == 0)) /* Steal a thread */
-         stealThread(p);
-      }
-}
-
-/*
-   Steal a spark and schedule moving it to proc. We want to look at PEs in
-   clock order -- most retarded first.  Currently sparks are only stolen
-   from the @ADVISORY_POOL@ never from the @REQUIRED_POOL@. Eventually,
-   this should be changed to first steal from the former then from the
-   latter.
-
-   We model a sort of fishing mechanism by counting the number of sparks
-   and threads we are currently stealing.  */
-
-/* 
-   Return a random nat value in the intervall [from, to) 
-*/
-static nat 
-natRandom(from, to)
-nat from, to;
-{
-  nat r, d;
-
-  ASSERT(from<=to);
-  d = to - from;
-  /* random returns a value in [0, RAND_MAX] */
-  r = (nat) ((float)from + ((float)random()*(float)d)/(float)RAND_MAX);
-  r = (r==to) ? from : r;
-  ASSERT(from<=r && (r<to || from==to));
-  return r;  
-}
-
-/* 
-   Find any PE other than proc. Used for GUM style fishing only.
-*/
-static PEs 
-findRandomPE (proc)
-PEs proc;
-{
-  nat p;
-
-  ASSERT(RtsFlags.GranFlags.Fishing);
-  if (RtsFlags.GranFlags.RandomSteal) {
-    p = natRandom(0,RtsFlags.GranFlags.proc);  /* full range of PEs */
-  } else {
-    p = 0;
-  }
-  IF_GRAN_DEBUG(randomSteal,
-               belch("^^ RANDOM_STEAL (fishing): stealing from PE %d (current proc is %d)",
-                     p, proc));
-    
-  return (PEs)p;
-}
-
-/*
-  Magic code for stealing sparks/threads makes use of global knowledge on
-  spark queues.  
-*/
-static void
-sortPEsByTime (proc, pes_by_time, firstp, np) 
-PEs proc;
-PEs *pes_by_time;
-nat *firstp, *np;
-{
-  PEs p, temp, n, i, j;
-  nat first, upb, r=0, q=0;
-
-  ASSERT(!RtsFlags.GranFlags.Fishing);
-
-#if 0  
-  upb = RtsFlags.GranFlags.proc;            /* full range of PEs */
-
-  if (RtsFlags.GranFlags.RandomSteal) {
-    r = natRandom(0,RtsFlags.GranFlags.proc);  /* full range of PEs */
-  } else {
-    r = 0;
-  }
-#endif
-
-  /* pes_by_time shall contain processors from which we may steal sparks */ 
-  for(n=0, p=0; p < RtsFlags.GranFlags.proc; ++p)
-    if ((proc != p) &&                       // not the current proc
-        (pending_sparks_hds[p] != (rtsSpark *)NULL) && // non-empty spark pool
-        (CurrentTime[p] <= CurrentTime[CurrentProc]))
-      pes_by_time[n++] = p;
-
-  /* sort pes_by_time */
-  for(i=0; i < n; ++i)
-    for(j=i+1; j < n; ++j)
-      if (CurrentTime[pes_by_time[i]] > CurrentTime[pes_by_time[j]]) {
-       rtsTime temp = pes_by_time[i];
-       pes_by_time[i] = pes_by_time[j];
-       pes_by_time[j] = temp;
-      }
-
-  /* Choose random processor to steal spark from; first look at processors */
-  /* that are earlier than the current one (i.e. proc) */
-  for(first=0; 
-      (first < n) && (CurrentTime[pes_by_time[first]] <= CurrentTime[proc]);
-      ++first)
-    /* nothing */ ;
-
-  /* if the assertion below is true we can get rid of first */
-  /* ASSERT(first==n); */
-  /* ToDo: check if first is really needed; find cleaner solution */
-
-  *firstp = first;
-  *np = n;
-}
-
-/* 
-   Steal a spark (piece of work) from any processor and bring it to proc.
-*/
-//@cindex stealSpark
-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 rtsBool 
-stealThread(PEs proc) { stealSomething(proc, rtsFalse, rtsTrue); }
-
-/* 
-   Steal a spark or a thread and schedule moving it to proc.
-*/
-//@cindex stealSomething
-static rtsBool
-stealSomething(proc, steal_spark, steal_thread)
-PEs proc;                           // PE that needs work (stealer)
-rtsBool steal_spark, steal_thread;  // should a spark and/or thread be stolen
-{
-  PEs p;
-  rtsTime fish_arrival_time;
-  rtsSpark *spark, *prev, *next;
-  rtsBool stolen = rtsFalse;
-
-  ASSERT(steal_spark || steal_thread);
-
-  /* Should never be entered in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-  ASSERT(!steal_thread || RtsFlags.GranFlags.DoThreadMigration);
-
-  if (!RtsFlags.GranFlags.Fishing) {
-    // ToDo: check if stealing threads is prefered over stealing sparks
-    if (steal_spark) {
-      if (stealSparkMagic(proc))
-       return rtsTrue;
-      else                             // no spark found
-       if (steal_thread)
-         return stealThreadMagic(proc);
-        else                           // no thread found
-         return rtsFalse;             
-    } else {                           // ASSERT(steal_thread);
-      return stealThreadMagic(proc);
-    }
-    barf("stealSomething: never reached");
-  }
-
-  /* The rest of this function does GUM style fishing */
-  
-  p = findRandomPE(proc); /* find a random PE other than proc */
-  
-  /* Message packing costs for sending a Fish; qeq jabbI'ID */
-  CurrentTime[proc] += RtsFlags.GranFlags.Costs.mpacktime;
-  
-  /* use another GranEvent for requesting a thread? */
-  if (steal_spark && RtsFlags.GranFlags.GranSimStats.Sparks)
-    DumpRawGranEvent(p, proc, SP_REQUESTED,
-                    (StgTSO*)NULL, (StgClosure *)NULL, (StgInt)0, 0);
-
-  /* time of the fish arrival on the remote PE */
-  fish_arrival_time = CurrentTime[proc] + RtsFlags.GranFlags.Costs.latency;
-  
-  /* Phps use an own Fish event for that? */
-  /* The contents of the spark component is a HACK:
-      1 means give me a spark;
-      2 means give me a thread
-      0 means give me nothing (this should never happen)
-  */
-  new_event(p, proc, fish_arrival_time,
-           FindWork,
-           (StgTSO*)NULL, (StgClosure*)NULL, 
-           (steal_spark ? (rtsSpark*)1 : steal_thread ? (rtsSpark*)2 : (rtsSpark*)0));
-  
-  ++OutstandingFishes[proc];
-  /* only with Async fetching? */
-  if (procStatus[proc]==Idle)  
-    procStatus[proc]=Fishing;
-  
-  /* time needed to clean up buffers etc after sending a message */
-  CurrentTime[proc] += RtsFlags.GranFlags.Costs.mtidytime;
-
-  /* If GUM style fishing stealing always succeeds because it only consists
-     of sending out a fish; of course, when the fish may return
-     empty-handed! */
-  return rtsTrue;
-}
-
-/* 
-   This version of stealing a spark makes use of the global info on all
-   spark pools etc which is not available in a real parallel system.
-   This could be extended to test e.g. the impact of perfect load information.
-*/
-//@cindex stealSparkMagic
-static rtsBool
-stealSparkMagic(proc)
-PEs proc;
-{
-  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;
-
-  /* Should never be entered in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-
-  sortPEsByTime(proc, pes_by_time, &first, &n);
-
-  while (!stolen && n>0) {
-    upb = (first==0) ? n : first;
-    i = natRandom(0,upb);                /* choose a random eligible PE */
-    p = pes_by_time[i];
-
-    IF_GRAN_DEBUG(randomSteal,
-                 belch("^^ stealSparkMagic (random_steal, not fishing): stealing spark from PE %d (current proc is %d)",
-                       p, proc));
-      
-    ASSERT(pending_sparks_hds[p]!=(rtsSpark *)NULL); /* non-empty spark pool */
-
-    /* Now go through rtsSparkQ and steal the first eligible spark */
-    
-    spark = pending_sparks_hds[p]; 
-    while (!stolen && spark != (rtsSpark*)NULL)
-      {
-       /* NB: no prev pointer is needed here because all sparks that are not 
-          chosen are pruned
-       */
-       if ((procStatus[p]==Idle || procStatus[p]==Sparking || procStatus[p] == Fishing) &&
-           spark->next==(rtsSpark*)NULL) 
-         {
-           /* Be social! Don't steal the only spark of an idle processor 
-              not {spark} neH yInIH !! */
-           break; /* next PE */
-         } 
-       else if (closure_SHOULD_SPARK(spark->node))
-         {
-           /* Don't Steal local sparks; 
-              ToDo: optionally prefer local over global sparks
-           if (!spark->global) {
-             prev=spark;
-             continue;                  next spark
-           }
-           */
-           /* found a spark! */
-
-           /* Prepare message for sending spark */
-           CurrentTime[p] += RtsFlags.GranFlags.Costs.mpacktime;
-
-           if (RtsFlags.GranFlags.GranSimStats.Sparks)
-             DumpRawGranEvent(p, (PEs)0, SP_EXPORTED,
-                              (StgTSO*)NULL, spark->node,
-                              spark->name, spark_queue_len(p));
-
-           stealtime = (CurrentTime[p] > CurrentTime[proc] ? 
-                          CurrentTime[p] : 
-                          CurrentTime[proc])
-                       + sparkStealTime();
-
-           new_event(proc, p /* CurrentProc */, stealtime,
-                     MoveSpark,
-                     (StgTSO*)NULL, spark->node, spark);
-           
-           stolen = rtsTrue;
-           ++OutstandingFishes[proc]; /* no. of sparks currently on the fly */
-           if (procStatus[proc]==Idle)
-             procStatus[proc] = Fishing;
-           ++(spark->global);         /* record that this is a global spark */
-           ASSERT(SparksAvail>0);
-           --SparksAvail;            /* on-the-fly sparks are not available */
-           next = delete_from_sparkq(spark, p, rtsFalse); // don't dispose!
-           CurrentTime[p] += RtsFlags.GranFlags.Costs.mtidytime;
-         }
-       else   /* !(closure_SHOULD_SPARK(SPARK_NODE(spark))) */
-         {
-          IF_GRAN_DEBUG(checkSparkQ,
-                        belch("^^ pruning spark %p (node %p) in stealSparkMagic",
-                              spark, spark->node));
-
-           /* if the spark points to a node that should not be sparked,
-              prune the spark queue at this point */
-           if (RtsFlags.GranFlags.GranSimStats.Sparks)
-             DumpRawGranEvent(p, (PEs)0, SP_PRUNED,
-                              (StgTSO*)NULL, spark->node,
-                              spark->name, spark_queue_len(p));
-           if (RtsFlags.GranFlags.GranSimStats.Global)
-             globalGranStats.pruned_sparks++;
-           
-           ASSERT(SparksAvail>0);
-           --SparksAvail;
-           spark = delete_from_sparkq(spark, p, rtsTrue);
-         }
-       /* unlink spark (may have been freed!) from sparkq;
-       if (prev == NULL) // spark was head of spark queue
-         pending_sparks_hds[p] = spark->next;
-        else  
-         prev->next = spark->next;
-       if (spark->next == NULL)
-         pending_sparks_tls[p] = prev;
-        else  
-         next->prev = prev;
-       */
-      }                    /* while ...    iterating over sparkq */
-
-    /* ToDo: assert that PE p still has work left after stealing the spark */
-
-    if (!stolen && (n>0)) {  /* nothing stealable from proc p :( */
-      ASSERT(pes_by_time[i]==p);
-
-      /* remove p from the list (at pos i) */
-      for (j=i; j+1<n; j++)
-       pes_by_time[j] = pes_by_time[j+1];
-      n--;
-      
-      /* update index to first proc which is later (or equal) than proc */
-      for ( ;
-           (first>0) &&
-             (CurrentTime[pes_by_time[first-1]]>CurrentTime[proc]);
-           first--)
-       /* nothing */ ;
-    } 
-  }  /* while ... iterating over PEs in pes_by_time */
-
-  IF_GRAN_DEBUG(randomSteal,
-               if (stolen)
-                 belch("^^ stealSparkMagic: spark %p (node=%p) stolen by PE %d from PE %d (SparksAvail=%d; idlers=%d)",
-                      spark, spark->node, proc, p, 
-                      SparksAvail, idlers());
-               else  
-                 belch("^^ stealSparkMagic: nothing stolen by PE %d (sparkq len after pruning=%d)(SparksAvail=%d; idlers=%d)",
-                       proc, SparksAvail, idlers()));
-
-  if (RtsFlags.GranFlags.GranSimStats.Global &&
-      stolen && (i!=0)) {                          /* only for statistics */
-    globalGranStats.rs_sp_count++;
-    globalGranStats.ntimes_total += n;
-    globalGranStats.fl_total += first;
-    globalGranStats.no_of_steals++;
-  }
-
-  return stolen;
-}
-
-/* 
-   The old stealThread code, which makes use of global info and does not
-   send out fishes.  
-   NB: most of this is the same as in stealSparkMagic;
-       only the pieces specific to processing thread queues are different; 
-       long live polymorphism!  
-*/
-
-//@cindex stealThreadMagic
-static rtsBool
-stealThreadMagic(proc)
-PEs proc;
-{
-  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;
-
-  /* Should never be entered in GrAnSim Light setup */
-  ASSERT(!RtsFlags.GranFlags.Light);
-
-  sortPEsByTime(proc, pes_by_time, &first, &n);
-
-  while (!stolen && n>0) {
-    upb = (first==0) ? n : first;
-    i = natRandom(0,upb);                /* choose a random eligible PE */
-    p = pes_by_time[i];
-
-    IF_GRAN_DEBUG(randomSteal,
-                 belch("^^ stealThreadMagic (random_steal, not fishing): stealing thread from PE %d (current proc is %d)",
-                       p, proc));
-      
-    /* Steal the first exportable thread in the runnable queue but
-       never steal the first in the queue for social reasons;
-       not Qu' wa'DIch yInIH !!
-    */
-    /* Would be better to search through queue and have options which of
-       the threads to pick when stealing */
-    if (run_queue_hds[p] == END_TSO_QUEUE) {
-      IF_GRAN_DEBUG(randomSteal,
-                   belch("^^ stealThreadMagic: No thread to steal from PE %d (stealer=PE %d)", 
-                         p, proc));
-    } else {
-      tso = run_queue_hds[p]->link;  /* tso is *2nd* thread in thread queue */
-      /* Found one */
-      stolen = rtsTrue;
-
-      /* update links in queue */
-      run_queue_hds[p]->link = tso->link;
-      if (run_queue_tls[p] == tso)
-       run_queue_tls[p] = run_queue_hds[p];
-      
-      /* ToDo: Turn magic constants into params */
-      
-      CurrentTime[p] += 5l * RtsFlags.GranFlags.Costs.mpacktime;
-      
-      stealtime = (CurrentTime[p] > CurrentTime[proc] ? 
-                  CurrentTime[p] : 
-                  CurrentTime[proc])
-       + sparkStealTime() 
-       + 4l * RtsFlags.GranFlags.Costs.additional_latency
-       + 5l * RtsFlags.GranFlags.Costs.munpacktime;
-
-      /* Move the thread; set bitmask to 0 while TSO is `on-the-fly' */
-      SET_GRAN_HDR(tso,Nowhere /* PE_NUMBER(proc) */); 
-
-      /* Move from one queue to another */
-      new_event(proc, p, stealtime,
-               MoveThread,
-               tso, (StgClosure*)NULL, (rtsSpark*)NULL);
-
-      /* MAKE_BUSY(proc);  not yet; only when thread is in threadq */
-      ++OutstandingFishes[proc];
-      if (procStatus[proc])
-       procStatus[proc] = Fishing;
-      --SurplusThreads;
-
-      if(RtsFlags.GranFlags.GranSimStats.Full)
-       DumpRawGranEvent(p, proc, 
-                        GR_STEALING, 
-                        tso, (StgClosure*)NULL, (StgInt)0, 0);
-      
-      /* costs for tidying up buffer after having sent it */
-      CurrentTime[p] += 5l * RtsFlags.GranFlags.Costs.mtidytime;
-    }
-
-    /* ToDo: assert that PE p still has work left after stealing the spark */
-
-    if (!stolen && (n>0)) {  /* nothing stealable from proc p :( */
-      ASSERT(pes_by_time[i]==p);
-
-      /* remove p from the list (at pos i) */
-      for (j=i; j+1<n; j++)
-       pes_by_time[j] = pes_by_time[j+1];
-      n--;
-      
-      /* update index to first proc which is later (or equal) than proc */
-      for ( ;
-           (first>0) &&
-             (CurrentTime[pes_by_time[first-1]]>CurrentTime[proc]);
-           first--)
-       /* nothing */ ;
-    } 
-  }  /* while ... iterating over PEs in pes_by_time */
-
-  IF_GRAN_DEBUG(randomSteal,
-               if (stolen)
-                 belch("^^ stealThreadMagic: stolen TSO %d (%p) by PE %d from PE %d (SparksAvail=%d; idlers=%d)",
-                       tso->id, tso, proc, p,
-                       SparksAvail, idlers());
-               else
-                 belch("stealThreadMagic: nothing stolen by PE %d (SparksAvail=%d; idlers=%d)",
-                       proc, SparksAvail, idlers()));
-
-  if (RtsFlags.GranFlags.GranSimStats.Global &&
-      stolen && (i!=0)) { /* only for statistics */
-    /* ToDo: more statistics on avg thread queue lenght etc */
-    globalGranStats.rs_t_count++;
-    globalGranStats.no_of_migrates++;
-  }
-
-  return stolen;
-}
-
-//@cindex sparkStealTime
-static rtsTime
-sparkStealTime(void)
-{
-  double fishdelay, sparkdelay, latencydelay;
-  fishdelay =  (double)RtsFlags.GranFlags.proc/2;
-  sparkdelay = fishdelay - 
-          ((fishdelay-1.0)/(double)(RtsFlags.GranFlags.proc-1))*((double)idlers());
-  latencydelay = sparkdelay*((double)RtsFlags.GranFlags.Costs.latency);
-
-  return((rtsTime)latencydelay);
-}
-
-//@node Routines directly called from Haskell world, Emiting profiling info for GrAnSim, Idle PEs, GranSim specific code
-//@subsection Routines directly called from Haskell world
-/* 
-The @GranSim...@ routines in here are directly called via macros from the
-threaded world. 
-
-First some auxiliary routines.
-*/
-
-/* Take the current thread off the thread queue and thereby activate the 
-   next thread. It's assumed that the next ReSchedule after this uses 
-   NEW_THREAD as param. 
-   This fct is called from GranSimBlock and GranSimFetch 
-*/
-
-//@cindex ActivateNextThread
-
-void 
-ActivateNextThread (proc)
-PEs proc;
-{
-  StgTSO *t;
-  /*
-    This routine is entered either via GranSimFetch or via GranSimBlock.
-    It has to prepare the CurrentTSO for being blocked and update the
-    run queue and other statistics on PE proc. The actual enqueuing to the 
-    blocking queue (if coming from GranSimBlock) is done in the entry code 
-    of the BLACKHOLE and BLACKHOLE_BQ closures (see StgMiscClosures.hc).
-  */
-  /* ToDo: add assertions here!! */
-  //ASSERT(run_queue_hds[proc]!=END_TSO_QUEUE);
-
-  // Only necessary if the running thread is at front of the queue
-  // run_queue_hds[proc] = run_queue_hds[proc]->link;
-  ASSERT(CurrentProc==proc);
-  ASSERT(!is_on_queue(CurrentTSO,proc));
-  if (run_queue_hds[proc]==END_TSO_QUEUE) {
-    /* NB: this routine is only entered with asynchr comm (see assertion) */
-    procStatus[proc] = Idle;
-  } else {
-    /* ToDo: check cost assignment */
-    CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadcontextswitchtime;
-    if (RtsFlags.GranFlags.GranSimStats.Full && 
-       (!RtsFlags.GranFlags.Light || RtsFlags.GranFlags.Debug.checkLight)) 
-                                      /* right flag !?? ^^^ */ 
-      DumpRawGranEvent(proc, 0, GR_SCHEDULE, run_queue_hds[proc],
-                       (StgClosure*)NULL, (StgInt)0, 0);
-  }
-}
-
-/* 
-   The following GranSim fcts are stg-called from the threaded world.    
-*/
-
-/* Called from HP_CHK and friends (see StgMacros.h)  */
-//@cindex GranSimAllocate
-void 
-GranSimAllocate(n)
-StgInt n;
-{
-  CurrentTSO->gran.allocs += n;
-  ++(CurrentTSO->gran.basicblocks);
-
-  if (RtsFlags.GranFlags.GranSimStats.Heap) {
-      DumpRawGranEvent(CurrentProc, 0, GR_ALLOC, CurrentTSO,
-                       (StgClosure*)NULL, (StgInt)0, n);
-  }
-  
-  CurrentTSO->gran.exectime += RtsFlags.GranFlags.Costs.heapalloc_cost;
-  CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.heapalloc_cost;
-}
-
-/*
-  Subtract the values added above, if a heap check fails and
-  so has to be redone.
-*/
-//@cindex GranSimUnallocate
-void 
-GranSimUnallocate(n)
-StgInt n;
-{
-  CurrentTSO->gran.allocs -= n;
-  --(CurrentTSO->gran.basicblocks);
-  
-  CurrentTSO->gran.exectime -= RtsFlags.GranFlags.Costs.heapalloc_cost;
-  CurrentTime[CurrentProc] -= RtsFlags.GranFlags.Costs.heapalloc_cost;
-}
-
-/* NB: We now inline this code via GRAN_EXEC rather than calling this fct */
-//@cindex GranSimExec
-void 
-GranSimExec(ariths,branches,loads,stores,floats)
-StgWord ariths,branches,loads,stores,floats;
-{
-  StgWord cost = RtsFlags.GranFlags.Costs.arith_cost*ariths + 
-            RtsFlags.GranFlags.Costs.branch_cost*branches + 
-            RtsFlags.GranFlags.Costs.load_cost * loads +
-            RtsFlags.GranFlags.Costs.store_cost*stores + 
-            RtsFlags.GranFlags.Costs.float_cost*floats;
-
-  CurrentTSO->gran.exectime += cost;
-  CurrentTime[CurrentProc] += cost;
-}
-
-/* 
-   Fetch the node if it isn't local
-   -- result indicates whether fetch has been done.
-
-   This is GRIP-style single item fetching.
-*/
-
-//@cindex GranSimFetch
-StgInt 
-GranSimFetch(node /* , liveness_mask */ )
-StgClosure *node;
-/* StgInt liveness_mask; */
-{
-  /* reset the return value (to be checked within STG land) */
-  NeedToReSchedule = rtsFalse;   
-
-  if (RtsFlags.GranFlags.Light) {
-     /* Always reschedule in GrAnSim-Light to prevent one TSO from
-        running off too far 
-     new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
-             ContinueThread,CurrentTSO,node,NULL);
-     */
-     return(0); 
-  }
-
-  /* Faking an RBH closure:
-     If the bitmask of the closure is 0 then this node is a fake RBH;
-  */
-  if (node->header.gran.procs == Nowhere) {
-    IF_GRAN_DEBUG(bq,
-                 belch("## Found fake RBH (node %p); delaying TSO %d (%p)", 
-                       node, CurrentTSO->id, CurrentTSO));
-                 
-    new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc]+10000,
-             ContinueThread, CurrentTSO, node, (rtsSpark*)NULL);
-
-    /* Rescheduling (GranSim internal) is necessary */
-    NeedToReSchedule = rtsTrue;
-    
-    return(1); 
-  }
-
-  /* Note: once a node has been fetched, this test will be passed */
-  if (!IS_LOCAL_TO(PROCS(node),CurrentProc))
-    {
-      PEs p = where_is(node);
-      rtsTime fetchtime;
-      
-      IF_GRAN_DEBUG(thunkStealing,
-                   if (p==CurrentProc) 
-                     belch("GranSimFetch: Trying to fetch from own processor%u\n", p););
-      
-      CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mpacktime;
-      /* NB: Fetch is counted on arrival (FetchReply) */
-      
-      fetchtime = stg_max(CurrentTime[CurrentProc],CurrentTime[p]) +
-       RtsFlags.GranFlags.Costs.latency;
-      
-      new_event(p, CurrentProc, fetchtime,
-               FetchNode, CurrentTSO, node, (rtsSpark*)NULL);
-      
-      if (fetchtime<TimeOfNextEvent)
-       TimeOfNextEvent = fetchtime;
-      
-      /* About to block */
-      CurrentTSO->gran.blockedat = CurrentTime[CurrentProc];
-      
-      ++OutstandingFetches[CurrentProc];
-      
-      if (RtsFlags.GranFlags.DoAsyncFetch) 
-       /* if asynchr comm is turned on, activate the next thread in the q */
-       ActivateNextThread(CurrentProc);
-      else
-       procStatus[CurrentProc] = Fetching;
-
-#if 0 
-      /* ToDo: nuke the entire if (anything special for fair schedule?) */
-      if (RtsFlags.GranFlags.DoAsyncFetch) 
-       {
-         /* Remove CurrentTSO from the queue -- assumes head of queue == CurrentTSO */
-         if(!RtsFlags.GranFlags.DoFairSchedule)
-           {
-             /* now done in do_the_fetchnode 
-             if (RtsFlags.GranFlags.GranSimStats.Full)
-               DumpRawGranEvent(CurrentProc, p, GR_FETCH, CurrentTSO,
-                                node, (StgInt)0, 0);
-             */                                
-             ActivateNextThread(CurrentProc);
-              
-# if 0 && defined(GRAN_CHECK)
-             if (RtsFlags.GranFlags.Debug.blockOnFetch_sanity) {
-               if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
-                 fprintf(stderr,"FetchNode: TSO 0x%x has fetch-mask set @ %d\n",
-                         CurrentTSO,CurrentTime[CurrentProc]);
-                 stg_exit(EXIT_FAILURE);
-               } else {
-                 TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
-               }
-             }
-# endif
-             CurrentTSO->link = END_TSO_QUEUE;
-             /* CurrentTSO = END_TSO_QUEUE; */
-             
-             /* CurrentTSO is pointed to by the FetchNode event; it is
-                on no run queue any more */
-         } else {  /* fair scheduling currently not supported -- HWL */
-           barf("Asynchr communication is not yet compatible with fair scheduling\n");
-         }
-       } else {                /* !RtsFlags.GranFlags.DoAsyncFetch */
-         procStatus[CurrentProc] = Fetching; // ToDo: BlockedOnFetch;
-         /* now done in do_the_fetchnode 
-         if (RtsFlags.GranFlags.GranSimStats.Full)
-           DumpRawGranEvent(CurrentProc, p,
-                            GR_FETCH, CurrentTSO, node, (StgInt)0, 0);
-         */
-         IF_GRAN_DEBUG(blockOnFetch, 
-                       BlockedOnFetch[CurrentProc] = CurrentTSO;); /*- rtsTrue; -*/
-       }
-#endif /* 0 */
-
-      CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mtidytime;
-      
-      /* Rescheduling (GranSim internal) is necessary */
-      NeedToReSchedule = rtsTrue;
-      
-      return(1); 
-    }
-  return(0);
-}
-
-//@cindex GranSimSpark
-void 
-GranSimSpark(local,node)
-StgInt local;
-StgClosure *node;
-{
-  /* ++SparksAvail;  Nope; do that in add_to_spark_queue */
-  if (RtsFlags.GranFlags.GranSimStats.Sparks)
-    DumpRawGranEvent(CurrentProc, (PEs)0, SP_SPARK,
-                    END_TSO_QUEUE, node, (StgInt)0, spark_queue_len(CurrentProc)-1);
-
-  /* Force the PE to take notice of the spark */
-  if(RtsFlags.GranFlags.DoAlwaysCreateThreads) {
-    new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
-             FindWork,
-             END_TSO_QUEUE, (StgClosure*)NULL, (rtsSpark*)NULL);
-    if (CurrentTime[CurrentProc]<TimeOfNextEvent)
-      TimeOfNextEvent = CurrentTime[CurrentProc];
-  }
-
-  if(local)
-    ++CurrentTSO->gran.localsparks;
-  else
-    ++CurrentTSO->gran.globalsparks;
-}
-
-//@cindex GranSimSparkAt
-void 
-GranSimSparkAt(spark,where,identifier)
-rtsSpark *spark;
-StgClosure *where;    /* This should be a node; alternatively could be a GA */
-StgInt identifier;
-{
-  PEs p = where_is(where);
-  GranSimSparkAtAbs(spark,p,identifier);
-}
-
-//@cindex GranSimSparkAtAbs
-void 
-GranSimSparkAtAbs(spark,proc,identifier)
-rtsSpark *spark;
-PEs proc;        
-StgInt identifier;
-{
-  rtsTime exporttime;
-
-  if (spark == (rtsSpark *)NULL) /* Note: Granularity control might have */
-    return;                          /* turned a spark into a NULL. */
-
-  /* ++SparksAvail; Nope; do that in add_to_spark_queue */
-  if(RtsFlags.GranFlags.GranSimStats.Sparks)
-    DumpRawGranEvent(proc,0,SP_SPARKAT,
-                    END_TSO_QUEUE, spark->node, (StgInt)0, spark_queue_len(proc));
-
-  if (proc!=CurrentProc) {
-    CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mpacktime;
-    exporttime = (CurrentTime[proc] > CurrentTime[CurrentProc]? 
-                  CurrentTime[proc]: CurrentTime[CurrentProc])
-                 + RtsFlags.GranFlags.Costs.latency;
-  } else {
-    exporttime = CurrentTime[CurrentProc];
-  }
-
-  if ( RtsFlags.GranFlags.Light )
-    /* Need CurrentTSO in event field to associate costs with creating
-       spark even in a GrAnSim Light setup */
-    new_event(proc, CurrentProc, exporttime,
-             MoveSpark,
-             CurrentTSO, spark->node, spark);
-  else
-    new_event(proc, CurrentProc, exporttime,
-             MoveSpark, (StgTSO*)NULL, spark->node, spark);
-  /* Bit of a hack to treat placed sparks the same as stolen sparks */
-  ++OutstandingFishes[proc];
-
-  /* Force the PE to take notice of the spark (FINDWORK is put after a
-     MoveSpark into the sparkq!) */
-  if (RtsFlags.GranFlags.DoAlwaysCreateThreads) {
-    new_event(CurrentProc,CurrentProc,exporttime+1,
-              FindWork,
-             (StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
-  }
-
-  if (exporttime<TimeOfNextEvent)
-    TimeOfNextEvent = exporttime;
-
-  if (proc!=CurrentProc) {
-    CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mtidytime;
-    ++CurrentTSO->gran.globalsparks;
-  } else { 
-    ++CurrentTSO->gran.localsparks;
-  }
-}
-
-/* 
-   This function handles local and global blocking.  It's called either
-   from threaded code (RBH_entry, BH_entry etc) or from blockFetch when
-   trying to fetch an BH or RBH 
-*/
-
-//@cindex GranSimBlock
-void 
-GranSimBlock(tso, proc, node)
-StgTSO *tso;
-PEs proc;
-StgClosure *node;
-{
-  PEs node_proc = where_is(node), 
-      tso_proc = where_is((StgClosure *)tso);
-
-  ASSERT(tso_proc==CurrentProc);
-  // ASSERT(node_proc==CurrentProc);
-  IF_GRAN_DEBUG(bq,
-               if (node_proc!=CurrentProc) 
-                 belch("## ghuH: TSO %d (%lx) [PE %d] blocks on non-local node %p [PE %d] (no simulation of FETCHMEs)",
-                       tso->id, tso, tso_proc, node, node_proc)); 
-  ASSERT(tso->link==END_TSO_QUEUE);
-  ASSERT(!is_on_queue(tso,proc)); // tso must not be on run queue already!
-  //ASSERT(tso==run_queue_hds[proc]);
-
-  IF_DEBUG(gran,
-          belch("GRAN: TSO %d (%p) [PE %d] blocks on closure %p @ %lx",
-                tso->id, tso, proc, node, CurrentTime[proc]));
-
-
-    /* THIS SHOULD NEVER HAPPEN!
-       If tso tries to block on a remote node (i.e. node_proc!=CurrentProc)
-       we have missed a GranSimFetch before entering this closure;
-       we hack around it for now, faking a FetchNode; 
-       because GranSimBlock is entered via a BLACKHOLE(_BQ) closure,
-       tso will be blocked on this closure until the FetchReply occurs.
-
-       ngoq Dogh! 
-
-    if (node_proc!=CurrentProc) {
-      StgInt ret;
-      ret = GranSimFetch(node);
-      IF_GRAN_DEBUG(bq,
-                    if (ret)
-                     belch(".. GranSimBlock: faking a FetchNode of node %p from %d to %d",
-                           node, node_proc, CurrentProc););
-      return;
-    }
-    */
-
-  if (RtsFlags.GranFlags.GranSimStats.Full)
-    DumpRawGranEvent(proc,node_proc,GR_BLOCK,tso,node,(StgInt)0,0);
-
-  ++(tso->gran.blockcount);
-  /* Distinction  between local and global block is made in blockFetch */
-  tso->gran.blockedat = CurrentTime[proc];
-
-  CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadqueuetime;
-  ActivateNextThread(proc);
-  /* tso->link = END_TSO_QUEUE;    not really necessary; only for testing */
-}
-
-#endif /* GRAN */
-
-//@node Index,  , Dumping routines, GranSim specific code
-//@subsection Index
-
-//@index
-//* ActivateNextThread::  @cindex\s-+ActivateNextThread
-//* CurrentProc::  @cindex\s-+CurrentProc
-//* CurrentTime::  @cindex\s-+CurrentTime
-//* GranSimAllocate::  @cindex\s-+GranSimAllocate
-//* GranSimBlock::  @cindex\s-+GranSimBlock
-//* GranSimExec::  @cindex\s-+GranSimExec
-//* GranSimFetch::  @cindex\s-+GranSimFetch
-//* GranSimLight_insertThread::  @cindex\s-+GranSimLight_insertThread
-//* GranSimSpark::  @cindex\s-+GranSimSpark
-//* GranSimSparkAt::  @cindex\s-+GranSimSparkAt
-//* GranSimSparkAtAbs::  @cindex\s-+GranSimSparkAtAbs
-//* GranSimUnallocate::  @cindex\s-+GranSimUnallocate
-//* any_idle::  @cindex\s-+any_idle
-//* blockFetch::  @cindex\s-+blockFetch
-//* do_the_fetchnode::  @cindex\s-+do_the_fetchnode
-//* do_the_fetchreply::  @cindex\s-+do_the_fetchreply
-//* do_the_findwork::  @cindex\s-+do_the_findwork
-//* do_the_globalblock::  @cindex\s-+do_the_globalblock
-//* do_the_movespark::  @cindex\s-+do_the_movespark
-//* do_the_movethread::  @cindex\s-+do_the_movethread
-//* do_the_startthread::  @cindex\s-+do_the_startthread
-//* do_the_unblock::  @cindex\s-+do_the_unblock
-//* fetchNode::  @cindex\s-+fetchNode
-//* ga_to_proc::  @cindex\s-+ga_to_proc
-//* get_next_event::  @cindex\s-+get_next_event
-//* get_time_of_next_event::  @cindex\s-+get_time_of_next_event
-//* grab_event::  @cindex\s-+grab_event
-//* handleFetchRequest::  @cindex\s-+handleFetchRequest
-//* handleIdlePEs::  @cindex\s-+handleIdlePEs
-//* idlers::  @cindex\s-+idlers
-//* insertThread::  @cindex\s-+insertThread
-//* insert_event::  @cindex\s-+insert_event
-//* is_on_queue::  @cindex\s-+is_on_queue
-//* is_unique::  @cindex\s-+is_unique
-//* new_event::  @cindex\s-+new_event
-//* prepend_event::  @cindex\s-+prepend_event
-//* print_event::  @cindex\s-+print_event
-//* print_eventq::  @cindex\s-+print_eventq
-//* prune_eventq ::  @cindex\s-+prune_eventq 
-//* spark queue::  @cindex\s-+spark queue
-//* sparkStealTime::  @cindex\s-+sparkStealTime
-//* stealSomething::  @cindex\s-+stealSomething
-//* stealSpark::  @cindex\s-+stealSpark
-//* stealSparkMagic::  @cindex\s-+stealSparkMagic
-//* stealThread::  @cindex\s-+stealThread
-//* stealThreadMagic::  @cindex\s-+stealThreadMagic
-//* thread_queue_len::  @cindex\s-+thread_queue_len
-//* traverse_eventq_for_gc::  @cindex\s-+traverse_eventq_for_gc
-//* where_is::  @cindex\s-+where_is
-//@end index
diff --git a/rts/parallel/GranSimRts.h b/rts/parallel/GranSimRts.h
deleted file mode 100644 (file)
index fc31a1f..0000000
+++ /dev/null
@@ -1,268 +0,0 @@
-/* --------------------------------------------------------------------------
-   Time-stamp: <Tue Mar 06 2001 00:18:30 Stardate: [-30]6285.06 hwloidl>
-
-   Variables and functions specific to GranSim.
-   ----------------------------------------------------------------------- */
-
-#ifndef GRANSIM_RTS_H
-#define GRANSIM_RTS_H
-
-//@node Headers for GranSim objs used only in the RTS internally, , ,
-//@section Headers for GranSim objs used only in the RTS internally
-
-//@menu
-//* Event queue::              
-//* Spark handling routines::  
-//* Processor related stuff::  
-//* Local types::              
-//* Statistics gathering::     
-//* Prototypes::               
-//@end menu
-//*/ fool highlight
-
-//@node Event queue, Spark handling routines, Headers for GranSim objs used only in the RTS internally, Headers for GranSim objs used only in the RTS internally
-//@subsection Event queue
-
-#if defined(GRAN) || defined(PAR)
-/* Granularity event types for output (see DumpGranEvent) */
-typedef enum GranEventType_ {
-    GR_START = 0, GR_STARTQ, 
-    GR_STEALING, GR_STOLEN, GR_STOLENQ, 
-    GR_FETCH, GR_REPLY, GR_BLOCK, GR_RESUME, GR_RESUMEQ,
-    GR_SCHEDULE, GR_DESCHEDULE,
-    GR_END,
-    SP_SPARK, SP_SPARKAT, SP_USED, SP_PRUNED, SP_EXPORTED, SP_ACQUIRED, SP_REQUESTED,
-    GR_ALLOC,
-    GR_TERMINATE,
-    GR_SYSTEM_START, GR_SYSTEM_END,            /* only for debugging */
-    GR_EVENT_MAX
-} GranEventType;
-
-extern char *gran_event_names[];
-#endif
-
-#if defined(GRAN)                                            /* whole file */
-
-/* Event Types (internal use only) */
-typedef enum rtsEventType_ {
- ContinueThread = 0,  /* Continue running the first thread in the queue */
- StartThread,         /* Start a newly created thread */
- ResumeThread,        /* Resume a previously running thread */
- MoveSpark,           /* Move a spark from one PE to another */
- MoveThread,          /* Move a thread from one PE to another */
- FindWork,            /* Search for work */
- FetchNode,           /* Fetch a node */
- FetchReply,          /* Receive a node */
- GlobalBlock,         /* Block a TSO on a remote node */
- UnblockThread        /* Make a TSO runnable */
-} rtsEventType;
-
-/* Number of last event type */
-#define MAX_EVENT       9
-typedef struct rtsEvent_ {
-  PEs           proc;    /* Processor id */
-  PEs           creator; /* Processor id of PE that created the event */
-  rtsEventType  evttype; /* rtsEvent type */
-  rtsTime       time;    /* Time at which event happened */
-  StgTSO       *tso;     /* Associated TSO, if relevant */
-  StgClosure   *node;    /* Associated node, if relevant */
-  rtsSpark     *spark;   /* Associated SPARK, if relevant */
-  StgInt        gc_info; /* Counter of heap objects to mark (used in GC only)*/
-  struct rtsEvent_ *next;
-  } rtsEvent;
-
-typedef rtsEvent *rtsEventQ;
-
-extern rtsEventQ EventHd;
-
-/* Interface for ADT of Event Queue */
-rtsEvent *get_next_event(void);
-rtsTime   get_time_of_next_event(void);
-void      insert_event(rtsEvent *newentry);
-void      new_event(PEs proc, PEs creator, rtsTime time, 
-                   rtsEventType evttype, StgTSO *tso, 
-                   StgClosure *node, rtsSpark *spark);
-void      print_event(rtsEvent *event);
-void      print_eventq(rtsEvent *hd);
-void      prepend_event(rtsEvent *event);
-rtsEventQ grab_event(void);
-void      prune_eventq(StgTSO *tso, StgClosure *node); 
-
-void      traverse_eventq_for_gc(void);
-void      markEventQueue(void);
-
-//@node Spark handling routines, Processor related stuff, Event queue, Headers for GranSim objs used only in the RTS internally
-//@subsection Spark handling routines
-
-/* These functions are only used in the RTS internally; see GranSim.h for rest */
-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);
-rtsSpark *delete_from_sparkq (rtsSpark *spark, PEs p, rtsBool dispose_too);
-void      markSparkQueue(void);
-
-//@node Processor related stuff, Local types, Spark handling routines, Headers for GranSim objs used only in the RTS internally
-//@subsection Processor related stuff
-
-typedef enum rtsProcStatus_ {
-  Idle = 0,             /* empty threadq */
-  Sparking,             /* non-empty sparkq; FINDWORK has been issued */
-  Starting,             /* STARTTHREAD has been issue */
-  Fetching,             /* waiting for remote data (only if block-on-fetch) */
-  Fishing,              /* waiting for remote spark/thread */
-  Busy                  /* non-empty threadq, with head of queue active */
-} rtsProcStatus;
-
-/*
-#define IS_IDLE(proc)        (procStatus[proc] == Idle)
-#define IS_SPARKING(proc)    (procStatus[proc] == Sparking)
-#define IS_STARTING(proc)    (procStatus[proc] == Starting)
-#define IS_FETCHING(proc)    (procStatus[proc] == Fetching)
-#define IS_FISHING(proc)     (procStatus[proc] == Fishing)
-#define IS_BUSY(proc)        (procStatus[proc] == Busy)    
-#define ANY_IDLE             (any_idle())
-#define MAKE_IDLE(proc)      procStatus[proc] = Idle
-#define MAKE_SPARKING(proc)  procStatus[proc] = Sparking
-#define MAKE_STARTING(proc)  procStatus[proc] = Starting
-#define MAKE_FETCHING(proc)  procStatus[proc] = Fetching
-#define MAKE_FISHING(proc)   procStatus[proc] = Fishing
-#define MAKE_BUSY(proc)      procStatus[proc] = Busy
-*/
-
-//@node Local types, Statistics gathering, Processor related stuff, Headers for GranSim objs used only in the RTS internally
-//@subsection Local types
-
-/* Return codes of HandleFetchRequest:
-    0 ... ok (FETCHREPLY event with a buffer containing addresses of the 
-              nearby graph has been scheduled)
-    1 ... node is already local (fetched by somebody else; no event is
-                                  scheduled in here)
-    2 ... fetch request has been forwrded to the PE that now contains the
-           node
-    3 ... node is a black hole (BH, BQ or RBH); no event is scheduled, and
-           the current TSO is put into the blocking queue of that node
-    4 ... out of heap in PackNearbyGraph; GC should be triggered in calling
-          function to guarantee that the tso and node inputs are valid
-          (they may be moved during GC).
-   Return codes of blockFetch:
-    0 ... ok; tso is now at beginning of BQ attached to the bh closure
-    1 ... the bh closure is no BH any more; tso is immediately unblocked
-*/
-
-typedef enum rtsFetchReturnCode_ {
-  Ok = 0,
-  NodeIsLocal,
-  NodeHasMoved,
-  NodeIsBH,
-  NodeIsNoBH,
-  OutOfHeap,
-} rtsFetchReturnCode;
-  
-//@node Statistics gathering, Prototypes, Local types, Headers for GranSim objs used only in the RTS internally
-//@subsection Statistics gathering
-
-extern unsigned int /* nat */ OutstandingFetches[], OutstandingFishes[];
-extern rtsProcStatus procStatus[];
-extern StgTSO *BlockedOnFetch[];
-
-/* global structure for collecting statistics */
-typedef struct GlobalGranStats_ {
-  /* event stats */
-  nat noOfEvents;
-  nat event_counts[MAX_EVENT];
-
-  /* communication stats */
-  nat fetch_misses;
-  nat tot_fake_fetches;   // GranSim internal; faked Fetches are a kludge!!
-  nat tot_low_pri_sparks;
-
-  /* load distribution statistics */  
-  nat rs_sp_count, rs_t_count, ntimes_total, fl_total, 
-      no_of_steals, no_of_migrates;
-
-  /* spark queue stats */
-  nat tot_sq_len, tot_sq_probes, tot_sparks;
-  nat tot_add_threads, tot_tq_len, non_end_add_threads;
-
-  /* packet statistics */
-  nat tot_packets, tot_packet_size, tot_cuts, tot_thunks;
-
-  /* thread stats */
-  nat tot_threads_created, threads_created_on_PE[MAX_PROC],
-      tot_TSOs_migrated;
-
-  /* spark stats */
-  nat pruned_sparks, withered_sparks;
-  nat tot_sparks_created, sparks_created_on_PE[MAX_PROC];
-
-  /* scheduling stats */
-  nat tot_yields, tot_stackover, tot_heapover;
-
-  /* blocking queue statistics */
-  rtsTime tot_bq_processing_time;
-  nat tot_bq_len, tot_bq_len_local, tot_awbq, tot_FMBQs;
-} GlobalGranStats;
-
-extern GlobalGranStats globalGranStats;
-
-//@node Prototypes,  , Statistics gathering, Headers for GranSim objs used only in the RTS internally
-//@subsection Prototypes
-
-/* Generally useful fcts */
-PEs where_is(StgClosure *node);
-rtsBool is_unique(StgClosure *node);
-
-/* Prototypes of event handling functions; needed in Schedule.c:ReSchedule() */
-void do_the_globalblock (rtsEvent* event);
-void do_the_unblock (rtsEvent* event);
-void do_the_fetchnode (rtsEvent* event);
-void do_the_fetchreply (rtsEvent* event);
-void do_the_movethread (rtsEvent* event);
-void do_the_movespark (rtsEvent* event);
-void do_the_startthread(rtsEvent *event);
-void do_the_findwork(rtsEvent* event);
-void gimme_spark (rtsEvent *event, rtsBool *found_res, rtsSparkQ *spark_res);
-rtsBool munch_spark (rtsEvent *event, rtsSparkQ spark);
-
-/* GranSimLight routines */
-void GranSimLight_enter_system(rtsEvent *event, StgTSO **ActiveTSOp);
-void GranSimLight_leave_system(rtsEvent *event, StgTSO **ActiveTSOp);
-
-/* Communication related routines */
-rtsFetchReturnCode fetchNode(StgClosure* node, PEs from, PEs to);
-rtsFetchReturnCode handleFetchRequest(StgClosure* node, PEs curr_proc, PEs p, StgTSO* tso);
-void               handleIdlePEs(void);
-
-long int random(void); /* used in stealSpark() and stealThread() in GranSim.c */
-
-/* Scheduling fcts defined in GranSim.c */
-void    insertThread(StgTSO *tso, PEs proc);
-void    endThread(StgTSO *tso, PEs proc);
-rtsBool GranSimLight_insertThread(StgTSO *tso, PEs proc);
-nat     thread_queue_len(PEs proc);
-
-/* For debugging */
-rtsBool is_on_queue (StgTSO *tso, PEs proc);
-#endif
-
-#if defined(GRAN) || defined(PAR)
-/* 
-   Interface for dumping routines (i.e. writing to log file).
-   These routines are shared with GUM (and could also be used for SMP).
-*/
-void DumpGranEvent(GranEventType name, StgTSO *tso);
-void DumpEndEvent(PEs proc, StgTSO *tso, rtsBool mandatory_thread);
-void DumpTSO(StgTSO *tso);
-void DumpRawGranEvent(PEs proc, PEs p, GranEventType name, 
-                     StgTSO *tso, StgClosure *node, 
-                     StgInt sparkname, StgInt len);
-void DumpVeryRawGranEvent(rtsTime time, PEs proc, PEs p, GranEventType name,
-                         StgTSO *tso, StgClosure *node, 
-                         StgInt sparkname, StgInt len);
-#endif
-
-#endif /* GRANSIM_RTS_H  */
diff --git a/rts/parallel/HLC.h b/rts/parallel/HLC.h
deleted file mode 100644 (file)
index 793ac84..0000000
+++ /dev/null
@@ -1,63 +0,0 @@
-/* --------------------------------------------------------------------------
-   Time-stamp: <Sun Mar 18 2001 20:16:14 Stardate: [-30]6349.22 hwloidl>
-
-   High Level Communications Header (HLC.h)
-
-   Contains the high-level definitions (i.e. communication
-   subsystem independent) used by GUM
-   Phil Trinder, Glasgow University, 12 December 1994
-   H-W. Loidl, Heriot-Watt, November 1999
-   ----------------------------------------------------------------------- */
-
-#ifndef __HLC_H
-#define __HLC_H
-
-#ifdef PAR
-
-#include "LLC.h"
-
-#define NEW_FISH_AGE           0
-#define NEW_FISH_HISTORY       0
-#define NEW_FISH_HUNGER        0
-#define FISH_LIFE_EXPECTANCY  10
-
-
-//@node GUM Message Sending and Unpacking Functions
-//@subsection GUM Message Sending and Unpacking Functions
-
-rtsBool  initMoreBuffers(void);
-
-void    sendFetch (globalAddr *ga, globalAddr *bqga, int load);
-void    sendResume(globalAddr *rga, int nelem, rtsPackBuffer *packBuffer);
-void    sendAck (GlobalTaskId task, int ngas, globalAddr *gagamap);
-void    sendFish (GlobalTaskId destPE, GlobalTaskId origPE, int age, int history, int hunger);
-void    sendFree (GlobalTaskId destPE, int nelem, P_ data);
-void    sendSchedule(GlobalTaskId origPE, int nelem, rtsPackBuffer *packBuffer);
-void    sendReval(GlobalTaskId origPE, int nelem, rtsPackBuffer *data);
-
-//@node Message-Processing Functions
-//@subsection Message-Processing Functions
-
-rtsBool         processMessages(void);
-void    processFetches(void);
-void    processTheRealFetches(void);
-
-//@node Miscellaneous Functions
-//@subsection Miscellaneous Functions
-
-void    prepareFreeMsgBuffers(void);
-void    freeRemoteGA (int pe, globalAddr *ga);
-void    sendFreeMessages(void);
-
-GlobalTaskId  choosePE(void);
-StgClosure   *createBlockedFetch (globalAddr ga, globalAddr rga);
-void         waitForTermination(void);
-
-/* Message bouncing (startup and shutdown, mainly) */
-void          bounceFish(void);
-void          bounceReval(void);
-
-void          DebugPrintGAGAMap (globalAddr *gagamap, int nGAs);
-
-#endif /* PAR */
-#endif /* __HLC_H */
diff --git a/rts/parallel/HLComms.c b/rts/parallel/HLComms.c
deleted file mode 100644 (file)
index b0982e4..0000000
+++ /dev/null
@@ -1,1810 +0,0 @@
-/* ----------------------------------------------------------------------------
- * Time-stamp: <Wed Mar 21 2001 16:34:41 Stardate: [-30]6363.45 hwloidl>
- *
- * High Level Communications Routines (HLComms.lc)
- *
- * Contains the high-level routines (i.e. communication
- * subsystem independent) used by GUM
- * 
- * GUM 0.2x: Phil Trinder, Glasgow University, 12 December 1994
- * GUM 3.xx: Phil Trinder, Simon Marlow July 1998
- * GUM 4.xx: H-W. Loidl, Heriot-Watt University, November 1999 -
- * 
- * ------------------------------------------------------------------------- */
-
-#ifdef PAR /* whole file */
-
-//@node High Level Communications Routines, , ,
-//@section High Level Communications Routines
-
-//@menu
-//* Macros etc::               
-//* Includes::                 
-//* GUM Message Sending and Unpacking Functions::  
-//* Message-Processing Functions::  
-//* GUM Message Processor::    
-//* Miscellaneous Functions::  
-//* Index::                    
-//@end menu
-
-//@node Macros etc, Includes, High Level Communications Routines, High Level Communications Routines
-//@subsection Macros etc
-
-/* Evidently not Posix */
-/* #include "PosixSource.h" */
-
-//@node Includes, GUM Message Sending and Unpacking Functions, Macros etc, High Level Communications Routines
-//@subsection Includes
-
-#include "Rts.h"
-#include "RtsUtils.h"
-#include "RtsFlags.h"
-#include "Storage.h"   // for recordMutable
-#include "HLC.h"
-#include "Parallel.h"
-#include "GranSimRts.h"
-#include "ParallelRts.h"
-#include "Sparks.h"
-#include "FetchMe.h"     // for BLOCKED_FETCH_info etc
-#if defined(DEBUG)
-# include "ParallelDebug.h"
-#endif
-#include "StgMacros.h" // inlined IS_... fcts
-
-#ifdef DIST
-#include "SchedAPI.h" //for createIOThread
-extern unsigned int context_switch; 
-#endif /* DIST */
-
-//@node GUM Message Sending and Unpacking Functions, Message-Processing Functions, Includes, High Level Communications Routines
-//@subsection GUM Message Sending and Unpacking Functions
-
-/*
- * GUM Message Sending and Unpacking Functions
- */
-
-/*
- * Allocate space for message processing
- */
-
-//@cindex gumPackBuffer
-static rtsPackBuffer *gumPackBuffer;
-
-//@cindex initMoreBuffers
-rtsBool
-initMoreBuffers(void)
-{
-  if ((gumPackBuffer = (rtsPackBuffer *)stgMallocWords(RtsFlags.ParFlags.packBufferSize, 
-                                            "initMoreBuffers")) == NULL)
-    return rtsFalse;
-  return rtsTrue;
-}
-
-/*
- * SendFetch packs the two global addresses and a load into a message +
- * sends it.  
-
-//@cindex FETCH
-
-   Structure of a FETCH message:
-
-         |    GA 1     |        GA 2          |
-         +------------------------------------+------+
-        | gtid | slot | weight | gtid | slot | load |
-        +------------------------------------+------+
- */
-
-//@cindex sendFetch
-void
-sendFetch(globalAddr *rga, globalAddr *lga, int load)
-{
-  ASSERT(rga->weight > 0 && lga->weight > 0);
-  IF_PAR_DEBUG(fetch,
-              belch("~^** Sending Fetch for ((%x, %d, 0)); locally ((%x, %d, %x)), load = %d", 
-                    rga->payload.gc.gtid, rga->payload.gc.slot, 
-                    lga->payload.gc.gtid, lga->payload.gc.slot, lga->weight,
-                    load));
-
-
-  /* ToDo: Dump event
-  DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(rga->payload.gc.gtid), 
-                  GR_FETCH, CurrentTSO, (StgClosure *)(lga->payload.gc.slot),
-                  0, spark_queue_len(ADVISORY_POOL));
-  */
-
-  sendOpV(PP_FETCH, rga->payload.gc.gtid, 6,
-         (StgWord) rga->payload.gc.gtid, (StgWord) rga->payload.gc.slot, 
-         (StgWord) lga->weight, (StgWord) lga->payload.gc.gtid, 
-         (StgWord) lga->payload.gc.slot, (StgWord) load);
-}
-
-/*
- * unpackFetch unpacks a FETCH message into two Global addresses and a load
- * figure.  
-*/
-
-//@cindex unpackFetch
-static void
-unpackFetch(globalAddr *lga, globalAddr *rga, int *load)
-{
-  long buf[6];
-
-  GetArgs(buf, 6); 
-
-  IF_PAR_DEBUG(fetch,
-              belch("~^** Unpacking Fetch for ((%x, %d, 0)) to ((%x, %d, %x)), load = %d", 
-                    (GlobalTaskId) buf[0], (int) buf[1], 
-                    (GlobalTaskId) buf[3], (int) buf[4], buf[2], buf[5]));
-
-  lga->weight = 1;
-  lga->payload.gc.gtid = (GlobalTaskId) buf[0];
-  lga->payload.gc.slot = (int) buf[1];
-
-  rga->weight = (unsigned) buf[2];
-  rga->payload.gc.gtid = (GlobalTaskId) buf[3];
-  rga->payload.gc.slot = (int) buf[4];
-
-  *load = (int) buf[5];
-
-  ASSERT(rga->weight > 0);
-}
-
-/*
- * SendResume packs the remote blocking queue's GA and data into a message 
- * and sends it.
-
-//@cindex RESUME
-
-   Structure of a RESUME message:
-
-      -------------------------------
-      | weight | slot | n | data ...
-      -------------------------------
-
-   data is a packed graph represented as an rtsPackBuffer
-   n is the size of the graph (as returned by PackNearbyGraph) + packet hdr size
- */
-
-//@cindex sendResume
-void
-sendResume(globalAddr *rga, int nelem, rtsPackBuffer *packBuffer)
-{
-  IF_PAR_DEBUG(fetch,
-              belch("~^[] Sending Resume (packet <<%d>> with %d elems) for ((%x, %d, %x)) to [%x]", 
-                    packBuffer->id, nelem,
-                    rga->payload.gc.gtid, rga->payload.gc.slot, rga->weight,
-                    rga->payload.gc.gtid));
-  IF_PAR_DEBUG(packet,
-              PrintPacket(packBuffer));
-
-  ASSERT(nelem==packBuffer->size);
-  /* check for magic end-of-buffer word */
-  IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+nelem) == END_OF_BUFFER_MARKER));
-
-  sendOpNV(PP_RESUME, rga->payload.gc.gtid, 
-          nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM, (StgPtr)packBuffer, 
-          2, (rtsWeight) rga->weight, (StgWord) rga->payload.gc.slot);
-}
-
-/*
- * unpackResume unpacks a Resume message into two Global addresses and
- * a data array.
- */
-
-//@cindex unpackResume
-static void
-unpackResume(globalAddr *lga, int *nelem, rtsPackBuffer *packBuffer)
-{
-    long buf[3];
-
-    GetArgs(buf, 3); 
-
-    /*
-      RESUME event is written in awaken_blocked_queue
-    DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(lga->payload.gc.gtid), 
-                    GR_RESUME, END_TSO_QUEUE, (StgClosure *)NULL, 0, 0);
-    */
-
-    lga->weight = (unsigned) buf[0];
-    lga->payload.gc.gtid = mytid;
-    lga->payload.gc.slot = (int) buf[1];
-
-    *nelem = (int) buf[2] - PACK_BUFFER_HDR_SIZE - DEBUG_HEADROOM;
-    GetArgs(packBuffer, *nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM);
-
-    IF_PAR_DEBUG(fetch,
-                belch("~^[] Unpacking Resume (packet <<%d>> with %d elems) for ((%x, %d, %x))", 
-                      packBuffer->id, *nelem, mytid, (int) buf[1], (unsigned) buf[0]));
-
-    /* check for magic end-of-buffer word */
-    IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+*nelem) == END_OF_BUFFER_MARKER));
-}
-
-/*
- * SendAck packs the global address being acknowledged, together with
- * an array of global addresses for any closures shipped and sends them.
-
-//@cindex ACK
-
-   Structure of an ACK message:
-
-      |        GA 1          |        GA 2          | 
-      +---------------------------------------------+-------
-      | weight | gtid | slot | weight | gtid | slot |  .....  ngas times
-      + --------------------------------------------+------- 
-
- */
-
-//@cindex sendAck
-void
-sendAck(GlobalTaskId task, int ngas, globalAddr *gagamap)
-{
-  static long *buffer;
-  long *p;
-  int i;
-
-  if(ngas==0)
-    return; //don't send unnecessary messages!!
-  
-  buffer = (long *) gumPackBuffer;
-
-  for(i = 0, p = buffer; i < ngas; i++, p += 6) {
-    ASSERT(gagamap[1].weight > 0);
-    p[0] = (long) gagamap->weight;
-    p[1] = (long) gagamap->payload.gc.gtid;
-    p[2] = (long) gagamap->payload.gc.slot;
-    gagamap++;
-    p[3] = (long) gagamap->weight;
-    p[4] = (long) gagamap->payload.gc.gtid;
-    p[5] = (long) gagamap->payload.gc.slot;
-    gagamap++;
-  }
-  IF_PAR_DEBUG(schedule,
-              belch("~^,, Sending Ack (%d pairs) to [%x]\n", 
-                    ngas, task));
-
-  sendOpN(PP_ACK, task, p - buffer, (StgPtr)buffer);
-}
-
-/*
- * unpackAck unpacks an Acknowledgement message into a Global address,
- * a count of the number of global addresses following and a map of 
- * Global addresses
- */
-
-//@cindex unpackAck
-static void
-unpackAck(int *ngas, globalAddr *gagamap)
-{
-  long GAarraysize;
-  long buf[6];
-  
-  GetArgs(&GAarraysize, 1);
-  
-  *ngas = GAarraysize / 6;
-  
-  IF_PAR_DEBUG(schedule,
-              belch("~^,, Unpacking Ack (%d pairs) on [%x]\n", 
-                    *ngas, mytid));
-
-  while (GAarraysize > 0) {
-    GetArgs(buf, 6);
-    gagamap->weight = (rtsWeight) buf[0];
-    gagamap->payload.gc.gtid = (GlobalTaskId) buf[1];
-    gagamap->payload.gc.slot = (int) buf[2];
-    gagamap++;
-    gagamap->weight = (rtsWeight) buf[3];
-    gagamap->payload.gc.gtid = (GlobalTaskId) buf[4];
-    gagamap->payload.gc.slot = (int) buf[5];
-    ASSERT(gagamap->weight > 0);
-    gagamap++;
-    GAarraysize -= 6;
-  }
-}
-
-/*
- * SendFish packs the global address being acknowledged, together with
- * an array of global addresses for any closures shipped and sends them.
-
-//@cindex FISH
-
- Structure of a FISH message:
-
-     +----------------------------------+
-     | orig PE | age | history | hunger |
-     +----------------------------------+
- */
-
-//@cindex sendFish
-void
-sendFish(GlobalTaskId destPE, GlobalTaskId origPE, 
-        int age, int history, int hunger)
-{
-  IF_PAR_DEBUG(fish,
-              belch("~^$$ Sending Fish to [%x] (%d outstanding fishes)", 
-                    destPE, outstandingFishes));
-
-  sendOpV(PP_FISH, destPE, 4, 
-         (StgWord) origPE, (StgWord) age, (StgWord) history, (StgWord) hunger);
-
-  if (origPE == mytid) {
-    //fishing = rtsTrue;
-    outstandingFishes++;
-  }
-}
-
-/*
- * unpackFish unpacks a FISH message into the global task id of the
- * originating PE and 3 data fields: the age, history and hunger of the
- * fish. The history + hunger are not currently used.
-
- */
-
-//@cindex unpackFish
-static void
-unpackFish(GlobalTaskId *origPE, int *age, int *history, int *hunger)
-{
-  long buf[4];
-  
-  GetArgs(buf, 4);
-  
-  IF_PAR_DEBUG(fish,
-              belch("~^$$ Unpacking Fish from [%x] (age=%d)", 
-                    (GlobalTaskId) buf[0], (int) buf[1]));
-
-  *origPE = (GlobalTaskId) buf[0];
-  *age = (int) buf[1];
-  *history = (int) buf[2];
-  *hunger = (int) buf[3];
-}
-
-/*
- * SendFree sends (weight, slot) pairs for GAs that we no longer need
- * references to.  
-
-//@cindex FREE
-
-   Structure of a FREE message:
-   
-       +-----------------------------
-       | n | weight_1 | slot_1 | ...
-       +-----------------------------
- */
-//@cindex sendFree
-void
-sendFree(GlobalTaskId pe, int nelem, StgPtr data)
-{
-    IF_PAR_DEBUG(free,
-                belch("~^!! Sending Free (%d GAs) to [%x]", 
-                      nelem/2, pe));
-
-    sendOpN(PP_FREE, pe, nelem, data);
-}
-
-/*
- * unpackFree unpacks a FREE message into the amount of data shipped and
- * a data block.
- */
-//@cindex unpackFree
-static void
-unpackFree(int *nelem, StgWord *data)
-{
-  long buf[1];
-  
-  GetArgs(buf, 1);
-  *nelem = (int) buf[0];
-
-  IF_PAR_DEBUG(free,
-              belch("~^!! Unpacking Free (%d GAs)", 
-                    *nelem/2));
-
-  GetArgs(data, *nelem);
-}
-
-/*
- * SendSchedule sends a closure to be evaluated in response to a Fish
- * message. The message is directed to the PE that originated the Fish
- * (origPE), and includes the packed closure (data) along with its size
- * (nelem).
-
-//@cindex SCHEDULE
-
-   Structure of a SCHEDULE message:
-
-       +------------------------------------
-       | PE | n | pack buffer of a graph ...
-       +------------------------------------
- */
-//@cindex sendSchedule
-void
-sendSchedule(GlobalTaskId origPE, int nelem, rtsPackBuffer *packBuffer) 
-{
-  IF_PAR_DEBUG(schedule,
-              belch("~^-- Sending Schedule (packet <<%d>> with %d elems) to [%x]\n", 
-                    packBuffer->id, nelem, origPE));
-  IF_PAR_DEBUG(packet,
-              PrintPacket(packBuffer));
-
-  ASSERT(nelem==packBuffer->size);
-  /* check for magic end-of-buffer word */
-  IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+nelem) == END_OF_BUFFER_MARKER));
-
-  sendOpN(PP_SCHEDULE, origPE, 
-         nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM, (StgPtr)packBuffer);
-}
-
-/*
- * unpackSchedule unpacks a SCHEDULE message into the Global address of
- * the closure shipped, the amount of data shipped (nelem) and the data
- * block (data).
- */
-
-//@cindex unpackSchedule
-static void
-unpackSchedule(int *nelem, rtsPackBuffer *packBuffer)
-{
-  long buf[1];
-
-  /* first, just unpack 1 word containing the total size (including header) */
-  GetArgs(buf, 1);
-  /* no. of elems, not counting the header of the pack buffer */
-  *nelem = (int) buf[0] - PACK_BUFFER_HDR_SIZE - DEBUG_HEADROOM;
-
-  /* automatic cast of flat pvm-data to rtsPackBuffer */
-  GetArgs(packBuffer, *nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM);
-
-  IF_PAR_DEBUG(schedule,
-              belch("~^-- Unpacking Schedule (packet <<%d>> with %d elems) on [%x]\n", 
-                    packBuffer->id, *nelem, mytid));
-
-  ASSERT(*nelem==packBuffer->size);
-  /* check for magic end-of-buffer word */
-  IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+*nelem) == END_OF_BUFFER_MARKER));
-}
-
-#ifdef DIST
-/* sendReval is almost identical to the Schedule version, so we can unpack with unpackSchedule */
-void
-sendReval(GlobalTaskId origPE, int nelem, rtsPackBuffer *packBuffer) 
-{  
-  IF_PAR_DEBUG(schedule,
-              belch("~^-- Sending Reval (packet <<%d>> with %d elems) to [%x]\n", 
-                    packBuffer->id, nelem, origPE));
-  IF_PAR_DEBUG(packet,
-              PrintPacket(packBuffer));
-
-  ASSERT(nelem==packBuffer->size);
-  /* check for magic end-of-buffer word */
-  IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+nelem) == END_OF_BUFFER_MARKER));
-
-  sendOpN(PP_REVAL, origPE, 
-         nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM, (StgPtr)packBuffer);
-}
-
-void FinishReval(StgTSO *t)
-{ StgClosure *res;
-  globalAddr ga;
-  nat size;
-  rtsPackBuffer *buffer=NULL;
-  
-  ga.payload.gc.slot = t->revalSlot;
-  ga.payload.gc.gtid = t->revalTid;
-  ga.weight = 0; 
-  
-  //find where the reval result is
-  res = GALAlookup(&ga);
-  ASSERT(res);
-  
-  IF_PAR_DEBUG(schedule,
-    printGA(&ga);
-    belch(" needs the result %08x\n",res));       
-  
-  //send off the result
-  buffer = PackNearbyGraph(res, END_TSO_QUEUE, &size,ga.payload.gc.gtid);
-  ASSERT(buffer != (rtsPackBuffer *)NULL);
-  sendResume(&ga, size, buffer);
-
-  IF_PAR_DEBUG(schedule,
-    belch("@;~) Reval Finished"));
-}
-
-#endif /* DIST */
-
-//@node Message-Processing Functions, GUM Message Processor, GUM Message Sending and Unpacking Functions, High Level Communications Routines
-//@subsection Message-Processing Functions
-
-/*
- * Message-Processing Functions
- *
- * The following routines process incoming GUM messages. Often reissuing
- * messages in response.
- *
- * processFish unpacks a fish message, reissuing it if it's our own,
- * sending work if we have it or sending it onwards otherwise.
- */
-
-/*
- * 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 
- * BlockedFetches from a blocking queue to the PendingFetches queue.
- */
-void GetRoots(void);
-extern StgBlockedFetch *PendingFetches;
-
-nat
-pending_fetches_len(void)
-{
-  StgBlockedFetch *bf;
-  nat n;
-
-  for (n=0, bf=PendingFetches; bf != END_BF_QUEUE; n++, bf = (StgBlockedFetch *)(bf->link)) {
-    ASSERT(get_itbl(bf)->type==BLOCKED_FETCH);
-  }
-  return n;
-}
-
-//@cindex processFetches
-void
-processFetches(void) {
-  StgBlockedFetch *bf, *next;
-  StgClosure *closure;
-  StgInfoTable *ip;
-  globalAddr rga;
-  static rtsPackBuffer *packBuffer;
-    
-  IF_PAR_DEBUG(verbose,
-              belch("____ processFetches: %d pending fetches (root @ %p)",
-                    pending_fetches_len(), PendingFetches));
-  
-  for (bf = PendingFetches; 
-       bf != END_BF_QUEUE;
-       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
-     * process it in much the same fashion as the original target
-     * of the fetch.  Though we hope to find graph here, we could
-     * find a black hole (of any flavor) or even a FetchMe.
-     */
-    closure = bf->node;
-    /*
-      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).
-    */
-    ASSERT(get_itbl(closure)->type != EVACUATED);
-      //  closure = ((StgEvacuated *)closure)->evacuee;
-
-    closure = UNWIND_IND(closure);
-    //while ((ind = IS_INDIRECTION(closure)) != NULL) { closure = ind; }
-
-    ip = get_itbl(closure);
-    if (ip->type == FETCH_ME) {
-      /* Forward the Fetch to someone else */
-      rga.payload.gc.gtid = bf->ga.payload.gc.gtid;
-      rga.payload.gc.slot = bf->ga.payload.gc.slot;
-      rga.weight = bf->ga.weight;
-      
-      sendFetch(((StgFetchMe *)closure)->ga, &rga, 0 /* load */);
-
-      // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_fetch_mess++;
-      }
-
-      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 => doing a blockFetch on closure %p (%s)",
-                        closure, info_type(closure)));
-      bf->node = closure;
-      blockFetch(bf, closure);
-    } else {
-      /* We now have some local graph to send back */
-      nat size;
-
-      packBuffer = gumPackBuffer;
-      IF_PAR_DEBUG(verbose,
-                  belch("__*> processFetches: PackNearbyGraph of closure %p (%s)",
-                        closure, info_type(closure)));
-
-      if ((packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, bf->ga.payload.gc.gtid)) == NULL) {
-       // Put current BF back on list
-       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, rtsFalse); 
-       bf = PendingFetches;
-       PendingFetches = (StgBlockedFetch *)(bf->link);
-       closure = bf->node;
-       packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, bf->ga.payload.gc.gtid);
-       ASSERT(packBuffer != (rtsPackBuffer *)NULL);
-      }
-      rga.payload.gc.gtid = bf->ga.payload.gc.gtid;
-      rga.payload.gc.slot = bf->ga.payload.gc.slot;
-      rga.weight = bf->ga.weight;
-      
-      sendResume(&rga, size, packBuffer);
-
-      // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_resume_mess++;
-      }
-    }
-  }
-  PendingFetches = END_BF_QUEUE;
-}
-
-#if 0
-/*
-  Alternatively to sending fetch messages directly from the FETCH_ME_entry
-  code we could just store the data about the remote data in a global
-  variable and send the fetch request from the main scheduling loop (similar
-  to processFetches above). This would save an expensive STGCALL in the entry 
-  code because we have to go back to the scheduler anyway.
-*/
-//@cindex processFetches
-void
-processTheRealFetches(void) {
-  StgBlockedFetch *bf;
-  StgClosure *closure, *next;
-    
-  IF_PAR_DEBUG(verbose,
-              belch("__ processTheRealFetches: ");
-              printGA(&theGlobalFromGA);
-              printGA(&theGlobalToGA));
-
-  ASSERT(theGlobalFromGA.payload.gc.gtid != 0 &&
-        theGlobalToGA.payload.gc.gtid != 0);
-
-  /* the old version did this in the FETCH_ME entry code */
-  sendFetch(&theGlobalFromGA, &theGlobalToGA, 0/*load*/);
-  
-}
-#endif
-
-
-/* 
-   Way of dealing with unwanted fish.
-   Used during startup/shutdown, or from unknown PEs 
-*/
-void
-bounceFish(void) { 
-  GlobalTaskId origPE;
-  int age, history, hunger;
-  
-  /* IF_PAR_DEBUG(verbose, */
-              belch(".... [%x] Bouncing unwanted FISH",mytid);
-
-  unpackFish(&origPE, &age, &history, &hunger);
-         
-  if (origPE == mytid) {
-    //fishing = rtsFalse;                   // fish has come home
-    outstandingFishes--;
-    last_fish_arrived_at = CURRENT_TIME;  // remember time (see schedule fct)
-    return;                               // that's all
-  }
-
-  /* otherwise, send it home to die */
-  sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
-  // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_fish_mess++;
-      }
-}
-   
-/*
- * processFish unpacks a fish message, reissuing it if it's our own,
- * sending work if we have it or sending it onwards otherwise.
- */
-//@cindex processFish
-static void
-processFish(void)
-{
-  GlobalTaskId origPE;
-  int age, history, hunger;
-  rtsSpark spark;
-  static rtsPackBuffer *packBuffer; 
-
-  unpackFish(&origPE, &age, &history, &hunger);
-
-  if (origPE == mytid) {
-    //fishing = rtsFalse;                   // fish has come home
-    outstandingFishes--;
-    last_fish_arrived_at = CURRENT_TIME;  // remember time (see schedule fct)
-    return;                               // that's all
-  }
-
-  ASSERT(origPE != mytid);
-  IF_PAR_DEBUG(fish,
-              belch("$$__ processing fish; %d sparks available",
-                    spark_queue_len(&(MainRegTable.rSparks))));
-  while ((spark = findSpark(rtsTrue/*for_export*/)) != NULL) {
-    nat size;
-    // StgClosure *graph;
-
-    packBuffer = gumPackBuffer; 
-    ASSERT(closure_SHOULD_SPARK((StgClosure *)spark));
-    if ((packBuffer = PackNearbyGraph(spark, END_TSO_QUEUE, &size,origPE)) == NULL) {
-      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, rtsFalse);
-      /* Now go back and try again */
-    } else {
-      IF_PAR_DEBUG(verbose,
-                  if (RtsFlags.ParFlags.ParStats.Sparks)
-                    belch("==== STEALING spark %x; sending to %x", spark, origPE));
-      
-      IF_PAR_DEBUG(fish,
-                  belch("$$-- Replying to FISH from %x by sending graph @ %p (%s)",
-                        origPE, 
-                        (StgClosure *)spark, info_type((StgClosure *)spark)));
-      sendSchedule(origPE, size, packBuffer);
-      disposeSpark(spark);
-      // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_schedule_mess++;
-      }
-
-      break;
-    }
-  }
-  if (spark == (rtsSpark)NULL) {
-    IF_PAR_DEBUG(fish,
-                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 */
-      sendFish(choosePE(), origPE,
-              (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
-
-      // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_fish_mess++;
-      }
-    } else { /* otherwise, send it home to die */
-      sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
-      // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_fish_mess++;
-      }
-    }
-  }
-}  /* processFish */
-
-/*
- * processFetch either returns the requested data (if available) 
- * or blocks the remote blocking queue on a black hole (if not).
- */
-
-//@cindex processFetch
-static void
-processFetch(void)
-{
-  globalAddr ga, rga;
-  int load;
-  StgClosure *closure;
-  StgInfoTable *ip;
-
-  unpackFetch(&ga, &rga, &load);
-  IF_PAR_DEBUG(fetch,
-              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));
-
-  closure = GALAlookup(&ga);
-  ASSERT(closure != (StgClosure *)NULL);
-  ip = get_itbl(closure);
-  if (ip->type == FETCH_ME) {
-    /* Forward the Fetch to someone else */
-    sendFetch(((StgFetchMe *)closure)->ga, &rga, load);
-
-    // Global statistics: count no. of fetches
-    if (RtsFlags.ParFlags.ParStats.Global &&
-       RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-      globalParStats.tot_fetch_mess++;
-    }
-  } else if (rga.payload.gc.gtid == mytid) {
-    /* Our own FETCH forwarded back around to us */
-    StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)GALAlookup(&rga);
-    
-    IF_PAR_DEBUG(fetch,
-                belch("%%%%== Fetch returned to sending PE; closure=%p (%s); receiver=%p (%s)",
-                      closure, info_type(closure), fmbq, info_type((StgClosure*)fmbq)));
-    /* We may have already discovered that the fetch target is our own. */
-    if ((StgClosure *)fmbq != closure) 
-      CommonUp((StgClosure *)fmbq, closure);
-    (void) addWeight(&rga);
-  } else if (IS_BLACK_HOLE(closure)) {
-    /* This includes RBH's and FMBQ's */
-    StgBlockedFetch *bf;
-
-    /* Can we assert something on the remote GA? */
-    ASSERT(GALAlookup(&rga) == NULL);
-
-    /* If we're hitting a BH or RBH or FMBQ we have to put a BLOCKED_FETCH
-       closure into the BQ in order to denote that when updating this node
-       the result should be sent to the originator of this fetch message. */
-    bf = (StgBlockedFetch *)createBlockedFetch(ga, rga);
-    IF_PAR_DEBUG(fetch,
-                belch("%%++ Blocking Fetch ((%x, %d, %x)) on %p (%s)",
-                      rga.payload.gc.gtid, rga.payload.gc.slot, rga.weight, 
-                      closure, info_type(closure)));
-    blockFetch(bf, closure);
-  } else {                     
-    /* The target of the FetchMe is some local graph */
-    nat size;
-    // StgClosure *graph;
-    rtsPackBuffer *buffer = (rtsPackBuffer *)NULL;
-
-    if ((buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, rga.payload.gc.gtid)) == NULL) {
-      barf("processFetch: out of heap while packing graph; ToDo: call GC here");
-      GarbageCollect(GetRoots, rtsFalse); 
-      closure = GALAlookup(&ga);
-      buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, rga.payload.gc.gtid);
-      ASSERT(buffer != (rtsPackBuffer *)NULL);
-    }
-    sendResume(&rga, size, buffer);
-
-    // Global statistics: count no. of fetches
-    if (RtsFlags.ParFlags.ParStats.Global &&
-       RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-      globalParStats.tot_resume_mess++;
-    }
-  }
-}
-
-/* 
-   The list of pending fetches must be a root-list for GC.
-   This routine is called from GC.c (same as marking GAs etc).
-*/
-void
-markPendingFetches(rtsBool major_gc) {
-
-  /* No need to traverse the list; this is done via the scavenge code
-     for a BLOCKED_FETCH closure, which evacuates the link field */
-
-  if (PendingFetches != END_BF_QUEUE ) {
-    IF_PAR_DEBUG(tables,
-                fprintf(stderr, "@@@@ PendingFetches is root; evaced from %p to",
-                        PendingFetches));
-
-    PendingFetches = MarkRoot((StgClosure*)PendingFetches);
-
-    IF_PAR_DEBUG(verbose,
-                fprintf(stderr, " %p\n", PendingFetches));
-
-  } else {
-    IF_PAR_DEBUG(tables,
-                fprintf(stderr, "@@@@ PendingFetches is empty; no need to mark it\n"));
-  }
-}
-
-/*
- * processFree unpacks a FREE message and adds the weights to our GAs.
- */
-//@cindex processFree
-static void
-processFree(void)
-{
-  int nelem;
-  static StgWord *buffer;
-  int i;
-  globalAddr ga;
-
-  buffer = (StgWord *)gumPackBuffer;
-  unpackFree(&nelem, buffer);
-  IF_PAR_DEBUG(free,
-              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, "!!-- Processing free "); 
-                printGA(&ga);
-                fputc('\n', stderr);
-                );
-    (void) addWeight(&ga);
-  }
-}
-
-/*
- * processResume unpacks a RESUME message into the graph, filling in
- * the LA -> GA, and GA -> LA tables. Threads blocked on the original
- * FetchMe (now a blocking queue) are awakened, and the blocking queue
- * is converted into an indirection.  Finally it sends an ACK in response
- * which contains any newly allocated GAs.
- */
-
-//@cindex processResume
-static void
-processResume(GlobalTaskId sender)
-{
-  int nelem;
-  nat nGAs;
-  static rtsPackBuffer *packBuffer;
-  StgClosure *newGraph, *old;
-  globalAddr lga;
-  globalAddr *gagamap;
-  
-  packBuffer = (rtsPackBuffer *)gumPackBuffer;
-  unpackResume(&lga, &nelem, packBuffer);
-
-  IF_PAR_DEBUG(fetch,
-              fprintf(stderr, "[]__ Rcvd Resume for "); 
-              printGA(&lga);
-              fputc('\n', stderr));
-  IF_PAR_DEBUG(packet,
-              PrintPacket((rtsPackBuffer *)packBuffer));
-  
-  /* 
-   * We always unpack the incoming graph, even if we've received the
-   * requested node in some other data packet (and already awakened
-   * the blocking queue).
-  if (SAVE_Hp + packBuffer[0] >= SAVE_HpLim) {
-    ReallyPerformThreadGC(packBuffer[0], rtsFalse);
-    SAVE_Hp -= packBuffer[0];
-  }
-   */
-
-  // ToDo: Check for GC here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  /* Do this *after* GC; we don't want to release the object early! */
-
-  if (lga.weight > 0)
-    (void) addWeight(&lga);
-
-  old = GALAlookup(&lga);
-
-  /* ToDo:  The closure that requested this graph must be one of these two?*/
-  ASSERT(get_itbl(old)->type == FETCH_ME_BQ || 
-        get_itbl(old)->type == RBH);
-
-  if (RtsFlags.ParFlags.ParStats.Full) {
-    StgBlockingQueueElement *bqe, *last_bqe;
-
-    IF_PAR_DEBUG(fetch,
-                belch("[]-- Resume is REPLY to closure %lx", old));
-
-    /* Write REPLY events to the log file, indicating that the remote
-       data has arrived 
-       NB: we emit a REPLY only for the *last* elem in the queue; this is
-           the one that triggered the fetch message; all other entries
-          have just added themselves to the queue, waiting for the data 
-          they know that has been requested (see entry code for FETCH_ME_BQ)
-    */
-    if ((get_itbl(old)->type == FETCH_ME_BQ ||
-        get_itbl(old)->type == RBH)) {
-      for (bqe = ((StgFetchMeBlockingQueue *)old)->blocking_queue,
-          last_bqe = END_BQ_QUEUE;
-            get_itbl(bqe)->type==TSO || 
-            get_itbl(bqe)->type==BLOCKED_FETCH;
-          last_bqe = bqe, bqe = bqe->link) { /* nothing */ }
-
-      ASSERT(last_bqe==END_BQ_QUEUE || 
-            get_itbl((StgClosure *)last_bqe)->type == TSO);
-
-      /* last_bqe now points to the TSO that triggered the FETCH */ 
-      if (get_itbl((StgClosure *)last_bqe)->type == TSO)
-       DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(sender), 
-                        GR_REPLY, ((StgTSO *)last_bqe), ((StgTSO *)last_bqe)->block_info.closure,
-                        0, spark_queue_len(&(MainRegTable.rSparks)));
-    }
-  }
-
-  newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
-  ASSERT(newGraph != NULL);
-
-  /* 
-   * Sometimes, unpacking will common up the resumee with the
-   * incoming graph, but if it hasn't, we'd better do so now.
-   */
-   
-  if (get_itbl(old)->type == FETCH_ME_BQ)
-    CommonUp(old, newGraph);
-
-  IF_PAR_DEBUG(fetch,
-              belch("[]-- Ready to resume unpacked graph at %p (%s)",
-                    newGraph, info_type(newGraph)));
-
-  IF_PAR_DEBUG(tables,
-              DebugPrintGAGAMap(gagamap, nGAs));
-  
-  sendAck(sender, nGAs, gagamap);
-}
-
-/*
- * processSchedule unpacks a SCHEDULE message into the graph, filling
- * in the LA -> GA, and GA -> LA tables. The root of the graph is added to
- * the local spark queue.  Finally it sends an ACK in response
- * which contains any newly allocated GAs.
- */
-//@cindex processSchedule
-static void
-processSchedule(GlobalTaskId sender)
-{
-  nat nelem, nGAs;
-  rtsBool success;
-  static rtsPackBuffer *packBuffer;
-  StgClosure *newGraph;
-  globalAddr *gagamap;
-  
-  packBuffer = gumPackBuffer;          /* HWL */
-  unpackSchedule(&nelem, packBuffer);
-
-  IF_PAR_DEBUG(schedule,
-              belch("--__ Rcvd Schedule (%d elems)", nelem));
-  IF_PAR_DEBUG(packet,
-              PrintPacket(packBuffer));
-
-  /*
-   * For now, the graph is a closure to be sparked as an advisory
-   * spark, but in future it may be a complete spark with
-   * required/advisory status, priority etc.
-   */
-
-  /*
-  space_required = packBuffer[0];
-  if (SAVE_Hp + space_required >= SAVE_HpLim) {
-    ReallyPerformThreadGC(space_required, rtsFalse);
-    SAVE_Hp -= space_required;
-  }
-  */
-  // ToDo: check whether GC is necessary !!!!!!!!!!!!!!!!!!!!!
-  newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
-  ASSERT(newGraph != NULL);
-  success = add_to_spark_queue(newGraph, &(MainRegTable.rSparks));
-
-  if (RtsFlags.ParFlags.ParStats.Full && 
-      RtsFlags.ParFlags.ParStats.Sparks && 
-      success) 
-    DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC, 
-                    GR_STOLEN, ((StgTSO *)NULL), newGraph, 
-                    0, 0 /* spark_queue_len(ADVISORY_POOL) */);
-
-  IF_PAR_DEBUG(schedule,
-              if (success)
-                belch("--^^  added spark to unpacked graph %p (%s); %d sparks available on [%x] (%s)", 
-                    newGraph, info_type(newGraph), spark_queue_len(&(MainRegTable.rSparks)), mytid);
-              else
-                 belch("--^^  received non-sparkable closure %p (%s); nothing added to spark pool; %d sparks available on [%x]", 
-                    newGraph, info_type(newGraph), spark_queue_len(&(MainRegTable.rSparks)), mytid));
-  IF_PAR_DEBUG(packet,
-              belch("*<    Unpacked graph with root at %p (%s):", 
-                    newGraph, info_type(newGraph));
-              PrintGraph(newGraph, 0));
-
-  IF_PAR_DEBUG(tables,
-              DebugPrintGAGAMap(gagamap, nGAs));
-
-  sendAck(sender, nGAs, gagamap);
-
-  //fishing = rtsFalse;
-  ASSERT(outstandingFishes>0);
-  outstandingFishes--;
-}
-
-/*
- * processAck unpacks an ACK, and uses the GAGA map to convert RBH's
- * (which represent shared thunks that have been shipped) into fetch-mes
- * to remote GAs.
- */
-//@cindex processAck
-static void
-processAck(void)
-{
-  nat nGAs;
-  globalAddr *gaga;
-  globalAddr gagamap[256]; // ToDo: elim magic constant!!   MAX_GAS * 2];??
-
-  unpackAck(&nGAs, gagamap);
-
-  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
-   * the weight from the oldGA.
-   */
-  for (gaga = gagamap; gaga < gagamap + nGAs * 2; gaga += 2) {
-    StgClosure *old_closure = GALAlookup(gaga);
-    StgClosure *new_closure = GALAlookup(gaga + 1);
-
-    ASSERT(old_closure != NULL);
-    if (new_closure == NULL) {
-      /* We don't have this closure, so we make a fetchme for it */
-      globalAddr *ga = setRemoteGA(old_closure, gaga + 1, rtsTrue);
-      
-      /* convertToFetchMe should be done unconditionally here.
-        Currently, we assign GAs to CONSTRs, too, (a bit of a hack),
-        so we have to check whether it is an RBH before converting
-
-        ASSERT(get_itbl(old_closure)==RBH);
-      */
-      if (get_itbl(old_closure)->type==RBH)
-       convertToFetchMe((StgRBH *)old_closure, ga);
-    } else {
-      /* 
-       * Oops...we've got this one already; update the RBH to
-       * point to the object we already know about, whatever it
-       * happens to be.
-       */
-      CommonUp(old_closure, new_closure);
-      
-      /* 
-       * Increase the weight of the object by the amount just
-       * received in the second part of the ACK pair.
-       */
-      (void) addWeight(gaga + 1);
-    }
-    (void) addWeight(gaga);
-  }
-
-  /* check the sanity of the LAGA and GALA tables after mincing them */
-  IF_DEBUG(sanity, checkLAGAtable(rtsFalse));
-}
-
-#ifdef DIST
-
-void
-bounceReval(void) {  
-  barf("Task %x: TODO: should send NACK in response to REVAL",mytid);    
-}
-
-static void
-processReval(GlobalTaskId sender) //similar to schedule...
-{ nat nelem, space_required, nGAs;
-  static rtsPackBuffer *packBuffer;
-  StgClosure *newGraph;
-  globalAddr *gagamap;
-  StgTSO*     tso;
-  globalAddr *ga;
-  
-  packBuffer = gumPackBuffer;          /* HWL */
-  unpackSchedule(&nelem, packBuffer); /* okay, since the structure is the same */
-
-  IF_PAR_DEBUG(packet,
-              belch("@;~) [%x] Rcvd Reval (%d elems)", mytid, nelem);
-              PrintPacket(packBuffer));
-
-  /*
-  space_required = packBuffer[0];
-  if (SAVE_Hp + space_required >= SAVE_HpLim) {
-    ReallyPerformThreadGC(space_required, rtsFalse);
-    SAVE_Hp -= space_required;
-  }
-  */
-  
-  // ToDo: check whether GC is necessary !!!!!!!!!!!!!!!!!!!!!
-  newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
-  ASSERT(newGraph != NULL);
-  
-  IF_PAR_DEBUG(packet,
-              belch("@;~)  Unpacked graph with root at %p (%s):", 
-                    newGraph, info_type(newGraph));
-              PrintGraph(newGraph, 0));
-
-  IF_PAR_DEBUG(tables,
-              DebugPrintGAGAMap(gagamap, nGAs));
-
-  IF_PAR_DEBUG(tables, 
-    printLAGAtable();   
-    DebugPrintGAGAMap(gagamap, nGAs));   
-
-  //We don't send an Ack to the head!!!!
-  ASSERT(nGAs>0);  
-  sendAck(sender, nGAs-1, gagamap+2);
-  
-  IF_PAR_DEBUG(verbose,
-              belch("@;~)  About to create Reval thread on behalf of %x", 
-                    sender));
-  
-  tso=createGenThread(RtsFlags.GcFlags.initialStkSize,newGraph);
-  tso->priority=RevalPriority;
-  tso->revalSlot=gagamap->payload.gc.slot;//record who sent the reval
-  tso->revalTid =gagamap->payload.gc.gtid;
-  scheduleThread(tso);
-  context_switch = 1; // switch at the earliest opportunity
-} 
-#endif
-
-
-//@node GUM Message Processor, Miscellaneous Functions, Message-Processing Functions, High Level Communications Routines
-//@subsection GUM Message Processor
-
-/*
- * GUM Message Processor
-
- * processMessages processes any messages that have arrived, calling
- * appropriate routines depending on the message tag
- * (opcode). N.B. Unless profiling it assumes that there {\em ARE} messages
- * present and performs a blocking receive! During profiling it
- * busy-waits in order to record idle time.
- */
-
-//@cindex processMessages
-rtsBool
-processMessages(void)
-{
-  rtsPacket packet;
-  OpCode opcode;
-  GlobalTaskId task;
-  rtsBool receivedFinish = rtsFalse;
-
-  do {
-    packet = GetPacket();  /* Get next message; block until one available */
-    getOpcodeAndSender(packet, &opcode, &task);
-
-    if (task==SysManTask) { 
-      switch (opcode) { 
-      case PP_PETIDS:
-       processPEtids();
-       break;
-         
-      case PP_FINISH:
-       IF_PAR_DEBUG(verbose,
-                    belch("==== received FINISH [%p]", mytid));
-       /* this boolean value is returned and propagated to the main 
-          scheduling loop, thus shutting-down this PE */
-       receivedFinish = rtsTrue;
-       break;  
-         
-      default:  
-       barf("Task %x: received unknown opcode %x from SysMan",mytid, opcode);
-      }
-    } else if (taskIDtoPE(task)==0) { 
-      /* When a new PE joins then potentially FISH & REVAL message may
-        reach PES before they are notified of the new PEs existance.  The
-        only solution is to bounce/fail these messages back to the sender.
-        But we will worry about it once we start seeing these race
-        conditions!  */
-      switch (opcode) { 
-      case PP_FISH:
-       bounceFish();
-       break;
-#ifdef DIST      
-      case PP_REVAL:
-       bounceReval();
-       break;    
-#endif          
-      case PP_PETIDS:
-       belch("Task %x: Ignoring PVM session opened by another SysMan %x",mytid,task);
-       break;
-        
-      case PP_FINISH:   
-       break;
-       
-      default:  
-       belch("Task %x: Ignoring opcode %x from unknown PE %x",mytid, opcode, task);
-      }
-    } else
-      switch (opcode) {
-      case PP_FETCH:
-       processFetch();
-       // Global statistics: count no. of fetches
-       if (RtsFlags.ParFlags.ParStats.Global &&
-           RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-         globalParStats.rec_fetch_mess++;
-       }
-       break;
-
-      case PP_RESUME:
-       processResume(task);
-       // Global statistics: count no. of fetches
-       if (RtsFlags.ParFlags.ParStats.Global &&
-           RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-         globalParStats.rec_resume_mess++;
-       }
-       break;
-
-      case PP_ACK:
-       processAck();
-       break;
-
-      case PP_FISH:
-       processFish();
-       // Global statistics: count no. of fetches
-       if (RtsFlags.ParFlags.ParStats.Global &&
-           RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-         globalParStats.rec_fish_mess++;
-       }
-       break;
-
-      case PP_FREE:
-       processFree();
-       break;
-      
-      case PP_SCHEDULE:
-       processSchedule(task);
-       // Global statistics: count no. of fetches
-       if (RtsFlags.ParFlags.ParStats.Global &&
-           RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-         globalParStats.rec_schedule_mess++;
-       }
-       break;
-      
-#ifdef DIST      
-      case PP_REVAL:
-       processReval(task);
-       // Global statistics: count no. of fetches
-       if (RtsFlags.ParFlags.ParStats.Global &&
-           RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-         globalParStats.rec_reval_mess++;
-       }
-       break;
-#endif
-      
-      default:
-       /* Anything we're not prepared to deal with. */
-       barf("Task %x: Unexpected opcode %x from %x",
-            mytid, opcode, task);
-      } /* switch */
-
-  } while (PacketsWaiting());  /* While there are messages: process them */
-  return receivedFinish;
-}                              /* processMessages */
-
-//@node Miscellaneous Functions, Index, GUM Message Processor, High Level Communications Routines
-//@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 = &stg_BLACKHOLE_BQ_info;
-    SET_INFO(bh, &stg_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(bq,
-              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=NULL;
-  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 queue (which is tso). 
-      */
-      ASSERT(looks_like_ga(&theGlobalFromGA));
-      // ASSERT(tso->link!=END_TSO_QUEUE && tso->link!=NULL);
-      remote_ga = &theGlobalFromGA; //tso->link;
-      tso->link = (StgTSO*)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 */
-       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, 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 == 1U << (BITS_IN(unsigned) - 1));
-      
-      sendFetch(remote_ga, &fmbq_ga, 0/*load*/);
-
-      // Global statistics: count no. of fetches
-      if (RtsFlags.ParFlags.ParStats.Global &&
-         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-       globalParStats.tot_fetch_mess++;
-      }
-
-      IF_DEBUG(sanity,
-              theGlobalFromGA.payload.gc.gtid = (GlobalTaskId)0);
-      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 */
-       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, 0);
-      }
-      break;
-
-    case BlockedOnMVar:
-    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==MVAR ||
-            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 */
-       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, 0);
-      }
-      break;
-
-    case BlockedOnDelay:
-      /* Whats sort of stats shall we collect for an explicit threadDelay? */
-      IF_PAR_DEBUG(verbose,
-              belch("##++ blockThread: TSO %d blocked on ThreadDelay",
-                    tso->id));
-      break;
-
-    /* Check that the following is impossible to happen, indeed
-    case BlockedOnException:
-    case BlockedOnRead:
-    case BlockedOnWrite:
-    */
-    default:
-      barf("blockThread: impossible why_blocked code %d for TSO %d",
-          tso->why_blocked, tso->id);
-  }
-
-  IF_PAR_DEBUG(verbose,
-              belch("##++ blockThread: TSO %d blocked on closure %p (%s); %s",
-                    tso->id, tso->block_info.closure, info_type(tso->block_info.closure),
-                    (tso->why_blocked==BlockedOnGA) ? "Sent FETCH for GA" : ""));
-  
-  IF_PAR_DEBUG(bq,
-              print_bq(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
- *   - it's different for each PE
- *   - we never send a fish to ourselves
- */
-extern long lrand48 (void);
-
-//@cindex choosePE
-GlobalTaskId
-choosePE(void)
-{
-  long temp;
-
-  temp = lrand48() % nPEs;
-  if (allPEs[temp] == mytid) { /* Never send a FISH to yourself */
-    temp = (temp + 1) % nPEs;
-  }
-  return allPEs[temp];
-}
-
-/* 
- * allocate a BLOCKED_FETCH closure and fill it with the relevant fields
- * of the ga argument; called from processFetch when the local closure is
- * under evaluation
- */
-//@cindex createBlockedFetch
-StgClosure *
-createBlockedFetch (globalAddr ga, globalAddr rga)
-{
-  StgBlockedFetch *bf;
-  StgClosure *closure;
-
-  closure = GALAlookup(&ga);
-  if ((bf = (StgBlockedFetch *)allocate(_HS + sizeofW(StgBlockedFetch))) == NULL) {
-    barf("createBlockedFetch: out of heap while allocating heap for a BlocekdFetch; ToDo: call GC here");
-    GarbageCollect(GetRoots, rtsFalse); 
-    closure = GALAlookup(&ga);
-    bf = (StgBlockedFetch *)allocate(_HS + sizeofW(StgBlockedFetch));
-    // ToDo: check whether really guaranteed to succeed 2nd time around
-  }
-
-  ASSERT(bf != (StgBlockedFetch *)NULL);
-  SET_INFO((StgClosure *)bf, &stg_BLOCKED_FETCH_info);
-  // ToDo: check whether other header info is needed
-  bf->node = closure;
-  bf->ga.payload.gc.gtid = rga.payload.gc.gtid;
-  bf->ga.payload.gc.slot = rga.payload.gc.slot;
-  bf->ga.weight = rga.weight;
-  // bf->link = NULL;  debugging
-
-  IF_PAR_DEBUG(schedule,
-              fprintf(stderr, "%%%%// created BF: bf=%p (%s) of closure , GA: ",
-                      bf, info_type((StgClosure*)bf));
-              printGA(&(bf->ga));
-              fputc('\n',stderr));
-  return (StgClosure *)bf;
-}
-
-/*
- * waitForTermination enters a loop ignoring spurious messages while
- * waiting for the termination sequence to be completed.  
- */
-//@cindex waitForTermination
-void
-waitForTermination(void)
-{
-  do {
-    rtsPacket p = GetPacket();
-    processUnexpectedMessage(p);
-  } while (rtsTrue);
-}
-
-#ifdef DEBUG
-//@cindex DebugPrintGAGAMap
-void
-DebugPrintGAGAMap(globalAddr *gagamap, int nGAs)
-{
-  nat i;
-  
-  for (i = 0; i < nGAs; ++i, gagamap += 2)
-    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 < (nat)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 nat      *freeMsgIndex  = NULL;
-
-//@cindex prepareFreeMsgBuffers
-void
-prepareFreeMsgBuffers(void)
-{
-  nat i;
-  
-  /* Allocate the freeMsg buffers just once and then hang onto them. */
-  if (freeMsgIndex == NULL) {
-    freeMsgIndex = (nat *) stgMallocBytes(nPEs * sizeof(nat), 
-                                         "prepareFreeMsgBuffers (Index)");
-    freeMsgBuffer = (StgWord **) stgMallocBytes(nPEs * sizeof(long *), 
-                                         "prepareFreeMsgBuffers (Buffer)");
-    
-    for(i = 0; i < nPEs; i++) 
-      if (i != (thisPE-1)) 
-       freeMsgBuffer[i] = (StgPtr) stgMallocWords(RtsFlags.ParFlags.packBufferSize,
-                                              "prepareFreeMsgBuffers (Buffer #i)");
-      else
-       freeMsgBuffer[i] = 0;
-  }
-  
-  /* Initialize the freeMsg buffer pointers to point to the start of their
-     buffers */
-  for (i = 0; i < nPEs; i++)
-    freeMsgIndex[i] = 0;
-}
-
-//@cindex freeRemoteGA
-void
-freeRemoteGA(int pe, globalAddr *ga)
-{
-  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)"));   
-
-    sendFree(ga->payload.gc.gtid, i, freeMsgBuffer[pe]);
-    i = 0;
-  }
-  freeMsgBuffer[pe][i++] = (StgWord) ga->weight;
-  freeMsgBuffer[pe][i++] = (StgWord) ga->payload.gc.slot;
-  freeMsgIndex[pe] = i;
-
-  IF_DEBUG(sanity,
-          ga->weight = 0xdead0add;
-          ga->payload.gc.gtid = 0xbbbbbbbb;
-          ga->payload.gc.slot = 0xbbbbbbbb;);
-}
-
-//@cindex sendFreeMessages
-void
-sendFreeMessages(void)
-{
-  nat i;
-  
-  for (i = 0; i < nPEs; i++) 
-    if (freeMsgIndex[i] > 0)
-      sendFree(allPEs[i], freeMsgIndex[i], freeMsgBuffer[i]);
-}
-
-/* synchronises with the other PEs. Receives and records in a global
- * variable the task-id of SysMan. If this is the main thread (discovered
- * in main.lc), identifies itself to SysMan. Finally it receives
- * from SysMan an array of the Global Task Ids of each PE, which is
- * returned as the value of the function.
- */
-
-#if defined(PAR_TICKY)
-/* Has to see freeMsgIndex, so must be defined here not in ParTicky.c */
-//@cindex stats_CntFreeGA
-void
-stats_CntFreeGA (void) {  // stats only
-
-  // Global statistics: residency of thread and spark pool
-  if (RtsFlags.ParFlags.ParStats.Global &&
-      RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-    nat i, s;
-  
-    globalParStats.cnt_free_GA++;
-    for (i = 0, s = 0; i < nPEs; i++) 
-      s += globalParStats.tot_free_GA += freeMsgIndex[i]/2;
-
-    if ( s > globalParStats.res_free_GA )
-      globalParStats.res_free_GA = s;
-  }
-}
-#endif /* PAR_TICKY */
-
-#endif /* PAR -- whole file */
-
-//@node Index,  , Miscellaneous Functions, High Level Communications Routines
-//@subsection Index
-
-//@index
-//* ACK::  @cindex\s-+ACK
-//* DebugPrintGAGAMap::  @cindex\s-+DebugPrintGAGAMap
-//* FETCH::  @cindex\s-+FETCH
-//* FISH::  @cindex\s-+FISH
-//* FREE::  @cindex\s-+FREE
-//* RESUME::  @cindex\s-+RESUME
-//* SCHEDULE::  @cindex\s-+SCHEDULE
-//* blockFetch::  @cindex\s-+blockFetch
-//* choosePE::  @cindex\s-+choosePE
-//* freeMsgBuffer::  @cindex\s-+freeMsgBuffer
-//* freeMsgIndex::  @cindex\s-+freeMsgIndex
-//* freeRemoteGA::  @cindex\s-+freeRemoteGA
-//* gumPackBuffer::  @cindex\s-+gumPackBuffer
-//* initMoreBuffers::  @cindex\s-+initMoreBuffers
-//* prepareFreeMsgBuffers::  @cindex\s-+prepareFreeMsgBuffers
-//* processAck::  @cindex\s-+processAck
-//* processFetch::  @cindex\s-+processFetch
-//* processFetches::  @cindex\s-+processFetches
-//* processFish::  @cindex\s-+processFish
-//* processFree::  @cindex\s-+processFree
-//* processMessages::  @cindex\s-+processMessages
-//* processResume::  @cindex\s-+processResume
-//* processSchedule::  @cindex\s-+processSchedule
-//* sendAck::  @cindex\s-+sendAck
-//* sendFetch::  @cindex\s-+sendFetch
-//* sendFish::  @cindex\s-+sendFish
-//* sendFree::  @cindex\s-+sendFree
-//* sendFreeMessages::  @cindex\s-+sendFreeMessages
-//* sendResume::  @cindex\s-+sendResume
-//* sendSchedule::  @cindex\s-+sendSchedule
-//* unpackAck::  @cindex\s-+unpackAck
-//* unpackFetch::  @cindex\s-+unpackFetch
-//* unpackFish::  @cindex\s-+unpackFish
-//* unpackFree::  @cindex\s-+unpackFree
-//* unpackResume::  @cindex\s-+unpackResume
-//* unpackSchedule::  @cindex\s-+unpackSchedule
-//* waitForTermination::  @cindex\s-+waitForTermination
-//@end index
diff --git a/rts/parallel/LLC.h b/rts/parallel/LLC.h
deleted file mode 100644 (file)
index 536e431..0000000
+++ /dev/null
@@ -1,130 +0,0 @@
-/* --------------------------------------------------------------------------
-   Time-stamp: <Sun Mar 18 2001 21:23:50 Stardate: [-30]6349.45 hwloidl>
-
-   Low Level Communications Header (LLC.h)
-
-   Contains the definitions used by the Low-level Communications
-   module of the GUM Haskell runtime environment.
-   Based on the Graph for PVM implementation.
-
-   Phil Trinder, Glasgow University, 13th Dec 1994
-   Adapted for the 4.xx RTS
-   H-W. Loidl, Heriot-Watt, November 1999
-   ----------------------------------------------------------------------- */
-
-#ifndef __LLC_H
-#define __LLC_H
-
-#ifdef PAR
-
-//@node Low Level Communications Header, , ,
-//@section Low Level Communications Header
-
-//@menu
-//* Includes::                 
-//* Macros and Constants::     
-//* PVM macros::               
-//* Externs::                  
-//@end menu
-
-//@node Includes, Macros and Constants, Low Level Communications Header, Low Level Communications Header
-//@subsection Includes
-
-#include "Rts.h"
-#include "Parallel.h"
-
-#include "PEOpCodes.h"
-#include "pvm3.h"
-
-//@node Macros and Constants, PVM macros, Includes, Low Level Communications Header
-//@subsection Macros and Constants
-
-#define        ANY_TASK        (-1)    /* receive messages from any task */
-#define ANY_GLOBAL_TASK        ANY_TASK
-#define ANY_OPCODE     (-1)    /* receive any opcode */
-#define        ALL_GROUP       (-1)    /* wait for barrier from every group member */
-
-#define        PEGROUP         "PE"
-
-#define        MGRGROUP        "MGR"
-#define        SYSGROUP        "SYS"
-
-
-#define        PETASK          "PE"
-
-//@node PVM macros, Externs, Macros and Constants, Low Level Communications Header
-//@subsection PVM macros
-
-#define        sync(gp,op)             do { \
-                                  broadcast(gp,op); \
-                                  pvm_barrier(gp,ALL_GROUP); \
-                                } while(0)
-
-#define broadcast(gp,op)       do { \
-                                  pvm_initsend(PvmDataDefault); \
-                                  pvm_bcast(gp,op); \
-                                } while(0)
-
-#define checkComms(c,s)                do { \
-                                  if ((c)<0) { \
-                                    pvm_perror(s); \
-                                    stg_exit(EXIT_FAILURE); \
-                                }} while(0)
-
-#define _my_gtid               pvm_mytid()
-#define GetPacket()             pvm_recv(ANY_TASK,ANY_OPCODE)
-#define PacketsWaiting()       (pvm_probe(ANY_TASK,ANY_OPCODE) != 0)
-
-#define SPARK_THREAD_DESCRIPTOR                1
-#define GLOBAL_THREAD_DESCRIPTOR       2
-
-#define _extract_jump_field(v) (v)
-
-#define MAX_DATA_WORDS_IN_PACKET       1024
-
-/* basic PVM packing */
-#define PutArg1(a)             pvm_pklong((long *)&(a),1,1)
-#define PutArg2(a)             pvm_pklong((long *)&(a),1,1)
-#define PutArgN(n,a)           pvm_pklong((long *)&(a),1,1)
-#define PutArgs(b,n)           pvm_pklong((long *)b,n,1)
-
-#define PutLit(l)              { int a = l; PutArgN(?,a); }
-
-/* basic PVM unpacking */
-#define GetArg1(a)             pvm_upklong((long *)&(a),1,1)
-#define GetArg2(a)             pvm_upklong((long *)&(a),1,1)
-#define GetArgN(n,a)           pvm_upklong((long *)&(a),1,1)
-#define GetArgs(b,n)           pvm_upklong((long *)b,n,1)
-
-//@node Externs,  , PVM macros, Low Level Communications Header
-//@subsection Externs
-
-/* basic message passing routines */
-extern void sendOp   (OpCode,GlobalTaskId),
-            sendOp1  (OpCode,GlobalTaskId,StgWord),
-            sendOp2  (OpCode,GlobalTaskId,StgWord,StgWord),
-           sendOpV  (OpCode,GlobalTaskId,int,...), 
-            sendOpN  (OpCode,GlobalTaskId,int,StgPtr),
-            sendOpNV (OpCode,GlobalTaskId,int,StgPtr,int,...);
-
-extern void broadcastOpN(OpCode op, char *group, int n, StgPtr args);
-
-/* extracting data out of a packet */
-OpCode        getOpcode (rtsPacket p);
-void          getOpcodeAndSender (rtsPacket p, OpCode *popcode, 
-                                 GlobalTaskId *psender_id);
-GlobalTaskId  senderTask (rtsPacket p);
-rtsPacket     waitForPEOp(OpCode op, GlobalTaskId who, void(*processUnexpected)(rtsPacket) );
-
-/* Init and shutdown routines */
-void          startUpPE (void);
-void          shutDownPE(void);
-int           getExitCode(int nbytes, GlobalTaskId *sender_idp);
-
-/* aux functions */
-char  *getOpName (unsigned op);  // returns string of opcode
-void   processUnexpectedMessage (rtsPacket);
-//void   NullException(void);
-
-#endif /*PAR */
-#endif /*defined __LLC_H */
diff --git a/rts/parallel/LLComms.c b/rts/parallel/LLComms.c
deleted file mode 100644 (file)
index baa6ddd..0000000
+++ /dev/null
@@ -1,489 +0,0 @@
-/* ----------------------------------------------------------------------------
- * Time-stamp: <Mon Mar 19 2001 22:10:38 Stardate: [-30]6354.62 hwloidl>
- *
- * GUM Low-Level Inter-Task Communication
- *
- * This module defines PVM Routines for PE-PE  communication.
- *
- * P. Trinder, December 5th. 1994.
- * P. Trinder, July 1998
- * H-W. Loidl, November 1999 -
- --------------------------------------------------------------------------- */
-
-#ifdef PAR /* whole file */
-
-//@node GUM Low-Level Inter-Task Communication, , ,
-//@section GUM Low-Level Inter-Task Communication
-
-/*
- *This module defines the routines which communicate between PEs.  The
- *code is based on Kevin Hammond's GRIP RTS. (OpCodes.h defines
- *PEOp1 etc. in terms of sendOp1 etc.).  
- *
- *Routine      &       Arguments 
- *             &               
- *sendOp       &       0                       \\
- *sendOp1      &       1                       \\
- *sendOp2      &       2                       \\
- *sendOpN      &       vector                  \\
- *sendOpV      &       variable                \\
- *sendOpNV     &       variable+ vector        \\
- *
- *First the standard include files.
- */
-
-//@menu
-//* Macros etc::               
-//* Includes::                 
-//* Auxiliary functions::      
-//* Index::                    
-//@end menu
-
-//@node Macros etc, Includes, GUM Low-Level Inter-Task Communication, GUM Low-Level Inter-Task Communication
-//@subsection Macros etc
-
-/* Evidently not Posix */
-/* #include "PosixSource.h" */
-
-#define UNUSED           /* nothing */
-
-//@node Includes, Auxiliary functions, Macros etc, GUM Low-Level Inter-Task Communication
-//@subsection Includes
-
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "Parallel.h"
-#include "ParallelRts.h"
-#if defined(DEBUG)
-# include "ParallelDebug.h"
-#endif
-#include "LLC.h"
-
-#ifdef __STDC__
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#endif
-
-/* Cannot use std macro when compiling for SysMan */
-/* debugging enabled */
-// #define IF_PAR_DEBUG(c,s)  { s; }
-/* debugging disabled */
-#define IF_PAR_DEBUG(c,s)  /* nothing */
-
-//@node Auxiliary functions, Index, Includes, GUM Low-Level Inter-Task Communication
-//@subsection Auxiliary functions
-
-/*
- * heapChkCounter tracks the number of heap checks since the last probe.
- * Not currently used! We check for messages when a thread is resheduled.
- */
-int heapChkCounter = 0;
-
-/*
- * Then some miscellaneous functions. 
- * getOpName returns the character-string name of any OpCode.
- */
-
-char *UserPEOpNames[] = { PEOP_NAMES };
-
-//@cindex getOpName
-char *
-getOpName(nat op)
-{
-    if (op >= MIN_PEOPS && op <= MAX_PEOPS)
-       return (UserPEOpNames[op - MIN_PEOPS]);
-    else
-       return ("Unknown PE OpCode");
-}
-
-/*
- * traceSendOp handles the tracing of messages. 
- */
-
-//@cindex traceSendOp
-static void
-traceSendOp(OpCode op, GlobalTaskId dest UNUSED,
-            unsigned int data1 UNUSED, unsigned int data2 UNUSED)
-{
-    char *OpName;
-
-    OpName = getOpName(op);
-    IF_PAR_DEBUG(trace,
-                fprintf(stderr," %s [%x,%x] sent from %x to %x", 
-                      OpName, data1, data2, mytid, dest));
-}
-
-/*
- * sendOp sends a 0-argument message with OpCode {\em op} to
- * the global task {\em task}.
- */
-
-//@cindex sendOp
-void
-sendOp(OpCode op, GlobalTaskId task)
-{
-    traceSendOp(op, task,0,0);
-
-    pvm_initsend(PvmDataRaw);
-    pvm_send(task, op);
-}
-
-/*
- * sendOp1 sends a 1-argument message with OpCode {\em op}
- * to the global task {\em task}.
- */
-
-//@cindex sendOp1
-void
-sendOp1(OpCode op, GlobalTaskId task, StgWord arg1)
-{
-    traceSendOp(op, task, arg1,0);
-
-    pvm_initsend(PvmDataRaw);
-    PutArg1(arg1);
-    pvm_send(task, op);
-}
-
-
-/*
- * sendOp2 is used by the FP code only. 
- */
-
-//@cindex sendOp2
-void
-sendOp2(OpCode op, GlobalTaskId task, StgWord arg1, StgWord arg2)
-{
-    traceSendOp(op, task, arg1, arg2);
-
-    pvm_initsend(PvmDataRaw);
-    PutArg1(arg1);
-    PutArg2(arg2);
-    pvm_send(task, op);
-}
-
-/*
- *
- * sendOpV takes a variable number of arguments, as specified by {\em n}.  
- * For example,
- *
- *    sendOpV( PP_STATS, StatsTask, 3, start_time, stop_time, sparkcount);
- */
-
-//@cindex sendOpV
-void
-sendOpV(OpCode op, GlobalTaskId task, int n, ...)
-{
-    va_list ap;
-    int i;
-    StgWord arg;
-
-    va_start(ap, n);
-
-    traceSendOp(op, task, 0, 0);
-
-    pvm_initsend(PvmDataRaw);
-
-    for (i = 0; i < n; ++i) {
-       arg = va_arg(ap, StgWord);
-       PutArgN(i, arg);
-    }
-    va_end(ap);
-
-    pvm_send(task, op);
-}
-
-/*    
- *
- * sendOpNV takes a variable-size datablock, as specified by {\em
- * nelem} and a variable number of arguments, as specified by {\em
- * narg}. N.B. The datablock and the additional arguments are contiguous
- * and are copied over together.  For example,
- *
- *        sendOpNV(PP_RESUME, tsoga.pe, 6, nelem, data,
- *         (W_) ga.weight, (W_) ga.loc.gc.gtid, (W_) ga.loc.gc.slot, 
- *         (W_) tsoga.weight, (W_) tsoga.loc.gc.gtid, (W_) tsoga.loc.gc.slot);
- *
- * Important: The variable arguments must all be StgWords.
-
- sendOpNV(_, tid, m, n, data, x1, ..., xm):
-
-                         |   n elems
-     +------------------------------
-     | x1 | ... | xm | n | data ....
-     +------------------------------
- */
-
-//@cindex sendOpNV
-void
-sendOpNV(OpCode op, GlobalTaskId task, int nelem, 
-        StgWord *datablock, int narg, ...)
-{
-    va_list ap;
-    int i;
-    StgWord arg;
-
-    va_start(ap, narg);
-
-    traceSendOp(op, task, 0, 0);
-    IF_PAR_DEBUG(trace,
-                fprintf(stderr,"~~ sendOpNV: op = %x (%s), task = %x, narg = %d, nelem = %d",
-                      op, getOpName(op), task, narg, nelem));
-
-    pvm_initsend(PvmDataRaw);
-
-    for (i = 0; i < narg; ++i) {
-       arg = va_arg(ap, StgWord);
-        IF_PAR_DEBUG(trace,
-                    fprintf(stderr,"~~ sendOpNV: arg = %d\n",arg));
-       PutArgN(i, arg);
-    }
-    arg = (StgWord) nelem;
-    PutArgN(narg, arg);
-
-/*  for (i=0; i < nelem; ++i) fprintf(stderr, "%d ",datablock[i]); */
-/*  fprintf(stderr," in sendOpNV\n");*/
-
-    PutArgs(datablock, nelem);
-    va_end(ap);
-
-    pvm_send(task, op);
-}
-
-/*    
- * sendOpN take a variable size array argument, whose size is given by
- * {\em n}.  For example,
- *
- *    sendOpN( PP_STATS, StatsTask, 3, stats_array);
- */
-
-//@cindex sendOpN
-void
-sendOpN(OpCode op, GlobalTaskId task, int n, StgPtr args)
-{
-    long arg;
-
-    traceSendOp(op, task, 0, 0);
-
-    pvm_initsend(PvmDataRaw);
-    arg = (long) n;
-    PutArgN(0, arg);
-    PutArgs(args, n);
-    pvm_send(task, op);
-}
-
-/*    
- * broadcastOpN is as sendOpN but broadcasts to all members of a group.
- */
-
-void
-broadcastOpN(OpCode op, char *group, int n, StgPtr args)
-{
-  long arg;
-
-  //traceSendOp(op, task, 0, 0);
-  
-  pvm_initsend(PvmDataRaw);
-  arg = (long) n;
-  PutArgN(0, arg);
-  PutArgs(args, n);
-  pvm_bcast(group, op);
-}
-
-/*
-   waitForPEOp waits for a packet from global task who with the
-   OpCode op.  If ignore is true all other messages are simply ignored; 
-   otherwise they are handled by processUnexpected.
- */
-//@cindex waitForPEOp
-rtsPacket 
-waitForPEOp(OpCode op, GlobalTaskId who, void(*processUnexpected)(rtsPacket) )
-{
-  rtsPacket p;
-  int nbytes;
-  OpCode opCode;
-  GlobalTaskId sender_id;
-  rtsBool match;
-
-  IF_PAR_DEBUG(verbose,
-              fprintf(stderr,"~~ waitForPEOp: expecting op = %x (%s), who = [%x]\n", 
-                      op, getOpName(op), who)); 
-
-  do {
-    while((p = pvm_recv(ANY_TASK,ANY_OPCODE)) < 0)
-      pvm_perror("waitForPEOp: Waiting for PEOp");
-      
-    pvm_bufinfo( p, &nbytes, &opCode, &sender_id );
-    match = (op == ANY_OPCODE || op == opCode) && 
-            (who == ANY_TASK || who == sender_id);
-
-    if (match) {
-      IF_PAR_DEBUG(verbose,
-                  fprintf(stderr,
-                          "~~waitForPEOp: Qapla! received: OpCode = %#x (%s), sender_id = [%x]",
-                          opCode, getOpName(opCode), sender_id)); 
-
-      return(p);
-    }
-
-    /* Handle the unexpected OpCodes */
-    if (processUnexpected!=NULL) {
-      (*processUnexpected)(p);
-    } else {
-      IF_PAR_DEBUG(verbose,
-                  fprintf(stderr,
-                          "~~ waitForPEOp: ignoring OpCode = %#x (%s), sender_id = [%x]",
-                          opCode, getOpName(opCode), sender_id)); 
-    }
-
-  } while(rtsTrue);
-}
-
-/*
-  processUnexpected processes unexpected messages. If the message is a
-  FINISH it exits the prgram, and PVM gracefully
- */
-//@cindex processUnexpectedMessage
-void
-processUnexpectedMessage(rtsPacket packet) {
-    OpCode opCode = getOpcode(packet);
-
-    IF_PAR_DEBUG(verbose,
-                GlobalTaskId sender = senderTask(packet); 
-                fprintf(stderr,"~~ [%x] processUnexpected: Received %x (%s), sender %x\n",
-                      mytid, opCode, getOpName(opCode), sender)); 
-
-    switch (opCode) {
-    case PP_FINISH:
-        stg_exit(EXIT_SUCCESS);
-       break;
-
-      /* Anything we're not prepared to deal with.  Note that ALL OpCodes
-        are discarded during termination -- this helps prevent bizarre
-        race conditions.  */
-      default:
-       // if (!GlobalStopPending) 
-        {
-         GlobalTaskId errorTask;
-         OpCode opCode;
-
-         getOpcodeAndSender(packet, &opCode, &errorTask);
-         fprintf(stderr,"== Task %x: Unexpected OpCode %x from %x in processUnexpected",
-               mytid, opCode, errorTask );
-            
-         stg_exit(EXIT_FAILURE);
-       }
-    }
-}
-
-//@cindex getOpcode
-OpCode 
-getOpcode(rtsPacket p)
-{
-  int nbytes;
-  OpCode OpCode;
-  GlobalTaskId sender_id;
-  /* read PVM buffer */
-  pvm_bufinfo(p, &nbytes, &OpCode, &sender_id);
-  /* return tag of the buffer as opcode */
-  return(OpCode);
-}
-
-//@cindex getOpcodeAndSender
-void
-getOpcodeAndSender(rtsPacket p, OpCode *opCodep, GlobalTaskId *senderIdp)
-{
-  int nbytes;
-  /* read PVM buffer */
-  pvm_bufinfo(p, &nbytes, opCodep, senderIdp);
-}
-
-//@cindex senderTask
-GlobalTaskId
-senderTask(rtsPacket p)
-{
-  int nbytes;
-  OpCode opCode;
-  GlobalTaskId sender_id;
-  /* read PVM buffer */
-  pvm_bufinfo(p, &nbytes, &opCode, &sender_id);
-  return(sender_id);
-}
-
-/*
- * startUpPE does the low-level comms specific startup stuff for a
- * PE. It initialises the comms system, joins the appropriate groups
- * allocates the PE buffer
- */
-
-//@cindex startUpPE
-void
-startUpPE(void)
-{ 
-  mytid = _my_gtid;    /* Initialise PVM and get task id into global var.*/
-  
-  IF_PAR_DEBUG(verbose,
-              fprintf(stderr,"== [%x] PEStartup: Task id = [%x], No. PEs = %d \n", 
-                      mytid, mytid, nPEs));
-  checkComms(pvm_joingroup(PEGROUP), "PEStartup");
-  IF_PAR_DEBUG(verbose,
-              fprintf(stderr,"== [%x] PEStartup: Joined PEGROUP\n", mytid));
-}
-
-/*
- * PEShutdown does the low-level comms-specific shutdown stuff for a
- * single PE. It leaves the groups and then exits from pvm.
- */
-//@cindex shutDownPE
-void
-shutDownPE(void)
-{    
-  IF_PAR_DEBUG(verbose,
-              fprintf(stderr, "== [%x] PEshutdown\n", mytid));
-
-  checkComms(pvm_lvgroup(PEGROUP),"PEShutDown");
-  checkComms(pvm_exit(),"PEShutDown");
-}
-
-/* 
-   Extract the exit code out of a PP_FINISH packet (used in SysMan)
-*/
-int
-getExitCode(int nbytes, GlobalTaskId *sender_idp) {
-  int exitCode=0;
-
-  if (nbytes==4) {               // Notification from a task doing pvm_exit
-    GetArgs(sender_idp,1);       // Presumably this must be MainPE Id
-    exitCode = -1;
-  } else if (nbytes==8) {        // Doing a controlled shutdown
-    GetArgs(&exitCode,1);        // HACK: controlled shutdown == 2 values
-    GetArgs(&exitCode,1);
-  } else {
-    exitCode = -2;               // everything else
-  }
-  return exitCode;
-}
-
-#endif /* PAR -- whole file */
-
-//@node Index,  , Auxiliary functions, GUM Low-Level Inter-Task Communication
-//@subsection Index
-
-//@index
-//* getOpName::  @cindex\s-+getOpName
-//* traceSendOp::  @cindex\s-+traceSendOp
-//* sendOp::  @cindex\s-+sendOp
-//* sendOp1::  @cindex\s-+sendOp1
-//* sendOp2::  @cindex\s-+sendOp2
-//* sendOpV::  @cindex\s-+sendOpV
-//* sendOpNV::  @cindex\s-+sendOpNV
-//* sendOpN::  @cindex\s-+sendOpN
-//* waitForPEOp::  @cindex\s-+waitForPEOp
-//* processUnexpectedMessage::  @cindex\s-+processUnexpectedMessage
-//* getOpcode::  @cindex\s-+getOpcode
-//* getOpcodeAndSender::  @cindex\s-+getOpcodeAndSender
-//* senderTask::  @cindex\s-+senderTask
-//* startUpPE::  @cindex\s-+startUpPE
-//* shutDownPE::  @cindex\s-+shutDownPE
-//@end index
diff --git a/rts/parallel/PEOpCodes.h b/rts/parallel/PEOpCodes.h
deleted file mode 100644 (file)
index 2d18b43..0000000
+++ /dev/null
@@ -1,58 +0,0 @@
-#ifndef PEOPCODES_H
-#define PEOPCODES_H
-
-/************************************************************************
-*                         PEOpCodes.h                                   *
-*                                                                      *
-*      This file contains definitions for all the GUM PE Opcodes       *
-*       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
-
-/*Startup + Shutdown*/
-#define        PP_READY                0x50  /* sent PEs -> SysMan */
-#define        PP_NEWPE                0x51  /* sent via newHost notify -> SysMan */
-#define        PP_FINISH               0x52  /* sent PEs & via taskExit notfiy -> SysMan */
-#define        PP_PETIDS               0x53  /* sent sysman -> PEs */
-
-/* Stats stuff */
-#define        PP_STATS                0x54
-#define PP_STATS_ON            0x55
-#define PP_STATS_OFF           0x56
-
-//#define PP_FAIL              0x57 
-
-/*Garbage Collection*/
-#define PP_GC_INIT              0x58
-#define PP_FULL_SYSTEM          0x59
-#define PP_GC_POLL              0x5a
-
-/*GUM Messages*/
-#define PP_FETCH                0x5b
-#define PP_RESUME               0x5c
-#define PP_ACK                  0x5d
-#define PP_FISH                 0x5e
-#define PP_SCHEDULE             0x5f
-#define PP_FREE                        0x60
-#define PP_REVAL               0x61
-
-
-#define        MIN_PEOPS               0x50
-#define        MAX_PEOPS               0x61
-
-#define        PEOP_NAMES              "Ready", "NewPE", \
-                               "Finish", "PETIDS", \
-                                "Stats", "Stats_On", "Stats_Off", \
-                               "Fail", \
-                                "GCInit", "FullSystem", "GCPoll", \
-                                "Fetch","Resume","ACK","Fish","Schedule", \
-                               "Free","REval"
-
-#endif /* PEOPCODES_H */
diff --git a/rts/parallel/Pack.c b/rts/parallel/Pack.c
deleted file mode 100644 (file)
index 58fe7ed..0000000
+++ /dev/null
@@ -1,4293 +0,0 @@
-/* 
-   Time-stamp: <2009-12-02 12:26:34 simonmar>
-
-   Graph packing and unpacking code for sending it to another processor
-   and retrieving the original graph structure from the packet.
-   In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
-   Used in GUM and GrAnSim.
-
-   The GrAnSim version of the code defines routines for *simulating* the
-   packing of closures in the same way it is done in the parallel runtime
-   system. Basically GrAnSim only puts the addresses of the closures to be
-   transferred into a buffer. This buffer will then be associated with the
-   event of transferring the graph. When this event is scheduled, the
-   @UnpackGraph@ routine is called and the buffer can be discarded
-   afterwards.
-
-   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 */
-
-//@menu
-//* Includes::                 
-//* Prototypes::               
-//* Global variables::         
-//* ADT of Closure Queues::    
-//* Initialisation for packing::  
-//* Packing Functions::                
-//* Low level packing routines::  
-//* Unpacking routines::       
-//* Aux fcts for packing::     
-//* Printing Packet Contents:: 
-//* End of file::              
-//@end menu
-//*/
-
-//@node Includes, Prototypes, Graph packing, Graph packing
-//@subsection Includes
-
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "ClosureTypes.h"
-#include "Storage.h"
-#include "Hash.h"
-#include "Parallel.h"
-#include "GranSimRts.h"
-#include "ParallelRts.h"
-# if defined(DEBUG)
-# include "sm/Sanity.h"
-# include "Printer.h"
-# include "ParallelDebug.h"
-# endif
-#include "FetchMe.h"
-
-/* Which RTS flag should be used to get the size of the pack buffer ? */
-# if defined(PAR)
-#  define RTS_PACK_BUFFER_SIZE   RtsFlags.ParFlags.packBufferSize
-# else   /* GRAN */
-#  define RTS_PACK_BUFFER_SIZE   RtsFlags.GranFlags.packBufferSize
-# endif
-
-//@node Prototypes, Global variables, Includes, Graph packing
-//@subsection Prototypes
-/* 
-   Code declarations. 
-*/
-
-//@node ADT of closure queues, Init for packing, Prototypes, Prototypes
-//@subsubsection ADT of closure queues
-
-static inline void       InitClosureQueue(void);
-static inline rtsBool    QueueEmpty(void);
-static inline void       QueueClosure(StgClosure *closure);
-static inline StgClosure *DeQueueClosure(void);
-
-//@node Init for packing, Packing routines, ADT of closure queues, Prototypes
-//@subsubsection Init for packing
-
-static void     InitPacking(rtsBool unpack);
-# if defined(PAR)
-rtsBool         InitPackBuffer(void);
-# elif defined(GRAN)
-rtsPackBuffer  *InstantiatePackBuffer (void);
-static void     reallocPackBuffer (void);
-# endif
-
-//@node Packing routines, Low level packing fcts, Init for packing, Prototypes
-//@subsubsection Packing routines
-
-static void    PackClosure (StgClosure *closure);
-
-//@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
-//@subsubsection Low level packing fcts
-
-# if defined(GRAN)
-static  void    Pack (StgClosure *data);
-# else
-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
-
-//@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
-//@subsubsection Unpacking routines
-
-# if defined(PAR)
-void        InitPendingGABuffer(nat size); 
-void        CommonUp(StgClosure *src, StgClosure *dst);
-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);
-#endif
-
-//@node Aux fcts for packing,  , Unpacking routines, Prototypes
-//@subsubsection Aux fcts for packing
-
-# if defined(PAR)
-static void    DonePacking(void);
-static void    AmPacking(StgClosure *closure);
-static int     OffsetFor(StgClosure *closure);
-static rtsBool  NotYetPacking(int offset);
-static inline rtsBool  RoomToPack (nat size, nat ptrs);
-static inline rtsBool  isOffset(globalAddr *ga);
-static inline rtsBool  isFixed(globalAddr *ga);
-static inline rtsBool  isConstr(globalAddr *ga);
-static inline rtsBool  isUnglobalised(globalAddr *ga);
-# elif defined(GRAN)
-static void     DonePacking(void);
-static rtsBool  NotYetPacking(StgClosure *closure);
-# endif
-
-//@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
-//@subsection Global variables
-/*
-  Static data declarations
-*/
-
-static nat     pack_locn,           /* ptr to first free loc in pack buffer */
-               clq_size, clq_pos,
-               buf_id = 1;          /* identifier for buffer */
-static nat     unpacked_size;
-static rtsBool roomInBuffer;
-#if defined(PAR)
-static GlobalTaskId dest_gtid=0;    /* destination for message to send */
-#endif
-
-/* 
-   The pack buffer
-   To be pedantic: in GrAnSim we're packing *addresses* of closures,
-   not the closures themselves.
-*/
-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
-  set in @PackNearbyGraph@ and tested in @PackClosure@.  
-*/
-
-static nat          packed_thunks = 0;
-static StgClosure  *graph_root;
-
-# if defined(PAR)
-/*
-  The offset hash table is used during packing to record the location in
-  the pack buffer of each closure which is packed.
-*/
-//@cindex offsetTable
-static HashTable *offsetTable;
-
-//@cindex PendingGABuffer
-static globalAddr *PendingGABuffer, *gaga;
-
-# endif /* PAR */
-
-
-//@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
-//@subsection ADT of Closure Queues
-
-//@menu
-//* Closure Queues::           
-//* Init routines::            
-//* Basic routines::           
-//@end menu
-
-//@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
-//@subsubsection Closure Queues
-/*
-  Closure Queues
-
-  These routines manage the closure queue.
-*/
-
-static nat clq_pos, clq_size;
-
-static StgClosure **ClosureQueue = NULL;   /* HWL: init in main */
-
-#if defined(DEBUG)
-static char graphFingerPrint[MAX_FINGER_PRINT_LEN];
-#endif
-
-//@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
-//@subsubsection Init routines
-
-/* @InitClosureQueue@ allocates and initialises the closure queue. */
-
-//@cindex InitClosureQueue
-static inline void
-InitClosureQueue(void)
-{
-  clq_pos = clq_size = 0;
-
-  if (ClosureQueue==NULL)
-    ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE, 
-                                                "InitClosureQueue");
-}
-
-//@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
-//@subsubsection Basic routines
-
-/*
-  QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
-*/
-
-//@cindex QueueEmpty
-static inline rtsBool
-QueueEmpty(void)
-{
-  return(clq_pos >= clq_size);
-}
-
-/* QueueClosure adds its argument to the closure queue. */
-
-//@cindex QueueClosure
-static inline void
-QueueClosure(closure)
-StgClosure *closure;
-{
-  if(clq_size < RTS_PACK_BUFFER_SIZE ) {
-    IF_PAR_DEBUG(paranoia,
-                belch(">__> <<%d>> Q: %p (%s); %d elems in q",
-                      globalPackBuffer->id, closure, info_type(closure), clq_size-clq_pos));
-    ClosureQueue[clq_size++] = closure;
-  } else { 
-    barf("Closure Queue Overflow (EnQueueing %p (%s))", 
-        closure, info_type(closure));
-  }
-}
-
-/* DeQueueClosure returns the head of the closure queue. */
-
-//@cindex DeQueueClosure
-static inline StgClosure * 
-DeQueueClosure(void)
-{
-  if(!QueueEmpty()) {
-    IF_PAR_DEBUG(paranoia,
-                belch(">__> <<%d>> DeQ: %p (%s); %d elems in q",
-                      globalPackBuffer->id, ClosureQueue[clq_pos], info_type(ClosureQueue[clq_pos]), 
-                      clq_size-clq_pos));
-    return(ClosureQueue[clq_pos++]);
-  } else {
-    return((StgClosure*)NULL);
-  }
-}
-
-/* DeQueueClosure returns the head of the closure queue. */
-
-#if defined(DEBUG)
-//@cindex PrintQueueClosure
-static void
-PrintQueueClosure(void)
-{
-  nat i;
-
-  fputs("Closure queue:", stderr);
-  for (i=clq_pos; i < clq_size; i++)
-    fprintf(stderr, "%p (%s), ", 
-           (StgClosure *)ClosureQueue[clq_pos++], 
-           info_type(ClosureQueue[clq_pos++]));
-  fputc('\n', stderr);
-}
-#endif
-
-//@node Types of Global Addresses,  , Basic routines, ADT of Closure Queues
-//@subsubsection Types of Global Addresses
-
-/*
-  Types of Global Addresses
-
-  These routines determine whether a GA is one of a number of special types
-  of GA.
-*/
-
-# if defined(PAR)
-//@cindex isOffset
-static inline rtsBool 
-isOffset(globalAddr *ga)
-{
-    return (ga->weight == 1U && ga->payload.gc.gtid == (GlobalTaskId)0);
-}
-
-//@cindex isFixed
-static inline rtsBool
-isFixed(globalAddr *ga)
-{
-    return (ga->weight == 0U);
-}
-
-//@cindex isConstr
-static inline rtsBool
-isConstr(globalAddr *ga)
-{
-    return (ga->weight == 2U);
-}
-
-//@cindex isUnglobalised
-static inline rtsBool
-isUnglobalised(globalAddr *ga)
-{
-    return (ga->weight == 2U);
-}
-# endif
-
-//@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
-//@subsection Initialisation for packing
-/*
-  Simple Packing Routines
-
-  About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
-  gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
-  words.  In the simulated PackBuffer we only keep the addresses of the
-  closures that would be packed in the parallel system (see Pack). To
-  decide if a packet overflow occurs pack_buffer_size must be compared
-  versus unpacked_size (see RoomToPack).  Currently, there is no multi
-  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
-*/
-
-# if defined(GRAN)
-rtsPackBuffer *
-InstantiatePackBuffer (void) {
-  extern rtsPackBuffer *globalPackBuffer;
-
-  globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer), 
-                        "InstantiatePackBuffer: failed to alloc packBuffer");
-  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 (globalPackBuffer);
-}
-
-/* 
-   Reallocate the GranSim internal pack buffer to make room for more closure
-   pointers. This is independent of the check for packet overflow as in GUM
-*/
-static void
-reallocPackBuffer (void) {
-
-  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",
-                     globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
-                     CurrentProc, CurrentTime[CurrentProc]));
-  
-  globalPackBuffer = (rtsPackBuffer*)realloc(globalPackBuffer, 
-                                 sizeof(StgClosure*)*(REALLOC_SZ +
-                                                      (int)globalPackBuffer->size +
-                                                      sizeofW(rtsPackBuffer))) ;
-  if (globalPackBuffer==(rtsPackBuffer*)NULL) 
-    barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n", 
-        REALLOC_SZ, globalPackBuffer, CurrentProc, CurrentTime[CurrentProc]);
-  
-  globalPackBuffer->size += REALLOC_SZ;
-
-  ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
-}
-# endif
-
-# if defined(PAR)
-/* @initPacking@ initialises the packing buffer etc. */
-//@cindex InitPackBuffer
-rtsBool
-InitPackBuffer(void)
-{
-  if (globalPackBuffer==(rtsPackBuffer*)NULL) {
-    if ((globalPackBuffer = (rtsPackBuffer *) 
-        stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM,
-                       "InitPackBuffer")) == NULL)
-      return rtsFalse;
-  }
-  return rtsTrue;
-}
-
-# endif 
-//@cindex InitPacking
-static void
-InitPacking(rtsBool unpack)
-{
-# if defined(GRAN)
-  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;
-
-  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 */
-  roomInBuffer = rtsTrue;
-  packed_thunks = 0;   /* total number of thunks packed so far */
-# if defined(PAR)
-  offsetTable = allocHashTable();
-# endif
-}
-
-//@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
-//@subsection Packing Functions
-
-//@menu
-//* Packing Sections of Nearby Graph:: 
-//* Packing Closures::         
-//@end menu
-
-//@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
-//@subsubsection Packing Sections of Nearby Graph
-/*
-  Packing Sections of Nearby Graph
-
-  @PackNearbyGraph@ packs a closure and associated graph into a static
-  buffer (@PackBuffer@).  It returns the address of this buffer and the
-  size of the data packed into the buffer (in its second parameter,
-  @packBufferSize@).  The associated graph is packed in a depth first
-  manner, hence it uses an explicit queue of closures to be packed rather
-  than simply using a recursive algorithm.  Once the packet is full,
-  closures (other than primitive arrays) are packed as FetchMes, and their
-  children are not queued for packing.  */
-
-//@cindex PackNearbyGraph
-
-/* NB: this code is shared between GranSim and GUM;
-       tso only used in GranSim */
-rtsPackBuffer *
-PackNearbyGraph(closure, tso, packBufferSize, dest)
-StgClosure* closure;
-StgTSO* tso;
-nat *packBufferSize;
-GlobalTaskId dest;
-{
-  IF_PAR_DEBUG(resume,
-              graphFingerPrint[0] = '\0');
-
-  ASSERT(RTS_PACK_BUFFER_SIZE > 0);
-  ASSERT(_HS==1);  // HWL HACK; compile time constant
-
-#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
-  PAR_TICKY_PACK_NEARBY_GRAPH_START();
-#endif
-
-  /* ToDo: check that we have enough heap for the packet
-     ngoq ngo'
-     if (Hp + PACK_HEAP_REQUIRED > HpLim) 
-     return NULL;
-  */
-  InitPacking(rtsFalse);
-# if defined(PAR)
-  dest_gtid=dest; //-1 to disable
-# elif 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]",
-                     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(resume,
-              GraphFingerPrint(closure, graphFingerPrint);
-              ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
-              belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n    demanded by TSO %d (%p); Finger-print is\n    {%s}",
-                    globalPackBuffer->id, globalPackBuffer, closure, mytid,
-                    tso->id, tso, graphFingerPrint)); 
-
-  IF_PAR_DEBUG(packet,
-              belch("** PrintGraph of %p is:", closure); 
-              belch("** pack_locn=%d", pack_locn);
-              PrintGraph(closure,0));
-
-  QueueClosure(closure);
-  do {
-    PackClosure(DeQueueClosure());
-  } while (!QueueEmpty());
-  
-# if defined(PAR)
-
-  /* Record how much space the graph needs in packet and in heap */
-  globalPackBuffer->tso = tso;       // currently unused, I think (debugging?)
-  globalPackBuffer->unpacked_size = unpacked_size;
-  globalPackBuffer->size = pack_locn;
-
-  /* Check for buffer overflow (again) */
-  ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM);
-  IF_DEBUG(sanity,                           // write magic end-of-buffer word
-          globalPackBuffer->buffer[pack_locn] = END_OF_BUFFER_MARKER);
-  *packBufferSize = pack_locn;
-
-# else  /* GRAN */
-
-  /* Record how much space is needed to unpack the graph */
-  // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;  for testing
-  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);
-  globalPackBuffer->size = pack_locn;
-  *packBufferSize = pack_locn;
-
-# endif
-
-  DonePacking();                               /* {GrAnSim}vaD 'ut'Ha' */
-
-# if defined(GRAN)
-  IF_GRAN_DEBUG(pack ,
-               belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
-                     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(globalPackBuffer));
-# elif defined(PAR)
-  IF_PAR_DEBUG(packet,
-               belch("** Finished <<%d>> packing graph %p (%s); closures packed: %d; thunks packed: %d; size of graph: %d",
-                     globalPackBuffer->id, closure, info_type(closure),
-                     globalPackBuffer->size, packed_thunks, 
-                     globalPackBuffer->unpacked_size));;
-
-  IF_DEBUG(sanity, // do a sanity check on the packet just constructed 
-          checkPacket(globalPackBuffer));
-# endif   /* GRAN */
-
-#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
-  PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks);
-#endif
-  
-  return (globalPackBuffer);
-}
-
-//@cindex PackOneNode
-
-# if defined(GRAN)
-/* This version is used when the node is already local */
-
-rtsPackBuffer *
-PackOneNode(closure, tso, packBufferSize)
-StgClosure* closure;
-StgTSO* tso;
-nat *packBufferSize;
-{
-  extern rtsPackBuffer *globalPackBuffer;
-  int i, clpack_locn;
-
-  InitPacking(rtsFalse);
-
-  IF_GRAN_DEBUG(pack,
-               belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
-                     closure, info_type(closure),
-                     where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));
-
-  Pack(closure);
-
-  /* Record how much space is needed to unpack the graph */
-  globalPackBuffer->tso = tso;
-  globalPackBuffer->unpacked_size = unpacked_size;
-
-  /* Set the size parameter */
-  ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
-  globalPackBuffer->size =  pack_locn;
-  *packBufferSize = pack_locn;
-
-  if (RtsFlags.GranFlags.GranSimStats.Global) {
-    globalGranStats.tot_packets++; 
-    globalGranStats.tot_packet_size += pack_locn; 
-  }
-  IF_GRAN_DEBUG(pack,
-    PrintPacket(globalPackBuffer));
-
-  return (globalPackBuffer);
-}
-# endif  /* GRAN */
-
-#if defined(GRAN)
-
-/*
-   PackTSO and PackStkO are entry points for two special kinds of closure
-   which are used in the parallel RTS.  Compared with other closures they
-   are rather awkward to pack because they don't follow the normal closure
-   layout (where all pointers occur before all non-pointers).  Luckily,
-   they're only needed when migrating threads between processors.  */
-
-//@cindex PackTSO
-rtsPackBuffer*
-PackTSO(tso, packBufferSize)
-StgTSO *tso;
-nat *packBufferSize;
-{
-  extern rtsPackBuffer *globalPackBuffer;
-  IF_GRAN_DEBUG(pack,
-               belch("** Packing TSO %d (%p)", tso->id, tso));
-  *packBufferSize = 0;
-  // PackBuffer[0] = PackBuffer[1] = 0; ???
-  return(globalPackBuffer);
-}
-
-//@cindex PackStkO
-static rtsPackBuffer*
-PackStkO(stko, packBufferSize)
-StgPtr stko;
-nat *packBufferSize;
-{
-  extern rtsPackBuffer *globalPackBuffer;
-  IF_GRAN_DEBUG(pack,
-               belch("** Packing STKO %p", stko));
-  *packBufferSize = 0;
-  // PackBuffer[0] = PackBuffer[1] = 0;
-  return(globalPackBuffer);
-}
-
-static void
-PackFetchMe(StgClosure *closure)
-{
-  barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
-}
-
-#elif defined(PAR)
-
-static rtsPackBuffer*
-PackTSO(tso, packBufferSize)
-StgTSO *tso;
-nat *packBufferSize;
-{
-  barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
-       tso->id, tso, packBufferSize);
-}
-
-rtsPackBuffer*
-PackStkO(stko, packBufferSize)
-StgPtr stko;
-nat *packBufferSize;
-{
-  barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
-       stko, packBufferSize);
-}
-
-//@cindex PackFetchMe
-static void
-PackFetchMe(StgClosure *closure)
-{
-  StgInfoTable *ip;
-  nat i;
-  int offset;
-#if defined(DEBUG)
-  nat x = pack_locn;
-#endif
-
-#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 += 0;   // unpacked_size unchanged (closure is shared!!)
-    return;
-  }
-
-  /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
-  AmPacking(closure);
-  /* FMs must be always globalised */
-  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 = &stg_FETCH_ME_info;
-  /* this assumes that the info ptr is always the first word in a closure*/
-  Pack((StgWord)ip);
-  for (i = 1; i < _HS; ++i)               // pack rest of fixed header
-    Pack((StgWord)*(((StgPtr)closure)+i));
-  
-  unpacked_size += sizeofW(StgFetchMe);
-  /* size of FETCHME in packed is the same as that constant */
-  ASSERT(pack_locn-x==PACK_FETCHME_SIZE);
-  /* In the pack buffer the pointer to a GA (in the FetchMe closure) 
-     is expanded to the full GA; this is a compile-time const */
-  //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);  
-#endif
-}
-
-#endif
-
-#ifdef DIST
-static void
-PackRemoteRef(StgClosure *closure)
-{
-  StgInfoTable *ip;
-  nat i;
-  int offset;
-
-  offset = OffsetFor(closure);
-  if (!NotYetPacking(offset)) {
-    PackOffset(offset);
-    unpacked_size += 2;
-    return;
-  }
-
-  /* Need a GA even when packing a constructed REMOTE_REF (cruel world!) */
-  AmPacking(closure);
-  
-  /* basically we just Globalise, but for sticky things we can't have multiple GAs,
-     so we must prevent the GAs being split.
-     
-     In returning things to the true sticky owner, this case is already handled, but for
-     anything else we just give up at the moment... This needs to be fixed! 
-  */
-  { globalAddr *ga;
-    ga = LAGAlookup(closure); // surely this ga must exist?
-    
-    // ***************************************************************************
-    // ***************************************************************************
-    // REMOTE_REF HACK - dual is in SetGAandCommonUp
-    // - prevents the weight from ever reaching zero
-    if(ga != NULL) 
-      ga->weight=0x06660666; //anything apart from 0 really...
-    // ***************************************************************************
-    // ***************************************************************************
-    
-    if((ga != NULL)&&(ga->weight / 2 <= 2))
-      barf("Cant split the weight any further when packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
-               closure, info_type(closure), 
-               ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight);                               
-  } 
-  GlobaliseAndPackGA(closure);
-      
-  IF_PAR_DEBUG(pack,
-              belch("*>.. Packing REMOTE_REF 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 REMOTE_REF closure instead of closure */
-  ip = &stg_REMOTE_REF_info;
-  /* this assumes that the info ptr is always the first word in a closure*/
-  Pack((StgWord)ip);
-  for (i = 1; i < _HS; ++i)               // pack rest of fixed header
-    Pack((StgWord)*(((StgPtr)closure)+i));
-  
-  unpacked_size += PACK_FETCHME_SIZE;
-}
-#endif /* DIST */
-
-//@node Packing Closures,  , Packing Sections of Nearby Graph, Packing Functions
-//@subsubsection Packing Closures
-/*
-  Packing Closures
-
-  @PackClosure@ is the heart of the normal packing code.  It packs a single
-  closure into the pack buffer, skipping over any indirections and
-  globalising it as necessary, queues any child pointers for further
-  packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
-  locally if it was a thunk.  Before the actual closure is packed, a
-  suitable global address (GA) is inserted in the pack buffer.  There is
-  always room to pack a fetch-me to the closure (guaranteed by the
-  RoomToPack calculation), and this is packed if there is no room for the
-  entire closure.
-
-  Space is allocated for any primitive array children of a closure, and
-  hence a primitive array can always be packed along with it's parent
-  closure.  */
-
-//@cindex PackClosure
-
-# if defined(PAR)
-
-void
-PackClosure(closure)
-StgClosure *closure;
-{
-  StgInfoTable *info;
-  nat clpack_locn;
-
-  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)) {
-    PackOffset(clpack_locn);
-    return;
-  }
-
-  switch (info->type) {
-
-  case CONSTR_CHARLIKE:
-    IF_PAR_DEBUG(pack,
-                belch("*>^^ Packing a charlike closure %d", 
-                      ((StgIntCharlikeClosure*)closure)->data));
-    
-    PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
-    // NB: unpacked_size of a PLC is 0
-    return;
-      
-  case CONSTR_INTLIKE:
-    {
-      StgInt val = ((StgIntCharlikeClosure*)closure)->data;
-
-      if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
-       IF_PAR_DEBUG(pack,
-                    belch("*>^^ Packing a small intlike %d as a PLC", 
-                          val));
-       PackPLC((StgPtr)INTLIKE_CLOSURE(val));
-       // NB: unpacked_size of a PLC is 0
-       return;
-      } else {
-       IF_PAR_DEBUG(pack,
-                    belch("*>^^ Packing a big intlike %d as a normal closure", 
-                          val));
-       PackGeneric(closure);
-       return;
-      }
-    }
-
-  case CONSTR:
-  case CONSTR_1_0:
-  case CONSTR_0_1:
-  case CONSTR_2_0:
-  case CONSTR_1_1:
-  case CONSTR_0_2:
-    /* it's a constructor (i.e. plain data) */
-    IF_PAR_DEBUG(pack,
-                belch("*>^^ Packing a CONSTR %p (%s) using generic packing", 
-                      closure, info_type(closure)));
-    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", 
-                      closure, info_type(closure)));
-
-    PackPLC((StgPtr)closure);
-    // NB: unpacked_size of a PLC is 0
-    return;
-
-  case THUNK_SELECTOR: 
-    {
-      StgClosure *selectee = ((StgSelector *)closure)->selectee;
-
-      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("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME", 
-                      closure, info_type(closure)));
-    PackFetchMe(closure);
-    */
-    PackPAP((StgPAP *)closure);
-    return;
-
-  case CAF_BLACKHOLE:
-  case BLACKHOLE:
-  case BLACKHOLE_BQ:
-  case SE_BLACKHOLE:
-  case SE_CAF_BLACKHOLE:
-  case RBH:
-  case FETCH_ME:
-  case FETCH_ME_BQ:
-
-    /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
-    //ASSERT(pack_locn > PACK_HDR_SIZE);
-    
-    IF_PAR_DEBUG(pack,
-                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;
-
-#ifdef DIST    
-  case REMOTE_REF:
-    IF_PAR_DEBUG(pack,
-                belch("*>.. Packing %p (%s) as a REMOTE_REF", 
-                      closure, info_type(closure)));
-    PackRemoteRef(closure);
-    /* we hopefully don't end up with a chain of REMOTE_REFs!!!!!!!!!! */
-
-    return;
-#endif  
-    
-  case TSO:
-  case MVAR:
-#ifdef DIST
-          IF_PAR_DEBUG(pack,
-                belch("*>.. Packing %p (%s) as a RemoteRef", 
-                      closure, info_type(closure)));
-    PackRemoteRef(closure);
-#else
-    barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)", 
-        closure, info_type(closure));
-#endif    
-    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 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:
-    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(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 a constructor at %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);
-
-  /* Pack Constructor marker */
-  Pack((StgWord)2);
-
-  /* pack fixed and variable header */
-  for (i = 0; i < _HS + vhs; ++i)
-    Pack((StgWord)*(((StgPtr)closure)+i));
-      
-  /* register all ptrs for further packing */
-  for (i = 0; i < ptrs; ++i)
-    QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
-
-  /* pack non-ptrs */
-  for (i = 0; i < nonptrs; ++i)
-    Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
-}
-#endif
-
-/*
-  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, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
-                      closure, info_type(closure), size, ptrs, nonptrs));
-
-  /* packing strategies: how many thunks to add to a packet; 
-     default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */
-  if (RtsFlags.ParFlags.thunksToPack &&
-      packed_thunks >= RtsFlags.ParFlags.thunksToPack &&
-      closure_THUNK(closure)) {
-    IF_PAR_DEBUG(pack,
-                belch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)",
-                      packed_thunks, closure, info_type(closure)));
-    PackFetchMe(closure);
-    return;
-  }
-
-  /* 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 */
-  /* Checks for globalisation scheme; default: globalise everything thunks */
-  if ( RtsFlags.ParFlags.globalising == 0 || 
-       (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
-    GlobaliseAndPackGA(closure);
-  else
-    Pack((StgWord)2);  // marker for unglobalised 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)||(info->type != REMOTE_REF)))
-    barf("*>// %p (%s) PackClosure: trying to replicate a Mutable closure!",
-        closure, info_type(closure));
-      
-  /* 
-     Remember, the generic closure layout is as follows:
-        +-------------------------------------------------+
-       | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
-        +-------------------------------------------------+
-  */
-  /* pack fixed and variable header */
-  for (i = 0; i < _HS + vhs; ++i)
-    Pack((StgWord)*(((StgPtr)closure)+i));
-      
-  /* register all ptrs for further packing */
-  for (i = 0; i < ptrs; ++i)
-    QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
-
-  /* pack non-ptrs */
-  for (i = 0; i < nonptrs; ++i)
-    Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
-      
-  // 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
-   * its address from the fetch reply.  Problem: unshared thunks may cause
-   * space leaks this way, their GAs should be deallocated following an
-   * ACK.
-   */
-      
-  if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) { 
-    rbh = convertToRBH(closure);
-    ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
-    ASSERT(rbh == closure);         // rbh at the same position (minced version)
-    packed_thunks++;
-  } else if ( closure==graph_root ) {
-    packed_thunks++;                // root of graph is counted as a thunk
-  }
-}
-/*
-  Pack an array of words.
-  ToDo: implement packing of MUT_ARRAYs
-*/
-
-//@cindex PackArray
-static void
-PackArray(StgClosure *closure)
-{
-  StgInfoTable *info;
-  nat size, ptrs, nonptrs, vhs;
-  nat i, n;
-  char str[80];
-
-  /* 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);
-
-  n = arr_words_words(((StgArrWords *)closure));
-  // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q)); 
-
-  IF_PAR_DEBUG(pack,
-              belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
-                    closure, info_type(closure), n,
-                    arr_words_sizeW((StgArrWords *)closure)));
-
-  /* check that we have enough room in the pack buffer */
-  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;
-  }
-
-  /* global stats about arrays sent */
-  if (RtsFlags.ParFlags.ParStats.Global &&
-      RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
-    globalParStats.tot_arrs++;
-    globalParStats.tot_arr_size += arr_words_words(((StgArrWords *)closure));
-  }
-
-  /* record offset of the closure and allocate a GA */
-  AmPacking(closure);
-  /* Checks for globalisation scheme; default: globalise everything thunks */
-  if ( RtsFlags.ParFlags.globalising == 0 || 
-       (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
-    GlobaliseAndPackGA(closure);
-  else
-    Pack((StgWord)2);  // marker for unglobalised closure
-
-  /* Pack the header (2 words: info ptr and the number of words to follow) */
-  Pack((StgWord)*(StgPtr)closure);
-  Pack(arr_words_words(((StgArrWords *)closure)));
-
-  /* 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 n, i, j, pack_start;
-  StgPtr p, q;
-  const StgInfoTable* info;
-  StgWord bitmap;
-  /* debugging only */
-  StgPtr end;
-  nat size, ptrs, nonptrs, vhs;
-  char str[80];
-  nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
-
-  /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
-  //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
-  ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
-  IF_DEBUG(sanity,
-          unpacked_size_before_PAP = unpacked_size);
-
-  n = (nat)(pap->n_args);
-
-  /* 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));
-
-  IF_PAR_DEBUG(pack,
-              belch("*>**  %p (%s): PackPAP: packing PAP with %d words (size=%d; ptrs=%d; nonptrs=%d:", 
-                    (StgClosure *)pap, info_type((StgClosure *)pap),
-                    n, size, ptrs, nonptrs);
-               printClosure((StgClosure *)pap));
-
-  /* check that we have enough room in the pack buffer */
-  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)",
-                      (StgClosure *)pap, info_type((StgClosure *)pap)));
-    PackFetchMe((StgClosure *)pap);
-    return;
-  }
-
-  /* record offset of the closure and allocate a GA */
-  AmPacking((StgClosure *)pap);
-  /* Checks for globalisation scheme; default: globalise everything thunks */
-  if ( RtsFlags.ParFlags.globalising == 0 || 
-       (closure_THUNK(pap) && !closure_UNPOINTED(pap)) )
-    GlobaliseAndPackGA((StgClosure *)pap);
-  else
-    Pack((StgWord)2);  // marker for unglobalised closure
-
-  /* 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((W_)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++;
-           IF_DEBUG(sanity, FMs_in_PAP++);
-           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++;
-         IF_DEBUG(sanity, FMs_in_PAP++);
-         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
-         IF_DEBUG(sanity, FMs_in_PAP++);
-       } else {
-         Pack((StgWord)*p++);
-       }
-       bitmap = bitmap >> 1;
-      }
-      
-    follow_srt:
-       IF_PAR_DEBUG(pack,
-                    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 + BITS_IN(W_);
-         while (bitmap != 0) {
-           if ((bitmap & 1) == 0) {
-             Pack((StgWord)(ARGTAG_MAX+1));
-             PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
-             IF_DEBUG(sanity, FMs_in_PAP++);
-           } 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);
-             IF_DEBUG(sanity, FMs_in_PAP++);
-           }
-         }
-       }
-
-       /* 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));
-  /*
-    We can use the generic pap_sizeW macro to compute the size of the
-    unpacked PAP because whenever we pack a new FETCHME as part of the
-    PAP's payload we also adjust unpacked_size accordingly (smart, aren't we?)
-
-    NB: the current PAP (un-)packing code  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 += pap_sizeW(pap); // sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
-  IF_DEBUG(sanity,
-          ASSERT(unpacked_size-unpacked_size_before_PAP==pap_sizeW(pap)+FMs_in_PAP*sizeofW(StgFetchMe)));
-}
-# 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;
-  StgClosure *indirectee, *rbh;
-  char str[80];
-  rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
-
-  is_mutable = rtsFalse;
-
-  /* In GranSim we don't pack and unpack closures -- we just simulate
-     packing by updating the bitmask. So, the graph structure is unchanged
-     i.e. we don't short out indirections here. -- HWL */
-
-  /* Nothing to do with packing but good place to (sanity) check closure;
-     if the closure is a thunk, it must be unique; otherwise we have copied
-     work at some point before that which violates one of our main global
-     assertions in GranSim/GUM */
-  ASSERT(!closure_THUNK(closure) || is_unique(closure));
-
-  IF_GRAN_DEBUG(pack,
-               belch("**  Packing closure %p (%s)",
-                     closure, info_type(closure)));
-
-  if (where_is(closure) != where_is(graph_root)) {
-    IF_GRAN_DEBUG(pack,
-                 belch("**   faking a FETCHME [current PE: %d, closure's PE: %d]",
-                       where_is(graph_root), where_is(closure)));
-
-    /* GUM would pack a FETCHME here; simulate that by increasing the */
-    /* unpacked size accordingly but don't pack anything -- HWL */
-    unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
-    return;