Remove unused files.
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: FetchMe.c,v 1.2 1998/12/02 13:29:03 simonm Exp $
- *
- * Entry code for a FETCH_ME closure
- *
- * ---------------------------------------------------------------------------*/
-
-#ifdef PAR /* all of it */
-
-#include "Rts.h"
-#include "FetchMe.h"
-#include "HLC.h"
-
-/* -----------------------------------------------------------------------------
- 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.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(FETCH_ME_info, FETCH_ME_entry, 0,2, FETCH_ME, const, EF_,0,0);
-
-STGFUN(FETCH_ME_entry)
-{
- globalAddr *rGA;
- globalAddr *lGA;
- globalAddr fmbqGA;
-
-# if defined(GRAN)
- STGCALL0(void,(),GranSimBlock); /* Do this before losing its TSO_LINK */
-# endif
-
- rGA = FETCHME_GA(R1);
- ASSERT(rGA->loc.gc.gtid != mytid);
-
- /* Turn the FETCH_ME into a FETCH_ME_BQ, and place the current thread
- * on the blocking queue.
- */
- R1.cl->header.info = FETCH_ME_BQ_info;
- CurrentTSO->link = END_TSO_QUEUE;
- ((StgBlackHole *)R1.cl)->blocking_queue = CurrentTSO;
-
-#ifdef 0 /* unknown junk... needed? --SDM */
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-
- if (RTSflags.ParFlags.granSimStats) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- TIME now = CURRENT_TIME;
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- TSO_FETCHCOUNT(CurrentTSO)++;
- TSO_QUEUE(CurrentTSO) = Q_FETCHING;
- TSO_BLOCKEDAT(CurrentTSO) = now;
- /* DumpGranEventAndNode(GR_FETCH, CurrentTSO, (SAVE_R1).p,
- taskIDtoPE(rGA->loc.gc.gtid)); */
- DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(rGA->loc.gc.gtid),GR_FETCH,
- CurrentTSO,(SAVE_R1).p,0);
- }
-
- /* Phil T. claims that this was a workaround for a hard-to-find
- * bug, hence I'm leaving it out for now --SDM
- */
- /* Assign a brand-new global address to the newly created FMBQ */
- lGA = MakeGlobal((SAVE_R1).p, rtsFalse);
- splitWeight(&fmbqGA, lGA);
- ASSERT(fmbqGA.weight == 1L << (BITS_IN(unsigned) - 1));
-#endif
-
- /* I *hope* it's ok to call this from STG land. --SDM */
- STGCALL3(sendFetch, rGA, &fmbqGA, 0/*load*/);
-
- BLOCK_NP(1); /* back to the scheduler */
-
- 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 black hole. 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.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(FETCH_ME_BQ_info, BLACKHOLE_entry,0,2,BLACKHOLE,const,EF_,0,0);
-
-#endif /* PAR */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: FetchMe.h,v 1.2 1998/12/02 13:29:04 simonm Exp $
- *
- * Closure types for the parallel system.
- *
- * ---------------------------------------------------------------------------*/
-
-EI_(FETCH_ME_info);
-EF_(FETCH_ME_entry);
-
-EI_(FETCH_ME_BQ_info);
-
-EI_(BLOCKED_FETCH_info);
-EF_(BLOCKED_FETCH_entry);
-
+++ /dev/null
-/********************************************************************
-* 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 *
-*********************************************************************/
-
-#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
-
-void sendFetch (globalAddr *ga, globalAddr *bqga, int load);
-void sendResume (globalAddr *bqga, int nelem, P_ data);
-void sendAck (GLOBAL_TASK_ID task, int ngas, globalAddr *gagamap);
-void sendFish (GLOBAL_TASK_ID destPE, GLOBAL_TASK_ID origPE, int age, int history, int hunger);
-void sendFree (GLOBAL_TASK_ID destPE, int nelem, P_ data);
-void sendSchedule (GLOBAL_TASK_ID origPE, int nelem, P_ data);
-void processMessages(void);
-void processFetches(void);
-
-void prepareFreeMsgBuffers(void);
-void freeRemoteGA (int pe, globalAddr *ga);
-void sendFreeMessages(void);
-
-GLOBAL_TASK_ID choosePE(void);
-
-void WaitForTermination(void);
-
-void DebugPrintGAGAMap (globalAddr *gagamap, int nGAs);
-
-void CommonUp (P_, P_);
-
-#endif /* PAR */
-#endif /* __HLC_H */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- *
- * $Id: HLComms.c,v 1.3 1999/02/15 14:30:56 simonm Exp $
- *
- * High Level Communications Routines (HLComms.lc)
- *
- * Contains the high-level routines (i.e. communication
- * subsystem independent) used by GUM
- *
- * Phil Trinder, Glasgow University, 12 December 1994
- * Adapted for new RTS
- * Phil Trinder, Simon Marlow July 1998
- *
- * -------------------------------------------------------------------------- */
-
-#ifdef PAR /* whole file */
-
-#ifndef _AIX
-#define NON_POSIX_SOURCE /* so says Solaris */
-#endif
-
-#include "Rts.h"
-#include "RtsUtils.h"
-#include "RtsFlags.h"
-
-#include "HLC.h"
-#include "Parallel.h"
-
-/*
- * GUM Message Sending and Unpacking Functions
- * ********************************************
- */
-
-/*
- * Allocate space for message processing
- */
-
-static W_ *gumPackBuffer;
-
-void
-InitMoreBuffers(void)
-{
- gumPackBuffer
- = (W_ *) stgMallocWords(RtsFlags.ParFlags.packBufferSize, "initMoreBuffers");
-}
-
-/*
- *SendFetch packs the two global addresses and a load into a message +
- *sends it.
- */
-
-void
-sendFetch(globalAddr *rga, globalAddr *lga, int load)
-{
-
- ASSERT(rga->weight > 0 && lga->weight > 0);
-#ifdef FETCH_DEBUG
- fprintf(stderr, "Sending Fetch (%x, %d, 0), load = %d\n",
- rga->loc.gc.gtid, rga->loc.gc.slot, load);
-#endif
- SendOpV(PP_FETCH, rga->loc.gc.gtid, 6,
- (W_) rga->loc.gc.gtid, (W_) rga->loc.gc.slot,
- (W_) lga->weight, (W_) lga->loc.gc.gtid, (W_) lga->loc.gc.slot, (W_) load);
-}
-
-/*
- *unpackFetch unpacks a FETCH message into two Global addresses and a load figure.
- */
-
-static void
-unpackFetch(globalAddr *lga, globalAddr *rga, int *load)
-{
- long buf[6];
-
- GetArgs(buf, 6);
- lga->weight = 1;
- lga->loc.gc.gtid = (GLOBAL_TASK_ID) buf[0];
- lga->loc.gc.slot = (int) buf[1];
-
- rga->weight = (unsigned) buf[2];
- rga->loc.gc.gtid = (GLOBAL_TASK_ID) buf[3];
- rga->loc.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.
- */
-
-void
-sendResume(globalAddr *rga, int nelem, StgPtr data)
-{
-
-#ifdef RESUME_DEBUG
- PrintPacket(data);
- fprintf(stderr, "Sending Resume for (%x, %d, %x)\n",
- rga->loc.gc.gtid, rga->loc.gc.slot, rga->weight);
-#endif
-
- SendOpNV(PP_RESUME, rga->loc.gc.gtid, nelem, data, 2,
- (W_) rga->weight, (W_) rga->loc.gc.slot);
-
-}
-
-/*
- * blockFetch blocks a BlockedFetch node on some kind of black hole.
- */
-static void
-blockFetch(StgPtr bf, StgPtr bh)
-{}
-
-#if 0
- Empty until Blocked fetches etc defined
- switch (INFO_TYPE(INFO_PTR(bh))) {
- case INFO_BH_TYPE:
- BF_LINK(bf) = PrelBase_Z91Z93_closure;
- SET_INFO_PTR(bh, BQ_info);
- BQ_ENTRIES(bh) = (W_) bf;
-
-#ifdef GC_MUT_REQUIRED
- /*
- * 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 INFO_BQ_TYPE:
- BF_LINK(bf) = (P_) BQ_ENTRIES(bh);
- BQ_ENTRIES(bh) = (W_) bf;
- break;
- case INFO_FMBQ_TYPE:
- BF_LINK(bf) = (P_) FMBQ_ENTRIES(bh);
- FMBQ_ENTRIES(bh) = (W_) bf;
- break;
- case INFO_SPEC_RBH_TYPE:
- BF_LINK(bf) = (P_) SPEC_RBH_BQ(bh);
- SPEC_RBH_BQ(bh) = (W_) bf;
- break;
- case INFO_GEN_RBH_TYPE:
- BF_LINK(bf) = (P_) GEN_RBH_BQ(bh);
- GEN_RBH_BQ(bh) = (W_) bf;
- break;
- default:
- fprintf(stderr, "Panic: thought %#lx was a black hole (IP %#lx)\n",
- (W_) bh, INFO_PTR(bh));
- EXIT(EXIT_FAILURE);
- }
-}
-#endif
-
-/*
- * processFetches constructs and sends resume messages for every
- * BlockedFetch which is ready to be awakened.
- */
-extern P_ PendingFetches;
-
-void
-processFetches()
-{}
-
-#if 0
- Empty till closure defined
- P_ bf;
- P_ next;
- P_ closure;
- P_ ip;
- globalAddr rga;
-
- for (bf = PendingFetches; bf != PrelBase_Z91Z93_closure; bf = next) {
- next = BF_LINK(bf);
-
- /*
- * 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(bf);
- while (IS_INDIRECTION(INFO_PTR(closure)))
- closure = (P_) IND_CLOSURE_PTR(closure);
- ip = (P_) INFO_PTR(closure);
-
- if (INFO_TYPE(ip) == INFO_FETCHME_TYPE) {
- /* Forward the Fetch to someone else */
- rga.loc.gc.gtid = (GLOBAL_TASK_ID) BF_GTID(bf);
- rga.loc.gc.slot = (int) BF_SLOT(bf);
- rga.weight = (unsigned) BF_WEIGHT(bf);
-
- sendFetch(FETCHME_GA(closure), &rga, 0 /* load */);
- } else if (IS_BLACK_HOLE(ip)) {
- BF_NODE(bf) = closure;
- blockFetch(bf, closure);
- } else {
- /* We now have some local graph to send back */
- W_ size;
- P_ graph;
-
- if ((graph = PackNearbyGraph(closure, &size)) == NULL) {
- PendingFetches = bf;
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
- SAVE_Hp -= PACK_HEAP_REQUIRED;
- bf = PendingFetches;
- next = BF_LINK(bf);
- closure = BF_NODE(bf);
- graph = PackNearbyGraph(closure, &size);
- ASSERT(graph != NULL);
- }
- rga.loc.gc.gtid = (GLOBAL_TASK_ID) BF_GTID(bf);
- rga.loc.gc.slot = (int) BF_SLOT(bf);
- rga.weight = (unsigned) BF_WEIGHT(bf);
-
- sendResume(&rga, size, graph);
- }
- }
- PendingFetches = PrelBase_Z91Z93_closure;
-}
-#endif
-
-/*
- * unpackResume unpacks a Resume message into two Global addresses and
- * a data array.
- */
-
-static void
-unpackResume(globalAddr *lga, int *nelem, W_ *data)
-{
- long buf[3];
-
- GetArgs(buf, 3);
- lga->weight = (unsigned) buf[0];
- lga->loc.gc.gtid = mytid;
- lga->loc.gc.slot = (int) buf[1];
-
- *nelem = (int) buf[2];
- GetArgs(data, *nelem);
-}
-
-/*
- *SendAck packs the global address being acknowledged, together with
- *an array of global addresses for any closures shipped and sends them.
- */
-
-void
-sendAck(GLOBAL_TASK_ID task, int ngas, globalAddr *gagamap)
-{
- static long *buffer;
- long *p;
- int i;
-
- 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->loc.gc.gtid;
- p[2] = (long) gagamap->loc.gc.slot;
- gagamap++;
- p[3] = (long) gagamap->weight;
- p[4] = (long) gagamap->loc.gc.gtid;
- p[5] = (long) gagamap->loc.gc.slot;
- gagamap++;
- }
-#ifdef ACK_DEBUG
- fprintf(stderr,"Sending Ack (%d pairs) to %x\n", ngas, task);
-#endif
- SendOpN(PP_ACK, task, p - buffer, 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
- */
-
-static void
-unpackAck(int *ngas, globalAddr *gagamap)
-{
- long GAarraysize;
- long buf[6];
-
- GetArgs(&GAarraysize, 1);
-
- *ngas = GAarraysize / 6;
-
- while (GAarraysize > 0) {
- GetArgs(buf, 6);
- gagamap->weight = (unsigned) buf[0];
- gagamap->loc.gc.gtid = (GLOBAL_TASK_ID) buf[1];
- gagamap->loc.gc.slot = (int) buf[2];
- gagamap++;
- gagamap->weight = (unsigned) buf[3];
- gagamap->loc.gc.gtid = (GLOBAL_TASK_ID) buf[4];
- gagamap->loc.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.
- */
-
-void
-sendFish(GLOBAL_TASK_ID destPE, GLOBAL_TASK_ID origPE,
- int age, int history, int hunger)
-{
-
-#ifdef FISH_DEBUG
- fprintf(stderr,"Sending Fish to %lx\n", destPE);
-#endif
- SendOpV(PP_FISH, destPE, 4, (W_) origPE, (W_) age, (W_) history, (W_) hunger);
- if (origPE == mytid)
- fishing = rtsTrue;
-
-}
-
-/*
- *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.
- */
-
-static void
-unpackFish(GLOBAL_TASK_ID *origPE, int *age, int *history, int *hunger)
-{
- long buf[4];
-
- GetArgs(buf, 4);
-
- *origPE = (GLOBAL_TASK_ID) 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.
- */
-void
-sendFree(GLOBAL_TASK_ID pe, int nelem, StgPtr data)
-{
-#ifdef FREE_DEBUG
- fprintf(stderr, "Sending Free (%d GAs) to %x\n", nelem / 2, pe);
-#endif
- SendOpN(PP_FREE, pe, nelem, data);
-
-}
-
-
-/*
- *unpackFree unpacks a FREE message into the amount of data shipped and
- *a data block.
- */
-
-static void
-unpackFree(int *nelem, W_ *data)
-{
- long buf[1];
-
- GetArgs(buf, 1);
- *nelem = (int) buf[0];
- 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).
- */
-
-void
-sendSchedule(GLOBAL_TASK_ID origPE, int nelem, StgPtr data)
-{
-#ifdef SCHEDULE_DEBUG
- PrintPacket(data);
- fprintf(stderr, "Sending Schedule to %x\n", origPE);
-#endif
-
- SendOpN(PP_SCHEDULE, origPE, nelem, data);
-}
-
-/*
- *unpackSchedule unpacks a SCHEDULE message into the Global address of
- *the closure shipped, the amount of data shipped (nelem) and the data
- *block (data).
- */
-
-static void
-unpackSchedule(int *nelem, W_ *data)
-{
- long buf[1];
-
- GetArgs(buf, 1);
- *nelem = (int) buf[0];
- GetArgs(data, *nelem);
-}
-
-/*
- *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.
- *
- * Only stubs now. Real stuff in HLCommsRest PWT
- */
-static void
-processFish(void)
-{} /* processFish */
-
-/*
- * processFetch either returns the requested data (if available)
- * or blocks the remote blocking queue on a black hole (if not).
- */
-static void
-processFetch(void)
-{}
-
-/*
- * processFree unpacks a FREE message and adds the weights to our GAs.
- */
-static void
-processFree(void)
-{}
-
-/*
- * 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.
- */
-
-static void
-processResume(GLOBAL_TASK_ID sender)
-{}
-
-/*
- * 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.
- */
-static void
-processSchedule(GLOBAL_TASK_ID sender)
-{
-}
-
-/*
- * 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.
- */
-static void
-processAck(void)
-{}
-
-/*
- * 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.
- */
-
-void
-processMessages(void)
-{
- PACKET packet;
- OPCODE opcode;
- GLOBAL_TASK_ID task;
-
- do {
-
- packet = GetPacket(); /* Get next message; block until one available */
-
- get_opcode_and_sender(packet, &opcode, &task);
-
- switch (opcode) {
-
- case PP_FINISH:
- stg_exit(EXIT_SUCCESS); /* The computation has been completed by someone
- * else */
- break;
-
- case PP_FETCH:
- processFetch();
- break;
-
- case PP_RESUME:
- processResume(task);
- break;
-
- case PP_ACK:
- processAck();
- break;
-
- case PP_FISH:
- processFish();
- break;
-
- case PP_FREE:
- processFree();
- break;
-
- case PP_SCHEDULE:
- processSchedule(task);
- break;
-
- default:
- /* Anything we're not prepared to deal with. */
- fprintf(stderr, "Task %x: Unexpected opcode %x from %x\n",
- mytid, opcode, task);
-
- stg_exit(EXIT_FAILURE);
- } /* switch */
-
- } while (PacketsWaiting()); /* While there are messages: process them */
-} /* processMessages */
-
-/*
- * Miscellaneous Functions
- *
- *
- * 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);
-
-GLOBAL_TASK_ID
-choosePE(void)
-{
- long temp;
-
- temp = lrand48() % nPEs;
- if (PEs[temp] == mytid) { /* Never send a FISH to yourself */
- temp = (temp + 1) % nPEs;
- }
- return PEs[temp];
-}
-
-/*
- *WaitForTermination enters a loop ignoring spurious messages while waiting for the
- *termination sequence to be completed.
- */
-void
-WaitForTermination(void)
-{
- do {
- PACKET p = GetPacket();
- ProcessUnexpected(p);
- } while (rtsTrue);
-}
-
-#ifdef DEBUG
-void
-DebugPrintGAGAMap(globalAddr *gagamap, int nGAs)
-{
- int i;
-
- for (i = 0; i < nGAs; ++i, gagamap += 2)
- fprintf(stderr, "gagamap[%d] = (%x, %d, %x) -> (%x, %d, %x)\n", i,
- gagamap[0].loc.gc.gtid, gagamap[0].loc.gc.slot, gagamap[0].weight,
- gagamap[1].loc.gc.gtid, gagamap[1].loc.gc.slot, gagamap[1].weight);
-}
-#endif
-
-static PP_ freeMsgBuffer = NULL;
-static int *freeMsgIndex = NULL;
-
-void
-prepareFreeMsgBuffers(void)
-{
- int i;
-
- /* Allocate the freeMsg buffers just once and then hang onto them. */
-
- if (freeMsgIndex == NULL) {
-
- freeMsgIndex = (int *) stgMallocBytes(nPEs * sizeof(int), "prepareFreeMsgBuffers (Index)");
- freeMsgBuffer = (PP_) stgMallocBytes(nPEs * sizeof(long *), "prepareFreeMsgBuffers (Buffer)");
-
- for(i = 0; i < nPEs; i++) {
- if (i != thisPE) {
- freeMsgBuffer[i] = (P_) stgMallocWords(RtsFlags.ParFlags.packBufferSize,
- "prepareFreeMsgBuffers (Buffer #i)");
- }
- }
- }
-
- /* Initialize the freeMsg buffer pointers to point to the start of their buffers */
- for (i = 0; i < nPEs; i++)
- freeMsgIndex[i] = 0;
-}
-
-void
-freeRemoteGA(int pe, globalAddr *ga)
-{
- int i;
-
- ASSERT(GALAlookup(ga) == NULL);
-
- if ((i = freeMsgIndex[pe]) + 2 >= RtsFlags.ParFlags.packBufferSize) {
-#ifdef FREE_DEBUG
- fprintf(stderr, "Filled a free message buffer\n");
-#endif
- sendFree(ga->loc.gc.gtid, i, freeMsgBuffer[pe]);
- i = 0;
- }
- freeMsgBuffer[pe][i++] = (W_) ga->weight;
- freeMsgBuffer[pe][i++] = (W_) ga->loc.gc.slot;
- freeMsgIndex[pe] = i;
-#ifdef DEBUG
- ga->weight = 0x0f0f0f0f;
- ga->loc.gc.gtid = 0x666;
- ga->loc.gc.slot = 0xdeaddead;
-#endif
-}
-
-void
-sendFreeMessages(void)
-{
- int i;
-
- for (i = 0; i < nPEs; i++) {
- if (freeMsgIndex[i] > 0)
- sendFree(PEs[i], freeMsgIndex[i], freeMsgBuffer[i]);
- }
-}
-
-/* Process messaging code ripped out for the time being -- SDM & PWT */
-
-#ifdef 0
-/* These are the remaining message-processing functions from HLComms*/
-
-
-/*
- *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.
- */
-static void
-processFish(void)
-{
- GLOBAL_TASK_ID origPE;
- int age, history, hunger;
-
- unpackFish(&origPE, &age, &history, &hunger);
-
- if (origPE == mytid) {
- fishing = rtsFalse;
- } else {
- P_ spark;
-
- while ((spark = FindLocalSpark(rtsTrue)) != NULL) {
- W_ size;
- P_ graph;
-
- if ((graph = PackNearbyGraph(spark, &size)) == NULL) {
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
- SAVE_Hp -= PACK_HEAP_REQUIRED;
- /* Now go back and try again */
- } else {
- sendSchedule(origPE, size, graph);
- DisposeSpark(spark);
- break;
- }
- }
- if (spark == NULL) {
- /* We have no sparks to give */
- if (age < FISH_LIFE_EXPECTANCY)
- sendFish(choosePE(), origPE,
- (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
-
- /* Send it home to die */
- else
- sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
- }
- }
-} /* processFish */
-
-/*
- *processFetch either returns the requested data (if available)
- *or blocks the remote blocking queue on a black hole (if not).
- */
-static void
-processFetch(void)
-{
- globalAddr ga, rga;
- int load;
-
- P_ closure;
- P_ ip;
-
- unpackFetch(&ga, &rga, &load);
-#ifdef FETCH_DEBUG
- fprintf(stderr, "Rcvd Fetch for (%x, %d, 0), Resume (%x, %d, %x) (load %d) \n",
- ga.loc.gc.gtid, ga.loc.gc.slot,
- rga.loc.gc.gtid, rga.loc.gc.slot, rga.weight, load);
-#endif
-
- closure = GALAlookup(&ga);
- ip = (P_) INFO_PTR(closure);
-
- if (INFO_TYPE(ip) == INFO_FETCHME_TYPE) {
- /* Forward the Fetch to someone else */
- sendFetch(FETCHME_GA(closure), &rga, load);
- } else if (rga.loc.gc.gtid == mytid) {
- /* Our own FETCH forwarded back around to us */
- P_ fmbq = GALAlookup(&rga);
-
- /* We may have already discovered that the fetch target is our own. */
- if (fmbq != closure)
- CommonUp(fmbq, closure);
- (void) addWeight(&rga);
- } else if (IS_BLACK_HOLE(ip)) {
- /* This includes RBH's and FMBQ's */
- P_ bf;
-
- if ((bf = AllocateHeap(FIXED_HS + BF_CLOSURE_SIZE(dummy))) == NULL) {
- ReallyPerformThreadGC(FIXED_HS + BF_CLOSURE_SIZE(dummy), rtsFalse);
- closure = GALAlookup(&ga);
- bf = SAVE_Hp - (FIXED_HS + BF_CLOSURE_SIZE(dummy)) + 1;
- }
- ASSERT(GALAlookup(&rga) == NULL);
-
- SET_BF_HDR(bf, BF_info, bogosity);
- BF_NODE(bf) = closure;
- BF_GTID(bf) = (W_) rga.loc.gc.gtid;
- BF_SLOT(bf) = (W_) rga.loc.gc.slot;
- BF_WEIGHT(bf) = (W_) rga.weight;
- blockFetch(bf, closure);
-
-#ifdef FETCH_DEBUG
- fprintf(stderr, "Blocking Fetch (%x, %d, %x) on %#lx\n",
- rga.loc.gc.gtid, rga.loc.gc.slot, rga.weight, closure);
-#endif
-
- } else {
- /* The target of the FetchMe is some local graph */
- W_ size;
- P_ graph;
-
- if ((graph = PackNearbyGraph(closure, &size)) == NULL) {
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
- SAVE_Hp -= PACK_HEAP_REQUIRED;
- closure = GALAlookup(&ga);
- graph = PackNearbyGraph(closure, &size);
- ASSERT(graph != NULL);
- }
- sendResume(&rga, size, graph);
- }
-}
-
-/*
- *processFree unpacks a FREE message and adds the weights to our GAs.
- */
-static void
-processFree(void)
-{
- int nelem;
- static W_ *freeBuffer;
- int i;
- globalAddr ga;
-
- freeBuffer = gumPackBuffer;
- unpackFree(&nelem, freeBuffer);
-#ifdef FREE_DEBUG
- fprintf(stderr, "Rcvd Free (%d GAs)\n", nelem / 2);
-#endif
- ga.loc.gc.gtid = mytid;
- for (i = 0; i < nelem;) {
- ga.weight = (unsigned) freeBuffer[i++];
- ga.loc.gc.slot = (int) freeBuffer[i++];
-#ifdef FREE_DEBUG
- fprintf(stderr,"Processing free (%x, %d, %x)\n", ga.loc.gc.gtid,
- ga.loc.gc.slot, ga.weight);
-#endif
- (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.
- */
-
-static void
-processResume(GLOBAL_TASK_ID sender)
-{
- int nelem;
- W_ nGAs;
- static W_ *packBuffer;
- P_ newGraph;
- P_ old;
- globalAddr lga;
- globalAddr *gagamap;
-
- packBuffer = gumPackBuffer;
- unpackResume(&lga, &nelem, packBuffer);
-
-#ifdef RESUME_DEBUG
- fprintf(stderr, "Rcvd Resume for (%x, %d, %x)\n",
- lga.loc.gc.gtid, lga.loc.gc.slot, lga.weight);
- PrintPacket(packBuffer);
-#endif
-
- /*
- * 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];
- }
-
- /* Do this *after* GC; we don't want to release the object early! */
-
- if (lga.weight > 0)
- (void) addWeight(&lga);
-
- old = GALAlookup(&lga);
-
- if (RtsFlags.ParFlags.granSimStats) {
- P_ tso = NULL;
-
- if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE) {
- for(tso = (P_) FMBQ_ENTRIES(old);
- TSO_LINK(tso) != PrelBase_Z91Z93_closure;
- tso = TSO_LINK(tso))
- ;
- }
- /* DumpGranEventAndNode(GR_REPLY, tso, old, taskIDtoPE(sender)); */
- DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(sender),GR_REPLY,
- tso,old,0);
- }
-
- 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 (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE)
- CommonUp(old, newGraph);
-
-#ifdef RESUME_DEBUG
- DebugPrintGAGAMap(gagamap, nGAs);
-#endif
-
- 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.
- */
-static void
-processSchedule(GLOBAL_TASK_ID sender)
-{
- int nelem;
- int space_required;
- rtsBool success;
- static W_ *packBuffer;
- W_ nGAs;
- P_ newGraph;
- globalAddr *gagamap;
-
- packBuffer = gumPackBuffer; /* HWL */
- unpackSchedule(&nelem, packBuffer);
-
-#ifdef SCHEDULE_DEBUG
- fprintf(stderr, "Rcvd Schedule\n");
- PrintPacket(packBuffer);
-#endif
-
- /*
- * 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;
- }
- newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
- ASSERT(newGraph != NULL);
- success = Spark(newGraph, rtsFalse);
- ASSERT(success);
-
-#ifdef SCHEDULE_DEBUG
- DebugPrintGAGAMap(gagamap, nGAs);
-#endif
-
- if (nGAs > 0)
- sendAck(sender, nGAs, gagamap);
-
- fishing = rtsFalse;
-}
-
-/*
- *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.
- */
-static void
-processAck(void)
-{
- int nGAs;
- globalAddr *gaga;
-
- globalAddr gagamap[MAX_GAS * 2];
-
- unpackAck(&nGAs, gagamap);
-
-#ifdef ACK_DEBUG
- fprintf(stderr, "Rcvd Ack (%d pairs)\n", nGAs);
- DebugPrintGAGAMap(gagamap, nGAs);
-#endif
-
- /*
- * 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) {
- P_ old = GALAlookup(gaga);
- P_ new = GALAlookup(gaga + 1);
-
- if (new == NULL) {
- /* We don't have this closure, so we make a fetchme for it */
- globalAddr *ga = setRemoteGA(old, gaga + 1, rtsTrue);
-
- convertToFetchMe(old, 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, new);
-
- /*
- * 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);
- }
-}
-
-#endif
-
-#endif /* PAR -- whole file */
-
+++ /dev/null
-/***********************************************************************
-* 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 *
-************************************************************************/
-
-#ifndef __LLC_H
-#define __LLC_H
-#ifdef PAR
-
-#include "Rts.h"
-#include "Parallel.h"
-
-#include "PEOpCodes.h"
-#include "pvm3.h"
-
-#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 PECTLGROUP "PECTL"
-
-
-#define PETASK "PE"
-
-#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
-
-#define PutArg1(a) pvm_pklong(&(a),1,1)
-#define PutArg2(a) pvm_pklong(&(a),1,1)
-#define PutArgN(n,a) pvm_pklong(&(a),1,1)
-#define PutArgs(b,n) pvm_pklong(b,n,1)
-
-#define PutLit(l) { int a = l; PutArgN(?,a); }
-
-#define GetArg1(a) pvm_upklong(&(a),1,1)
-#define GetArg2(a) pvm_upklong(&(a),1,1)
-#define GetArgN(n,a) pvm_upklong(&(a),1,1)
-#define GetArgs(b,n) pvm_upklong(b,n,1)
-
-extern void SendOp (OPCODE,GLOBAL_TASK_ID),
- SendOp1 (OPCODE,GLOBAL_TASK_ID,StgWord),
- SendOp2 (OPCODE,GLOBAL_TASK_ID,StgWord,StgWord),
- SendOpV (OPCODE,GLOBAL_TASK_ID,int,...),
- SendOpN (OPCODE,GLOBAL_TASK_ID,int,StgPtr),
- SendOpNV (OPCODE,GLOBAL_TASK_ID,int,StgPtr,int,...);
-
-char *GetOpName (unsigned op);
-void NullException(void);
-
-PACKET WaitForPEOp (OPCODE op, GLOBAL_TASK_ID who);
-OPCODE Opcode (PACKET p);
-GLOBAL_TASK_ID Sender_Task (PACKET p);
-void get_opcode_and_sender (PACKET p, OPCODE *popcode, GLOBAL_TASK_ID *psender_id);
-GLOBAL_TASK_ID *PEStartUp (unsigned nPEs);
-void PEShutDown(void);
-void ProcessUnexpected (PACKET);
-
-#endif /*PAR */
-#endif /*defined __LLC_H */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- *
- * $Id: LLComms.c,v 1.3 1999/08/26 08:23:44 panne Exp $
- *
- * GUM Low-Level Inter-Task Communication
- *
- * This module defines PVM Routines for PE-PE communication.
- *
- * P. Trinder, December 5th. 1994.
- * Adapted for the new RTS, P. Trinder July 1998
- *
- ---------------------------------------------------------------------------- */
-
-#ifdef PAR /* whole file */
-
-/*
- *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.
- */
-
-#define NON_POSIX_SOURCE /* so says Solaris */
-
-#include "Rts.h"
-#include "RtsUtils.h"
-#include "Parallel.h"
-
-#include "LLC.h"
-#ifdef __STDC__
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#endif
-
-/*
- *Then some miscellaneous functions.
- *GetOpName returns the character-string name of any opcode.
- */
-
-char *UserPEOpNames[] = { PEOP_NAMES };
-
-char *
-GetOpName(nat op)
-{
- if (op >= MIN_PEOPS && op <= MAX_PEOPS)
- return (UserPEOpNames[op - MIN_PEOPS]);
-
- else
- return ("Unknown PE Opcode");
-}
-
-/*
- * trace_SendOp handles the tracing of messages.
- */
-
-static void
-trace_SendOp(OPCODE op, GLOBAL_TASK_ID dest STG_UNUSED,
- unsigned int data1 STG_UNUSED, unsigned int data2 STG_UNUSED)
-{
- char *OpName;
-
- OpName = GetOpName(op);
-/* fprintf(stderr, " %s [%x,%x] sent from %x to %x\n", OpName, data1, data2, mytid, dest);*/
-}
-
-/*
- *SendOp sends a 0-argument message with opcode {\em op} to
- *the global task {\em task}.
- */
-
-void
-SendOp(OPCODE op, GLOBAL_TASK_ID task)
-{
- trace_SendOp(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}.
- */
-
-void
-SendOp1(OPCODE op, GLOBAL_TASK_ID task, StgWord arg1)
-{
- trace_SendOp(op, task, arg1,0);
-
- pvm_initsend(PvmDataRaw);
- PutArg1(arg1);
- pvm_send( task, op );
-}
-
-
-/*
- *SendOp2 is used by the FP code only.
- */
-
-void
-SendOp2(OPCODE op, GLOBAL_TASK_ID task, StgWord arg1, StgWord arg2)
-{
- trace_SendOp(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);
- */
-
-void
-SendOpV(OPCODE op, GLOBAL_TASK_ID task, int n, ...)
-{
- va_list ap;
- int i;
- StgWord arg;
-
- va_start(ap, n);
-
- trace_SendOp(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.
- */
-
-void
-SendOpNV(OPCODE op, GLOBAL_TASK_ID task, int nelem,
- StgWord *datablock, int narg, ...)
-{
- va_list ap;
- int i;
- StgWord arg;
-
- va_start(ap, narg);
-
- trace_SendOp(op, task, 0, 0);
-/* fprintf(stderr,"SendOpNV: op = %x, task = %x, narg = %d, nelem = %d\n",op,task,narg,nelem); */
-
- pvm_initsend(PvmDataRaw);
-
- for (i = 0; i < narg; ++i) {
- arg = va_arg(ap, StgWord);
-/* 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);
- */
-
-void
-SendOpN(OPCODE op, GLOBAL_TASK_ID task, int n, StgPtr args)
-{
- long arg;
-
- trace_SendOp(op, task, 0, 0);
-
- pvm_initsend(PvmDataRaw);
- arg = (long) n;
- PutArgN(0, arg);
- PutArgs(args, n);
- pvm_send(task, op);
-}
-
-/*
- *WaitForPEOp waits for a packet from global task {\em who} with the
- *opcode {\em op}. Other opcodes are handled by processUnexpected.
- */
-PACKET
-WaitForPEOp(OPCODE op, GLOBAL_TASK_ID who)
-{
- PACKET p;
- int nbytes;
- OPCODE opcode;
- GLOBAL_TASK_ID sender_id;
- rtsBool match;
-
- do {
-#if 0
- fprintf(stderr,"WaitForPEOp: op = %x, who = %x\n",op,who);
-#endif
- while((p = pvm_recv(ANY_TASK,ANY_OPCODE)) < 0)
- pvm_perror("WaitForPEOp: Waiting for PEOp");
-
- pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
-#if 0
- fprintf(stderr,"WaitForPEOp: received: opcode = %x, sender_id = %x\n",opcode,sender_id);
-#endif
- match = (op == ANY_OPCODE || op == opcode) && (who == ANY_TASK || who == sender_id);
-
- if(match)
- return(p);
-
- /* Handle the unexpected opcodes */
- ProcessUnexpected(p);
-
- } while(rtsTrue);
-}
-
-/*
- *ProcessUnexpected processes unexpected messages. If the message is a
- *FINISH it exits the prgram, and PVM gracefully
- */
-void
-ProcessUnexpected(PACKET packet)
-{
- OPCODE opcode = Opcode(packet);
-
-#ifdef 0
- {
- GLOBAL_TASK_ID sender = Sender_Task(packet);
- fprintf(stderr,"ProcessUnexpected: Received %s (%x), sender %x\n",GetOpName(opcode),opcode,sender);
- }
-#endif
-
- 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)
- {
- GLOBAL_TASK_ID ErrorTask;
- int opcode;
-
- get_opcode_and_sender(packet,&opcode,&ErrorTask);
- fprintf(stderr,"Task %x: Unexpected opcode %x from %x in ProcessUnexpected\n",
- mytid, opcode, ErrorTask );
-
- stg_exit(EXIT_FAILURE);
- }
- }
-}
-
-OPCODE
-Opcode(PACKET p)
-{
- int nbytes;
- OPCODE opcode;
- GLOBAL_TASK_ID sender_id;
- pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
- return(opcode);
-}
-
-GLOBAL_TASK_ID
-Sender_Task(PACKET p)
-{
- int nbytes;
- OPCODE opcode;
- GLOBAL_TASK_ID sender_id;
- pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
- return(sender_id);
-}
-
-void
-get_opcode_and_sender(PACKET p, OPCODE *popcode, GLOBAL_TASK_ID *psender_id)
-{
- int nbytes;
- pvm_bufinfo( p, &nbytes, popcode, psender_id );
-}
-
-
-/*
- *PEStartUp does the low-level comms specific startup stuff for a
- *PE. It initialises the comms system, joins the appropriate groups,
- *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.
- */
-GLOBAL_TASK_ID *
-PEStartUp(nat nPEs)
-{
- int i;
- PACKET addr;
- long *buffer = (long *) stgMallocBytes(sizeof(long) * nPEs, "PEStartUp (buffer)");
- GLOBAL_TASK_ID *PEs
- = (GLOBAL_TASK_ID *) stgMallocBytes(sizeof(GLOBAL_TASK_ID) * nPEs, "PEStartUp (PEs)");
-
- mytid = _my_gtid; /* Initialise PVM and get task id into global var.*/
-
-/* fprintf(stderr,"PEStartup, Task id = [%x], No. PEs = %d \n", mytid, nPEs); */
- checkComms(pvm_joingroup(PEGROUP), "PEStartup");
-/* fprintf(stderr,"PEStartup, Joined PEGROUP\n"); */
- checkComms(pvm_joingroup(PECTLGROUP), "PEStartup");
-/* fprintf(stderr,"PEStartup, Joined PECTLGROUP\n"); */
- checkComms(pvm_barrier(PECTLGROUP, nPEs+1), "PEStartup");
-/* fprintf(stderr,"PEStartup, Passed PECTLGROUP barrier\n"); */
-
- addr = WaitForPEOp(PP_SYSMAN_TID, ANY_GLOBAL_TASK);
- SysManTask = Sender_Task(addr);
- if (IAmMainThread) { /* Main Thread Identifies itself to SysMan */
- pvm_initsend(PvmDataDefault);
- pvm_send(SysManTask, PP_MAIN_TASK);
- }
- addr = WaitForPEOp(PP_PETIDS, ANY_GLOBAL_TASK);
- GetArgs(buffer, nPEs);
- for (i = 0; i < nPEs; ++i) {
- PEs[i] = (GLOBAL_TASK_ID) buffer[i];
-#if 0
- fprintf(stderr,"PEs[%d] = %x \n", i, PEs[i]);
-#endif
- }
- free(buffer);
- return PEs;
-}
-
-/*
- *PEShutdown does the low-level comms-specific shutdown stuff for a
- *single PE. It leaves the groups and then exits from pvm.
- */
-void
-PEShutDown(void)
-{
- checkComms(pvm_lvgroup(PEGROUP),"PEShutDown");
- checkComms(pvm_lvgroup(PECTLGROUP),"PEShutDown");
- checkComms(pvm_exit(),"PEShutDown");
-}
-
-/*
-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;
-
-#endif /* PAR -- whole file */
-
+++ /dev/null
-#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 *
-* *
-************************************************************************/
-
-#define REPLY_OK 0x00
-
-/*Startup + Shutdown*/
-#define PP_SYSMAN_TID 0x50
-#define PP_MAIN_TASK 0x51
-#define PP_FINISH 0x52
-#define PP_PETIDS 0x53
-
-/* 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 MIN_PEOPS 0x50
-#define MAX_PEOPS 0x60
-
-#define PEOP_NAMES "Init", "IOInit", \
- "Finish", "PETIDS", \
- "Stats", "Stats_On", "Stats_Off", \
- "Fail", \
- "GCInit", "FullSystem", "GCPoll", \
- "Fetch","Resume","ACK","Fish","Schedule", \
- "Free"
-
-#endif /* PEOPCODES_H */
+++ /dev/null
-/****************************************************************************
-
-[ParInit.c] Initialising the parallel RTS
-
- P. Trinder, January 17th 1995.
- An extension based on Kevin Hammond's GRAPH for PVM version
- P. Trinder, July 1997.
- Adapted for the new RTS
-
-****************************************************************************/
-
-#ifdef PAR /* whole file */
-
-#define NON_POSIX_SOURCE /* so says Solaris */
-
-#include "Rts.h"
-#include <setjmp.h>
-#include "LLC.h"
-#include "HLC.h"
-
-/* Global conditions defined here. */
-
-rtsBool
- IAmMainThread = rtsFalse, /* Set for the main thread */
- GlobalStopPending = rtsFalse; /* Terminating */
-
-/* Task identifiers for various interesting global tasks. */
-
-GLOBAL_TASK_ID IOTask = 0, /* The IO Task Id */
- SysManTask = 0, /* The System Manager Task Id */
- mytid = 0; /* This PE's Task Id */
-
-REAL_TIME main_start_time; /* When the program started */
-REAL_TIME main_stop_time; /* When the program finished */
-jmp_buf exit_parallel_system; /* How to abort from the RTS */
-
-
-/* Flag handling. */
-
-#if 0
-rtsBool TraceSparks = rtsFalse; /* Enable the spark trace mode */
-rtsBool SparkLocally = rtsFalse; /* Use local threads if possible */
-rtsBool DelaySparks = rtsFalse; /* Use delayed sparking */
-rtsBool LocalSparkStrategy = rtsFalse; /* Either delayed threads or local threads*/
-rtsBool GlobalSparkStrategy = rtsFalse; /* Export all threads */
-
-rtsBool DeferGlobalUpdates = rtsFalse; /* Defer updating of global nodes */
-#endif
-
-rtsBool fishing = rtsFalse; /* We have no fish out in the stream */
-
-/* Initialisation Routines */
-
-/*
-par_exit defines how to terminate the program. If the exit code is
-non-zero (i.e. an error has occurred), the PE should not halt until
-outstanding error messages have been processed. Otherwise, messages
-might be sent to non-existent Task Ids. The infinite loop will actually
-terminate, since STG_Exception will call myexit\tr{(0)} when
-it received a PP_FINISH from the system manager task.
-*/
-
-void
-par_exit(I_ n) /* NB: "EXIT" is set to "myexit" for parallel world */
-{
- GlobalStopPending = rtsTrue;
- SendOp(PP_FINISH, SysManTask);
- if (n != 0)
- WaitForTermination();
- else
- WaitForPEOp(PP_FINISH, SysManTask);
- PEShutDown();
-/* fprintf(stderr,"PE %lx shutting down, %ld Threads run, %ld Sparks Ignored\n", (W_) mytid, threadId, sparksIgnored); */
- fprintf(stderr,"PE %lx shutting down, %ld Threads run\n", (W_) mytid, threadId);
-
- exit(n);
-}
-
-void srand48 (long);
-time_t time (time_t *);
-
-void
-initParallelSystem(void)
-{
- /* Don't buffer standard channels... */
- setbuf(stdout,NULL);
- setbuf(stderr,NULL);
-
- srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
- /* Used to select target of FISH message*/
- InitPackBuffer();
- InitMoreBuffers();
-}
-
-/*
- *SynchroniseSystem synchronises the reduction task with the system
- *manager, and initialises the Global address tables (LAGA & GALA)
- */
-
-GLOBAL_TASK_ID *PEs;
-
-void
-SynchroniseSystem(void)
-{
- int i;
-
- PEs = PEStartUp(nPEs);
-
- /* Initialize global address tables */
- initGAtables();
-
- /* Record the shortened the PE identifiers for LAGA etc. tables */
- for (i = 0; i < nPEs; ++i)
- registerTask(PEs[i]);
-
-}
-
-#endif /* PAR -- whole file */
-
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * ParInit.h,1
- *
- * Phil Trinder
- * July 1998
- *
- * External Parallel Initialisation Interface
- *
- * ---------------------------------------------------------------------------*/
-
-#ifndef PARINIT_H
-#define PARINIT_H
-
-extern void RunParallelSystem (P_);
-extern void initParallelSystem(void);
-extern void SynchroniseSystem(void);
-extern void par_exit(I_);
-
-#endif PARINIT_H
+++ /dev/null
-/************************************************************************
- * *
- * Runtime system types for GUM *
- * *
- ************************************************************************/
-
-#ifndef PARTYPES_H
-#define PARTYPES_H
-
-#ifdef PAR /* all of it */
-
-typedef struct hashtable HashTable;
-typedef struct hashlist HashList;
-
-typedef double REAL_TIME;
-typedef int GLOBAL_TASK_ID;
-typedef int PACKET;
-typedef int OPCODE;
-typedef W_ TIME;
-typedef GLOBAL_TASK_ID PROC;
-
-/* Global addresses, in all their glory */
-
-typedef struct {
- union {
- P_ plc;
- struct {
- GLOBAL_TASK_ID gtid;
- int slot;
- } gc;
- } loc;
- unsigned weight;
-} globalAddr;
-
-/* (GA, LA) pairs */
-typedef struct gala {
- globalAddr ga;
- P_ la;
- struct gala *next;
- rtsBool preferred;
-} GALA;
-
-#if defined(GRAN)
-typedef unsigned long TIME;
-typedef unsigned char PROC;
-typedef unsigned char EVTTYPE;
-#endif
-
-#endif /* PAR */
-
-#endif /* ! PARTYPES_H */
-
-
+++ /dev/null
-
-/************************************************************************
- * *
- * [Parallel.h]{Definitions for parallel machines}
- * *
- ************************************************************************/
-
-#ifndef Parallel_H
-#define Parallel_H
-
-/*
- * This section contains definitions applicable only to programs compiled
- * to run on a parallel machine.
- *
- * These basic definitions need to be around, one way or the other:
- */
-
-#include "ParTypes.h"
-
-# ifdef 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.
- */
-
-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);
-void SynchroniseSystem(void);
-
-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(void);
-W_ taskIDtoPE (GLOBAL_TASK_ID gtid);
-void RebuildLAGAtable(void);
-
-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);
-void *removeHashTable (HashTable *table, StgWord key, void *data);
-
-extern void par_exit (I_);
-#endif
-
-/************************************************************************
- * *
-[anti-parallel-SM]{But if we're {\em not} compiling for a parallel system...}
- * *
- ************************************************************************
- *
- *Get this out of the way. These are all null definitions.
- */
-
-#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) (*((P_)(closure)+PROCS_HDR_POSN))
-
-# define SET_PROCS(closure, procs) \
- PROCS(closure) = (W_)(procs) /* Set closure's location */
-# define SET_GRAN_HDR(closure,pe) SET_PROCS(closure,pe)
-
-# define SET_STATIC_PROCS(closure) , (W_) (Everywhere)
-
-# define SET_TASK_ACTIVITY(act) /* nothing */
-#endif
-
-/************************************************************************
- * *
- *[parallel-GAs]{Parallel-only part of fixed headers (global addresses)}
- * *
- ************************************************************************
- *
- *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(closure) getGA(closure)
-# define SET_GA(closure, ga) setGA(closure,ga)
-
-# define SET_STATIC_GA(closure)
-# 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:
- */
-
-# define SET_TASK_ACTIVITY(act)
-
-
-
-/************************************************************************
- * *
- *[parallel-heap-objs]{Special parallel-only heap objects (`closures')}
- * *
- ************************************************************************
- *
- * %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- * NB: The following definitons are BOTH for GUM and GrAnSim -- HWL
- * %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- *
- *The rest of this file contains definitions for {\it GUM and GrAnSim}.
- *Although we don't create FetchMe nodes in GrAnSim (we simulate it by
- *bitmask twiddling) we use FetchMe_info when converting nodes into RBHs
- *(mainly to keep the code as close to GUM as possible). So, we define all
- *the FetchMe related stuff in GrAnSim, too. % -- HWL
- *
- ************************************************************************
- * *
- * [FETCHME-closures]{@FETCHME@ heap objects (`closures')}
- * *
- ************************************************************************
-
- ... Zapped for now PWT ...
-*/
-
-
-/************************************************************************
- * *
- [parallel-pack-defs]{Parallel-only Packing definitions}
- * *
- ************************************************************************
- *
- *
- *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.
- */
-
-void InitPackBuffer(void);
-P_ PackTSO (P_ tso, W_ *size);
-P_ PackStkO (P_ stko, W_ *size);
-P_ AllocateHeap (W_ size); /* Doesn't belong */
-
-void InitClosureQueue (void);
-P_ DeQueueClosure(void);
-void QueueClosure (P_ closure);
-rtsBool QueueEmpty(void);
-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(void);
-
-P_ PackNearbyGraph (P_ closure,W_ *size);
-P_ UnpackGraph (W_ *buffer, globalAddr **gamap, W_ *nGAs);
-
-# define PACK_HEAP_REQUIRED \
- ((RTSflags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 2))
-
-extern W_ *PackBuffer; /* size: can be set via option */
-extern long *buffer; /* HWL_ */
-extern W_ *freeBuffer; /* HWL_ */
-extern W_ *packBuffer; /* HWL_ */
-
-extern void InitPackBuffer(void);
-extern void InitMoreBuffers(void);
-extern void InitPendingGABuffer(W_ size);
-extern void AllocClosureQueue(W_ size);
-
-# 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 */
-
-#if defined(GRAN)
-/* ToDo: Check which of the PAR routines are needed in GranSim -- HWL */
-void InitPackBuffer(void);
-P_ AllocateHeap (W_ size); /* Doesn't belong */
-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);
-void PrintPacket (P_ buffer);
-
-P_ get_closure_info (P_ closure, W_ *size, W_ *ptrs, W_ *nonptrs, W_ *vhs, char *type);
-
-/* 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 - PACK_HDR_SIZE) / (PACK_GA_SIZE \
- + _FHS) * (SPEC_HS + 2))
-
-# 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 */
-
-#endif /* PAR */
-#endif /* Parallel_H */
-
-
-
+++ /dev/null
-/****************************************************************************
-
- GUM System Manager Program
-
- The Parade/AQUA Projects, Glasgow University, 1994-1995.
- P. Trinder, November 30th. 1994.
- Adapted for new RTS
- P. Trinder, July 1997.
-
-
-****************************************************************************
-
-The Sysman task currently controls initiation, termination, of a
-parallel Haskell program running under GUM. In the future it may
-control global GC synchronisation and statistics gathering. Based on
-K. Hammond's SysMan.lc in Graph for PVM. SysMan is unusual in that it
-is not part of the executable produced by ghc: it is a free-standing
-program that spawns PVM tasks (logical PEs) to evaluate the
-program. After initialisation it runs in parallel with the PE tasks,
-awaiting messages.
-
-OK children, buckle down for some serious weirdness, it works like this ...
-
-
-o The argument vector (argv) for SysMan has one the following 2 shapes:
-
--------------------------------------------------------------------------------
-| SysMan path | debug flag | pvm-executable path | Num. PEs | Program Args ...|
--------------------------------------------------------------------------------
-
--------------------------------------------------------------------
-| SysMan path | pvm-executable path | Num. PEs | Program Args ... |
--------------------------------------------------------------------
-
-The "pvm-executable path" is an absolute path of where PVM stashes the
-code for each PE. The arguments passed on to each PE-executable
-spawned by PVM are:
-
--------------------------------
-| Num. PEs | Program Args ... |
--------------------------------
-
-The arguments passed to the Main-thread PE-executable are
-
--------------------------------------------------------------------
-| main flag | pvm-executable path | Num. PEs | Program Args ... |
--------------------------------------------------------------------
-
-o SysMan's algorithm is as follows.
-
-o use PVM to spawn (nPE-1) PVM tasks
-o fork SysMan to create the main-thread PE. This permits the main-thread to
-read and write to stdin and stdout.
-o Barrier-synchronise waiting for all of the PE-tasks to start.
-o Broadcast the SysMan task-id, so that the main thread knows it.
-o Wait for the Main-thread PE to send it's task-id.
-o Broadcast an array of the PE task-ids to all of the PE-tasks.
-o Enter a loop awaiting incoming messages, e.g. failure, Garbage-collection,
-termination.
-
-The forked Main-thread algorithm, in SysMan, is as follows.
-
-o disconnects from PVM.
-o sets a flag in argv to indicate that it is the main thread.
-o `exec's a copy of the pvm-executable (i.e. the program being run)
-
-
-The pvm-executable run by each PE-task, is initialised as follows.
-
-o Registers with PVM, obtaining a task-id.
-o Joins the barrier synchronisation awaiting the other PEs.
-o Receives and records the task-id of SysMan, for future use.
-o If the PE is the main thread it sends its task-id to SysMan.
-o Receives and records the array of task-ids of the other PEs.
-o Begins execution.
-
-***************************************************************************/
-
-#define NON_POSIX_SOURCE /* so says Solaris */
-
-#include "Rts.h"
-#include "ParTypes.h"
-#include "LLC.h"
-#include "Parallel.h"
-
-/*
- *The following definitions included so that SysMan can be linked with
- *Low Level Communications module (LLComms). They are not used in
- *SysMan.
- */
-
-GLOBAL_TASK_ID mytid, SysManTask;
-rtsBool IAmMainThread;
-rtsBool GlobalStopPending = rtsFalse; /* Handle Unexpexted messages correctly */
-
-static GLOBAL_TASK_ID gtids[MAX_PES];
-static long PEbuffer[MAX_PES];
-int nPEs = 0;
-static GLOBAL_TASK_ID sysman_id, sender_id, mainThread_id;
-static unsigned PEsTerminated = 0;
-static rtsBool Finishing = rtsFalse;
-
-/*
- * This reproduced from RtsUtlis to save linking with a whole ball of wax
- */
-stgMallocBytes (int n, char *msg)
-{
- char *space;
-
- if ((space = (char *) malloc((size_t) n)) == NULL) {
- fflush(stdout);
- fprintf(stderr,"stgMallocBytes failed: ", msg);
- stg_exit(EXIT_FAILURE);
- }
- return space;
-}
-
-#define checkerr(c) do {if((c)<0) { pvm_perror("Sysman"); exit(EXIT_FAILURE); }} while(0)
-
-main(int argc, char **argv)
-{
- int rbufid;
- int opcode, nbytes;
- char **pargv;
- int i, cc;
- int spawn_flag = PvmTaskDefault;
- PACKET addr;
-
- char *petask, *pvmExecutable;
-
- setbuf(stdout, NULL);
- setbuf(stderr, NULL);
-
- if (argc > 1) {
- if (*argv[1] == '-') {
- spawn_flag = PvmTaskDebug;
- argv[1] = argv[0];
- argv++; argc--;
- }
- sysman_id = pvm_mytid();/* This must be the first PVM call */
-
- checkerr(sysman_id);
-
- /*
- Get the full path and filename of the pvm executable (stashed in some
- PVM directory.
- */
- pvmExecutable = argv[1];
-
- nPEs = atoi(argv[2]);
-
- if ((petask = getenv(PETASK)) == NULL)
- petask = PETASK;
-
-#if 1
- fprintf(stderr, "nPEs (%s) = %d\n", petask, nPEs);
-#endif
-
- /* Check that we can create the number of PE and IMU tasks requested */
- if (nPEs > MAX_PES) {
- fprintf(stderr, "No more than %d PEs allowed (%d requested)\n", MAX_PES, nPEs);
- exit(EXIT_FAILURE);
- }
-
- /*
- Now create the PE Tasks. We spawn (nPEs-1) pvm threads: the Main Thread
- (which starts execution and performs IO) is created by forking SysMan
- */
- nPEs--;
- if (nPEs > 0) {
- /* Initialise the PE task arguments from Sysman's arguments */
- pargv = argv + 2;
-#if 1
- fprintf(stderr, "Spawning %d PEs(%s) ...\n", nPEs, petask);
- fprintf(stderr, " args: ");
- for (i = 0; pargv[i]; ++i)
- fprintf(stderr, "%s, ", pargv[i]);
- fprintf(stderr, "\n");
-#endif
- checkerr(pvm_spawn(petask, pargv, spawn_flag, "", nPEs, gtids));
- /*
- * Stash the task-ids of the PEs away in a buffer, once we know
- * the Main Thread's task-id, we'll broadcast them all.
- */
- for (i = 0; i < nPEs; i++)
- PEbuffer[i+1] = (long) gtids[i];
-#if 1
- fprintf(stderr, "Spawned /* PWT */\n");
-#endif
- }
-
- /*
- Create the MainThread PE by forking SysMan. This arcane coding
- is required to allow MainThread to read stdin and write to stdout.
- PWT 18/1/96
- */
- nPEs++; /* Record that the number of PEs is increasing */
- if ((cc = fork())) {
- checkerr(cc); /* Parent continues as SysMan */
-#if 1
- fprintf(stderr, "SysMan Task is [t%x]\n", sysman_id);
-#endif
- /*
- SysMan joins PECTLGROUP, so that it can wait (at the
- barrier sysnchronisation a few instructions later) for the
- other PE-tasks to start.
-
- The manager group (MGRGROUP) is vestigial at the moment. It
- may eventually include a statistics manager, and a (global)
- garbage collector manager.
- */
- checkerr(pvm_joingroup(PECTLGROUP));
-#if 1
- fprintf(stderr, "Joined PECTLGROUP /* PWT */\n");
-#endif
- /* Wait for all the PEs to arrive */
- checkerr(pvm_barrier(PECTLGROUP, nPEs + 1));
-#if 1
- fprintf(stderr, "PECTLGROUP barrier passed /* HWL */\n");
-#endif
- /* Broadcast SysMan's ID, so Main Thread PE knows it */
- pvm_initsend(PvmDataDefault);
- pvm_bcast(PEGROUP, PP_SYSMAN_TID);
-
- /* Wait for Main Thread to identify itself*/
- addr = WaitForPEOp(PP_MAIN_TASK, ANY_GLOBAL_TASK);
- pvm_bufinfo(addr, &nbytes, &opcode, &mainThread_id );
- PEbuffer[0] = mainThread_id;
-#if 1
- fprintf(stderr,"SysMan received Main Task = %x\n",mainThread_id);
-#endif
- /* Now that we have them all, broadcast Global Task Ids of all PEs */
- pvm_initsend(PvmDataDefault);
- PutArgs(PEbuffer, nPEs);
- pvm_bcast(PEGROUP, PP_PETIDS);
-#if 1
- fprintf(stderr, "Sysman successfully initialized!\n");
-#endif
- /* Process incoming messages */
- while (1) {
- if ((rbufid = pvm_recv(ANY_TASK, ANY_OPCODE)) < 0)
- pvm_perror("Sysman: Receiving Message");
- else {
- pvm_bufinfo(rbufid, &nbytes, &opcode, &sender_id);
-#if 1
- fprintf(stderr, "HWL-DBG(SysMan; main loop): rbufid=%x, nbytes = %d, opcode = %x, sender_id = %x\n",
- rbufid, nbytes, opcode, sender_id);
-#endif
- switch (opcode) {
- case PP_GC_INIT:
- /* This Function not yet implemented for GUM */
- fprintf(stderr, "Global GC from %x Not yet implemented for GUM!\n", sender_id);
- sync(PECTLGROUP, PP_FULL_SYSTEM);
- broadcast(PEGROUP, PP_GC_INIT);
-/* DoGlobalGC(); */
-/* broadcast(PEGROUP, PP_INIT); */
- break;
-
- case PP_STATS_ON:
- case PP_STATS_OFF:
- /* This Function not yet implemented for GUM */
- break;
-
- case PP_FINISH:
- if (!Finishing) {
- fprintf(stderr, "\nFinish from %x\n", sender_id);
- Finishing = rtsTrue;
- pvm_initsend(PvmDataDefault);
- pvm_bcast(PEGROUP, PP_FINISH);
- } else {
- ++PEsTerminated;
- }
- if (PEsTerminated >= nPEs) {
- broadcast(PEGROUP, PP_FINISH);
- broadcast(MGRGROUP, PP_FINISH);
- pvm_lvgroup(PECTLGROUP);
- pvm_lvgroup(MGRGROUP);
- pvm_exit();
- exit(EXIT_SUCCESS);
- }
- break;
-
- case PP_FAIL:
- fprintf(stderr, "Fail from %x\n", sender_id);
- if (!Finishing) {
- Finishing = rtsTrue;
- broadcast(PEGROUP, PP_FAIL);
- }
- break;
-
- default:
- {
-/* char *opname = GetOpName(opcode);
- fprintf(stderr,"Sysman: Unrecognised opcode %s (%x)\n",
- opname,opcode); */
- fprintf(stderr, "Sysman: Unrecognised opcode (%x)\n",
- opcode);
- }
- break;
- } /* switch */
- } /* else */
- } /* while 1 */
- } /* forked Sysman Process */
- else {
- pvmendtask(); /* Disconnect from PVM to avoid confusion: */
- /* executable reconnects */
- *argv[0] = '-'; /* Flag that this is the Main Thread PE */
- execv(pvmExecutable,argv); /* Parent task becomes Main Thread PE */
- }
- } /* argc > 1 */
-} /* main */
-
-/* Needed here because its used in loads of places like LLComms etc */
-
-void stg_exit(n)
-I_ n;
-{
- exit(n);
-}
projects / ghc-hetmet.git / commitdiff