From: simonmar Date: Fri, 3 Nov 2000 16:39:00 +0000 (+0000) Subject: [project @ 2000-11-03 16:39:00 by simonmar] X-Git-Tag: Approximately_9120_patches~3433 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a5c2bbbd58d9ef892f1f0f445c7520d6ccc5bc3e;p=ghc-hetmet.git [project @ 2000-11-03 16:39:00 by simonmar] Remove unused files. --- diff --git a/ghc/rts/gum/FetchMe.c b/ghc/rts/gum/FetchMe.c deleted file mode 100644 index 57dcd39..0000000 --- a/ghc/rts/gum/FetchMe.c +++ /dev/null @@ -1,91 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $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 */ diff --git a/ghc/rts/gum/FetchMe.h b/ghc/rts/gum/FetchMe.h deleted file mode 100644 index bc10cff..0000000 --- a/ghc/rts/gum/FetchMe.h +++ /dev/null @@ -1,15 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $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); - diff --git a/ghc/rts/gum/HLC.h b/ghc/rts/gum/HLC.h deleted file mode 100644 index 099e4c0..0000000 --- a/ghc/rts/gum/HLC.h +++ /dev/null @@ -1,42 +0,0 @@ -/******************************************************************** -* 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 */ diff --git a/ghc/rts/gum/HLComms.c b/ghc/rts/gum/HLComms.c deleted file mode 100644 index bc22fe2..0000000 --- a/ghc/rts/gum/HLComms.c +++ /dev/null @@ -1,992 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * $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 */ - diff --git a/ghc/rts/gum/LLC.h b/ghc/rts/gum/LLC.h deleted file mode 100644 index bd16a76..0000000 --- a/ghc/rts/gum/LLC.h +++ /dev/null @@ -1,78 +0,0 @@ -/*********************************************************************** -* 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 */ diff --git a/ghc/rts/gum/LLComms.c b/ghc/rts/gum/LLComms.c deleted file mode 100644 index e816f48..0000000 --- a/ghc/rts/gum/LLComms.c +++ /dev/null @@ -1,387 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * $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 -#else -#include -#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 */ - diff --git a/ghc/rts/gum/PEOpCodes.h b/ghc/rts/gum/PEOpCodes.h deleted file mode 100644 index 8380f46..0000000 --- a/ghc/rts/gum/PEOpCodes.h +++ /dev/null @@ -1,52 +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 * -* * -************************************************************************/ - -#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 */ diff --git a/ghc/rts/gum/ParInit.c b/ghc/rts/gum/ParInit.c deleted file mode 100644 index 2b49396..0000000 --- a/ghc/rts/gum/ParInit.c +++ /dev/null @@ -1,119 +0,0 @@ -/**************************************************************************** - -[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 -#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 */ - diff --git a/ghc/rts/gum/ParInit.h b/ghc/rts/gum/ParInit.h deleted file mode 100644 index add7ad9..0000000 --- a/ghc/rts/gum/ParInit.h +++ /dev/null @@ -1,19 +0,0 @@ -/* ----------------------------------------------------------------------------- - * 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 diff --git a/ghc/rts/gum/ParTypes.h b/ghc/rts/gum/ParTypes.h deleted file mode 100644 index 37a34ad..0000000 --- a/ghc/rts/gum/ParTypes.h +++ /dev/null @@ -1,53 +0,0 @@ -/************************************************************************ - * * - * 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 */ - - diff --git a/ghc/rts/gum/Parallel.h b/ghc/rts/gum/Parallel.h deleted file mode 100644 index be050dd..0000000 --- a/ghc/rts/gum/Parallel.h +++ /dev/null @@ -1,276 +0,0 @@ - -/************************************************************************ - * * - * [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 */ - - - diff --git a/ghc/rts/gum/SysMan.c b/ghc/rts/gum/SysMan.c deleted file mode 100644 index 89f89ea..0000000 --- a/ghc/rts/gum/SysMan.c +++ /dev/null @@ -1,319 +0,0 @@ -/**************************************************************************** - - 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); -}