ghc/rts/parallel/SysMan.c

   1 /* ----------------------------------------------------------------------------
   2    Time-stamp: <Tue Mar 21 2000 20:25:55 Stardate: [-30]4539.25 hwloidl>
   3    $Id: SysMan.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
   4
   5    GUM System Manager Program
   6    Handles startup, shutdown and global synchronisation of the parallel system.
   7
   8    The Parade/AQUA Projects, Glasgow University, 1994-1995.
   9    GdH/APART Projects, Heriot-Watt University, Edinburgh, 1997-1999.
  10    P. Trinder, November 30th. 1994.
  11    Adapted for new RTS
  12    P. Trinder, July 1997.
  13    H-W. Loidl, November 1999.
  14
  15    ------------------------------------------------------------------------- */
  16
  17 //@node GUM System Manager Program, , ,
  18 //@section GUM System Manager Program
  19
  20 //@menu
  21 //* General docu::
  22 //* Includes::
  23 //* Macros etc::
  24 //* Variables::
  25 //* Main fct::
  26 //* Auxiliary fcts::
  27 //* Index::
  28 //@end menu
  29
  30 //@node General docu, Includes, GUM System Manager Program, GUM System Manager Program
  31 //@subsection General docu
  32
  33 /*
  34
  35 The Sysman task currently controls initiation, termination, of a
  36 parallel Haskell program running under GUM. In the future it may
  37 control global GC synchronisation and statistics gathering. Based on
  38 K. Hammond's SysMan.lc in Graph for PVM. SysMan is unusual in that it
  39 is not part of the executable produced by ghc: it is a free-standing
  40 program that spawns PVM tasks (logical PEs) to evaluate the
  41 program. After initialisation it runs in parallel with the PE tasks,
  42 awaiting messages.
  43
  44 OK children, buckle down for some serious weirdness, it works like this ...
  45
  46
  47 o The argument vector (argv) for SysMan has one the following 2 shapes:
  48
  49 -------------------------------------------------------------------------------
  50 | SysMan path | debug flag | pvm-executable path | Num. PEs | Program Args ...|
  51 -------------------------------------------------------------------------------
  52
  53 -------------------------------------------------------------------
  54 | SysMan path | pvm-executable path | Num. PEs | Program Args ... |
  55 -------------------------------------------------------------------
  56
  57 The "pvm-executable path" is an absolute path of where PVM stashes the
  58 code for each PE. The arguments passed on to each PE-executable
  59 spawned by PVM are:
  60
  61 -------------------------------
  62 | Num. PEs | Program Args ... |
  63 -------------------------------
  64
  65 The arguments passed to the Main-thread PE-executable are
  66
  67 -------------------------------------------------------------------
  68 | main flag | pvm-executable path | Num. PEs | Program Args ... |
  69 -------------------------------------------------------------------
  70
  71 o SysMan's algorithm is as follows.
  72
  73 o use PVM to spawn (nPE-1) PVM tasks
  74 o fork SysMan to create the main-thread PE. This permits the main-thread to
  75 read and write to stdin and stdout.
  76 o Barrier-synchronise waiting for all of the PE-tasks to start.
  77 o Broadcast the SysMan task-id, so that the main thread knows it.
  78 o Wait for the Main-thread PE to send it's task-id.
  79 o Broadcast an array of the PE task-ids to all of the PE-tasks.
  80 o Enter a loop awaiting incoming messages, e.g. failure, Garbage-collection,
  81 termination.
  82
  83 The forked Main-thread algorithm, in SysMan, is as follows.
  84
  85 o disconnects from PVM.
  86 o sets a flag in argv to indicate that it is the main thread.
  87 o `exec's a copy of the pvm-executable (i.e. the program being run)
  88
  89
  90 The pvm-executable run by each PE-task, is initialised as follows.
  91
  92 o Registers with PVM, obtaining a task-id.
  93 o Joins the barrier synchronisation awaiting the other PEs.
  94 o Receives and records the task-id of SysMan, for future use.
  95 o If the PE is the main thread it sends its task-id to SysMan.
  96 o Receives and records the array of task-ids of the other PEs.
  97 o Begins execution.
  98
  99 */
 100
 101 //@node Includes, Macros etc, General docu, GUM System Manager Program
 102 //@subsection Includes
 103
 104 #include "Rts.h"
 105 #include "ParTypes.h"
 106 #include "LLC.h"
 107 #include "Parallel.h"
 108
 109 //@node Macros etc, Variables, Includes, GUM System Manager Program
 110 //@subsection Macros etc
 111
 112 #define NON_POSIX_SOURCE /* so says Solaris */
 113
 114 #define checkerr(c)     do { \
 115                           if ((c)<0) { \
 116                             pvm_perror("Sysman"); \
 117                             fprintf(stderr,"Sysman"); \
 118                             stg_exit(EXIT_FAILURE); \
 119                           } \
 120                         } while(0)
 121
 122 /* SysMan is put on top of the GHC routine that does the RtsFlags handling.
 123    So, we cannot use the standard macros. For the time being we use a macro
 124    that is fixed at compile time.
 125 */
 126 /* debugging enabled */
 127 #define IF_PAR_DEBUG(c,s)  { s; }
 128 /* debugging disabled */
 129 // #define IF_PAR_DEBUG(c,s)  /* nothing */
 130
 131 //@node Variables, Main fct, Macros etc, GUM System Manager Program
 132 //@subsection Variables
 133
 134 /*
 135    The following definitions included so that SysMan can be linked with Low
 136    Level Communications module (LLComms). They are not used in SysMan.  */
 137
 138 GlobalTaskId  mytid, SysManTask;
 139 rtsBool       IAmMainThread;
 140 rtsBool       GlobalStopPending = rtsFalse;
 141               /* Handle unexpected messages correctly */
 142
 143 static           GlobalTaskId gtids[MAX_PES];
 144 static           GlobalTaskId sysman_id, sender_id, mainThread_id;
 145 static unsigned  PEsTerminated = 0;
 146 static rtsBool   Finishing = rtsFalse;
 147 static long      PEbuffer[MAX_PES];
 148 nat              nPEs = 0;
 149
 150 //@node Main fct, Auxiliary fcts, Variables, GUM System Manager Program
 151 //@subsection Main fct
 152
 153 //@cindex main
 154 main (int argc, char **argv) {
 155   int rbufid;
 156   int opcode, nbytes;
 157   char **pargv;
 158   int i, cc, spawn_flag = PvmTaskDefault;
 159   char *petask, *pvmExecutable;
 160   rtsPacket addr;
 161
 162   setbuf(stdout, NULL);  // disable buffering of stdout
 163   setbuf(stderr, NULL);  // disable buffering of stderr
 164
 165   if (argc > 1) {
 166     if (*argv[1] == '-') {
 167       spawn_flag = PvmTaskDebug;
 168       argv[1] = argv[0];
 169       argv++; argc--;
 170     }
 171     sysman_id = pvm_mytid();  /* This must be the first PVM call */
 172
 173     checkerr(sysman_id);
 174
 175     /*
 176        Get the full path and filename of the pvm executable (stashed in some
 177        PVM directory), and the number of PEs from the command line.
 178     */
 179     pvmExecutable = argv[1];
 180     nPEs = atoi(argv[2]);
 181
 182     if ((petask = getenv(PETASK)) == NULL)  // PETASK set by driver
 183       petask = PETASK;
 184
 185     IF_PAR_DEBUG(verbose,
 186                  fprintf(stderr,"== [%x] nPEs (%s) = %d\n",
 187                          sysman_id, petask, nPEs));
 188
 189     /* Check that we can create the number of PE and IMU tasks requested */
 190     if (nPEs > MAX_PES) {
 191       fprintf(stderr,"SysMan: No more than %d PEs allowed (%d requested)\n",
 192            MAX_PES, nPEs);
 193       stg_exit(EXIT_FAILURE);
 194     }
 195     /*
 196        Now create the PE Tasks. We spawn (nPEs-1) pvm threads: the Main Thread
 197        (which starts execution and performs IO) is created by forking SysMan
 198     */
 199     nPEs--;
 200     if (nPEs > 0) {
 201       /* Initialise the PE task arguments from Sysman's arguments */
 202       pargv = argv + 2;
 203
 204       IF_PAR_DEBUG(verbose,
 205                    fprintf(stderr, "== [%x] Spawning %d PEs(%s) ...\n",
 206                            sysman_id, nPEs, petask);
 207                    fprintf(stderr, "  args: ");
 208                    for (i = 0; pargv[i]; ++i)
 209                      fprintf(stderr, "%s, ", pargv[i]);
 210                    fprintf(stderr, "\n"));
 211
 212       checkerr(pvm_spawn(petask, pargv, spawn_flag, "", nPEs, gtids));
 213       /*
 214        * Stash the task-ids of the PEs away in a buffer, once we know
 215        * the Main Thread's task-id, we'll broadcast them all.
 216        */
 217       for (i = 0; i < nPEs; i++)
 218         PEbuffer[i+1] = (long) gtids[i];
 219
 220       IF_PAR_DEBUG(verbose,
 221                    fprintf(stderr,"== [%x] Spawned\n", sysman_id));
 222     }
 223
 224     /*
 225        Create the MainThread PE by forking SysMan. This arcane coding
 226        is required to allow MainThread to read stdin and write to stdout.
 227        PWT 18/1/96
 228     */
 229     nPEs++;                /* Record that the number of PEs is increasing */
 230     if ((cc = fork())) {
 231       checkerr(cc);        /* Parent continues as SysMan */
 232       IF_PAR_DEBUG(verbose,
 233                    fprintf(stderr,"== [%x] SysMan Task is [t%x]\n", sysman_id));
 234
 235       /*
 236         SysMan joins PECTLGROUP, so that it can wait (at the
 237         barrier sysnchronisation a few instructions later) for the
 238         other PE-tasks to start.
 239
 240         The manager group (MGRGROUP) is vestigial at the moment. It
 241         may eventually include a statistics manager, and a (global)
 242         garbage collector manager.
 243       */
 244       checkerr(pvm_joingroup(PECTLGROUP));
 245       IF_PAR_DEBUG(verbose,
 246                    fprintf(stderr,"== [%x] Joined PECTLGROUP \n", sysman_id));
 247
 248       /* Wait for all the PEs to arrive */
 249       checkerr(pvm_barrier(PECTLGROUP, nPEs + 1));
 250
 251       IF_PAR_DEBUG(verbose,
 252                    fprintf(stderr,"== [%x] PECTLGROUP  barrier passed \n",
 253                            sysman_id));
 254
 255       /* Broadcast SysMan's ID, so Main Thread PE knows it */
 256       pvm_initsend(PvmDataDefault);
 257       pvm_bcast(PEGROUP, PP_SYSMAN_TID);
 258
 259       /* Wait for Main Thread to identify itself*/
 260       addr = waitForPEOp(PP_MAIN_TASK, ANY_GLOBAL_TASK);
 261       pvm_bufinfo(addr, &nbytes, &opcode, &mainThread_id);
 262       PEbuffer[0] = mainThread_id;
 263
 264       IF_PAR_DEBUG(verbose,
 265                    fprintf(stderr,"== [%x] SysMan received Main Task = %x\n",
 266                            sysman_id, mainThread_id));
 267
 268       /* Now that we have them all, broadcast Global Task Ids of all PEs */
 269       pvm_initsend(PvmDataDefault);
 270       PutArgs(PEbuffer, nPEs);
 271       pvm_bcast(PEGROUP, PP_PETIDS);
 272
 273       IF_PAR_DEBUG(verbose,
 274                    fprintf(stderr,"== [%x] Sysman successfully initialized!\n",
 275                            sysman_id));
 276
 277 //@cindex message handling loop
 278       /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
 279       /* Main message handling loop                                         */
 280       /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
 281       /* Process incoming messages */
 282       while (1) {
 283         if ((rbufid = pvm_recv(ANY_TASK, ANY_OPCODE)) < 0)
 284           pvm_perror("Sysman: Receiving Message");
 285         else {
 286           pvm_bufinfo(rbufid, &nbytes, &opcode, &sender_id);
 287
 288           /*
 289           IF_PAR_DEBUG(trace,
 290                        fprintf(stderr,"== [%x] SysMan: Message received by SysMan: rbufid=%x, nbytes = %d, opcode = %x, sender_id = %x\n",
 291                              sysman_id, rbufid, nbytes, opcode, sender_id));
 292           */
 293           switch (opcode) {
 294           case PP_GC_INIT:
 295             /* This Function not yet implemented for GUM */
 296             fprintf(stderr,"Global GC from %x Not yet implemented for GUM!\n",
 297                   sender_id);
 298             sync(PECTLGROUP, PP_FULL_SYSTEM);
 299             broadcast(PEGROUP, PP_GC_INIT);
 300             /*                DoGlobalGC();                */
 301             /*                broadcast(PEGROUP, PP_INIT); */
 302             break;
 303
 304           case PP_STATS_ON:
 305             fprintf(stderr,"PP_STATS_ON (from %x) not yet implemented for GUM!\n",
 306                   sender_id);
 307             break;
 308
 309           case PP_STATS_OFF:
 310             fprintf(stderr,"PP_STATS_OFF (from %x) not yet implemented for GUM!\n",
 311                   sender_id);
 312             break;
 313
 314           case PP_FINISH:
 315             IF_PAR_DEBUG(verbose,
 316                          fprintf(stderr,"== [%x] Finish from %x\n",
 317                                  sysman_id, sender_id));
 318             if (!Finishing) {
 319               Finishing = rtsTrue;
 320               PEsTerminated = 1;
 321               pvm_initsend(PvmDataDefault);
 322               pvm_bcast(PEGROUP, PP_FINISH);
 323             } else {
 324               ++PEsTerminated;
 325             }
 326             if (PEsTerminated >= nPEs) {
 327               IF_PAR_DEBUG(verbose,
 328                            fprintf(stderr,"== [%x] Global Shutdown, Goodbye!! (SysMan has received FINISHes from all PEs)\n",
 329                                    sysman_id));
 330               broadcast(PEGROUP, PP_FINISH);
 331               broadcast(MGRGROUP, PP_FINISH);
 332               pvm_lvgroup(PECTLGROUP);
 333               pvm_lvgroup(MGRGROUP);
 334               pvm_exit();
 335               exit(EXIT_SUCCESS);
 336               /* Qapla'! */
 337             }
 338             break;
 339
 340           case PP_FAIL:
 341             IF_PAR_DEBUG(verbose,
 342                          fprintf(stderr,"== [%x] Fail from %x\n",
 343                                  sysman_id, sender_id));
 344             if (!Finishing) {
 345               Finishing = rtsTrue;
 346               broadcast(PEGROUP, PP_FAIL);
 347             }
 348             break;
 349
 350           default:
 351             {
 352              /*
 353               char *opname = GetOpName(opcode);
 354               fprintf(stderr,"Sysman: Unrecognised opcode %s (%x)\n",
 355                               opname,opcode);   */
 356               fprintf(stderr,"Qagh: Sysman: Unrecognised opcode (%x)\n",
 357                     opcode);
 358             }
 359             break;
 360           }     /* switch */
 361         }               /* else */
 362       }         /* while 1 */
 363     }                   /* forked Sysman Process */
 364     else {
 365       fprintf(stderr, "Main Thread PE has been forked; doing an execv(%s,...)\n",
 366               pvmExecutable);
 367       pvmendtask();              /* Disconnect from PVM to avoid confusion: */
 368       /* executable reconnects  */
 369       *argv[0] = '-';            /* Flag that this is the Main Thread PE */
 370       execv(pvmExecutable,argv); /* Parent task becomes Main Thread PE */
 371     }
 372   }                     /* argc > 1 */
 373 }                       /* main */
 374
 375 //@node Auxiliary fcts, Index, Main fct, GUM System Manager Program
 376 //@subsection Auxiliary fcts
 377
 378 /*
 379  * This reproduced from RtsUtlis to save linking with a whole ball of wax
 380  */
 381 /* result-checking malloc wrappers. */
 382
 383 //@cindex stgMallocBytes
 384
 385 void *
 386 stgMallocBytes (int n, char *msg)
 387 {
 388     char *space;
 389
 390     if ((space = (char *) malloc((size_t) n)) == NULL) {
 391         fflush(stdout);
 392         fprintf(stderr, msg);
 393         // MallocFailHook((W_) n, msg); /*msg*/
 394         stg_exit(EXIT_FAILURE);
 395     }
 396     return space;
 397 }
 398
 399 /* Needed here because its used in loads of places like LLComms etc */
 400
 401 //@cindex stg_exit
 402
 403 void stg_exit(n)
 404 I_ n;
 405 {
 406     exit(n);
 407 }
 408
 409 //@node Index,  , Auxiliary fcts, GUM System Manager Program
 410 //@subsection Index
 411
 412 //@index
 413 //* main::  @cindex\s-+main
 414 //* message handling loop::  @cindex\s-+message handling loop
 415 //* stgMallocBytes::  @cindex\s-+stgMallocBytes
 416 //* stg_exit::  @cindex\s-+stg_exit
 417 //@end index