ghc/runtime/gum/Unpack.lc

   1 %
   2 % (c) Parade/AQUA Projects, Glasgow University, 1995
   3 %     Kevin Hammond, February 15th. 1995
   4 %
   5 %     This is for GUM and GrAnSim.
   6 %
   7 %************************************************************************
   8 %*                                                                      *
   9 \section[Unpack.lc]{Unpacking closures which have been exported to remote processors}
  10 %*                                                                      *
  11 %************************************************************************
  12
  13 This module defines routines for unpacking closures in the parallel runtime
  14 system (GUM).
  15
  16 In the case of GrAnSim, this module defines routines for *simulating* the
  17 unpacking of closures as it is done in the parallel runtime system.
  18
  19 \begin{code}
  20 #include "rtsdefs.h"
  21
  22 #if defined(PAR)
  23
  24 EXTDATA_RO(FetchMe_info);
  25 \end{code}
  26
  27 Local Definitions.
  28
  29 \begin{code}
  30 static globalAddr *PendingGABuffer;  /* HWL; init in main; */
  31
  32 void
  33 InitPendingGABuffer(size)
  34 W_ size;
  35 {
  36   PendingGABuffer
  37     = (globalAddr *) stgMallocBytes((size-PACK_HDR_SIZE)*2*sizeof(globalAddr), "InitPendingGABuffer");
  38 }
  39 \end{code}
  40
  41 @CommonUp@ commons up two closures which we have discovered to be
  42 variants of the same object.  One is made an indirection to the other.
  43
  44 \begin{code}
  45 void
  46 CommonUp(P_ src, P_ dst)
  47 {
  48     P_ bqe;
  49
  50     ASSERT(src != dst);
  51     switch (INFO_TYPE(INFO_PTR(src))) {
  52     case INFO_SPEC_RBH_TYPE:
  53         bqe = (P_) SPEC_RBH_BQ(src);
  54         break;
  55     case INFO_GEN_RBH_TYPE:
  56         bqe = (P_) GEN_RBH_BQ(src);
  57         break;
  58     case INFO_FETCHME_TYPE:
  59         bqe = PrelBase_Z91Z93_closure;
  60         break;
  61     case INFO_FMBQ_TYPE:
  62         bqe = (P_) FMBQ_ENTRIES(src);
  63         break;
  64     default:
  65         /* Don't common up anything else */
  66         return;
  67
  68     }
  69     /* Note that UPD_IND does *not* awaken the bq */
  70     UPD_IND(src, dst);
  71     ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
  72     if (IS_MUTABLE(INFO_PTR(bqe)))
  73         AwakenBlockingQueue(bqe);
  74 }
  75
  76 \end{code}
  77
  78 @UnpackGraph@ unpacks the graph contained in a message buffer.  It
  79 returns a pointer to the new graph.  The @gamap@ parameter is set to
  80 point to an array of (oldGA,newGA) pairs which were created as a
  81 result of unpacking the buffer; @nGAs@ is set to the number of GA
  82 pairs which were created.
  83
  84 The format of graph in the pack buffer is as defined in @Pack.lc@.
  85
  86 \begin{code}
  87 P_
  88 UnpackGraph(buffer, gamap, nGAs)
  89 P_ buffer;
  90 globalAddr **gamap;
  91 W_ *nGAs;
  92 {
  93     W_ size, ptrs, nonptrs, vhs;
  94
  95     P_ bufptr = buffer + PACK_HDR_SIZE;
  96
  97     P_ slotptr;
  98
  99     globalAddr ga;
 100     P_ closure, existing;
 101     P_ ip, oldip;
 102
 103     W_ bufsize;
 104     P_ graphroot, graph, parent;
 105     W_ pptr = 0, pptrs = 0, pvhs;
 106     char str[80];
 107
 108     int i;
 109     globalAddr *gaga;
 110
 111     InitPackBuffer(); /* in case it isn't already init'd */
 112
 113     gaga = PendingGABuffer;
 114
 115     InitClosureQueue();
 116
 117     /* Unpack the header */
 118     bufsize = buffer[0];
 119
 120     /* allocate heap */
 121     if (bufsize > 0) {
 122         graph = AllocateHeap(bufsize);
 123         ASSERT(graph != NULL);
 124     }
 125
 126     parent = NULL;
 127
 128     do {
 129         /* This is where we will ultimately save the closure's address */
 130         slotptr = bufptr;
 131
 132         /* First, unpack the next GA or PLC */
 133         ga.weight = *bufptr++;
 134
 135         if (ga.weight > 0) {
 136             ga.loc.gc.gtid = *bufptr++;
 137             ga.loc.gc.slot = *bufptr++;
 138         } else
 139             ga.loc.plc = (P_) *bufptr++;
 140
 141         /* Now unpack the closure body, if there is one */
 142         if (isFixed(&ga)) {
 143           /* No more to unpack; just set closure to local address */
 144 #ifdef PACK_DEBUG
 145           fprintf(stderr, "Unpacked PLC at %x \n", ga.loc.plc);
 146 #endif
 147           closure = ga.loc.plc;
 148         } else if (isOffset(&ga)) {
 149             /* No more to unpack; just set closure to cached address */
 150             ASSERT(parent != NULL);
 151             closure = (P_) buffer[ga.loc.gc.slot];
 152         } else {
 153
 154             /* Now we have to build something. */
 155
 156           ASSERT(bufsize > 0);
 157
 158           /*
 159            * Close your eyes.  You don't want to see where we're looking. You
 160            * can't get closure info until you've unpacked the variable header,
 161            * but you don't know how big it is until you've got closure info.
 162            * So...we trust that the closure in the buffer is organized the
 163            * same way as they will be in the heap...at least up through the
 164            * end of the variable header.
 165            */
 166           ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
 167
 168           /* Fill in the fixed header */
 169           for (i = 0; i < FIXED_HS; i++)
 170             graph[i] = *bufptr++;
 171
 172           if (INFO_TYPE(ip) == INFO_FETCHME_TYPE)
 173             size = ptrs = nonptrs = vhs = 0;
 174
 175           /* Fill in the packed variable header */
 176           for (i = 0; i < vhs; i++)
 177             graph[FIXED_HS + i] = *bufptr++;
 178
 179           /* Pointers will be filled in later */
 180
 181           /* Fill in the packed non-pointers */
 182           for (i = 0; i < nonptrs; i++)
 183             graph[FIXED_HS + i + vhs + ptrs] = *bufptr++;
 184
 185           /* Indirections are never packed */
 186           ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
 187
 188           /* Add to queue for processing */
 189           QueueClosure(graph);
 190
 191           /*
 192            * Common up the new closure with any existing closure having the same
 193            * GA
 194            */
 195
 196           if ((existing = GALAlookup(&ga)) == NULL) {
 197             globalAddr *newGA;
 198             /* Just keep the new object */
 199 #ifdef PACK_DEBUG
 200             fprintf(stderr, "Unpacking new (%x, %d, %x)\n",
 201                     ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
 202 #endif
 203             closure = graph;
 204             newGA = setRemoteGA(graph, &ga, rtsTrue);
 205             if (INFO_TYPE(ip) == INFO_FETCHME_TYPE)
 206               FETCHME_GA(closure) = newGA;
 207           } else {
 208             /* Two closures, one global name.  Someone loses */
 209             oldip = (P_) INFO_PTR(existing);
 210
 211             if ((INFO_TYPE(oldip) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(oldip)) &&
 212                 INFO_TYPE(ip) != INFO_FETCHME_TYPE) {
 213
 214               /* What we had wasn't worth keeping */
 215               closure = graph;
 216               CommonUp(existing, graph);
 217             } else {
 218
 219               /*
 220                * Either we already had something worthwhile by this name or
 221                * the new thing is just another FetchMe.  However, the thing we
 222                * just unpacked has to be left as-is, or the child unpacking
 223                * code will fail.  Remember that the way pointer words are
 224                * filled in depends on the info pointers of the parents being
 225                * the same as when they were packed.
 226                */
 227 #ifdef PACK_DEBUG
 228               fprintf(stderr, "Unpacking old (%x, %d, %x), keeping %#lx\n",
 229                       ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight, existing);
 230 #endif
 231               closure = existing;
 232             }
 233             /* Pool the total weight in the stored ga */
 234             (void) addWeight(&ga);
 235           }
 236
 237           /* Sort out the global address mapping */
 238           if ((IS_THUNK(ip) && IS_UPDATABLE(ip)) ||
 239               (IS_MUTABLE(ip) && INFO_TYPE(ip) != INFO_FETCHME_TYPE)) {
 240             /* Make up new GAs for single-copy closures */
 241             globalAddr *newGA = MakeGlobal(closure, rtsTrue);
 242
 243             ASSERT(closure == graph);
 244
 245             /* Create an old GA to new GA mapping */
 246             *gaga++ = ga;
 247             splitWeight(gaga, newGA);
 248             ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
 249             gaga++;
 250           }
 251           graph += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
 252         }
 253
 254         /*
 255          * Set parent pointer to point to chosen closure.  If we're at the top of
 256          * the graph (our parent is NULL), then we want to arrange to return the
 257          * chosen closure to our caller (possibly in place of the allocated graph
 258          * root.)
 259          */
 260         if (parent == NULL)
 261             graphroot = closure;
 262         else
 263             parent[FIXED_HS + pvhs + pptr] = (W_) closure;
 264
 265         /* Save closure pointer for resolving offsets */
 266         *slotptr = (W_) closure;
 267
 268         /* Locate next parent pointer */
 269         pptr++;
 270         while (pptr + 1 > pptrs) {
 271             parent = DeQueueClosure();
 272
 273             if (parent == NULL)
 274                 break;
 275             else {
 276                 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
 277                                         &pvhs, str);
 278                 pptr = 0;
 279             }
 280         }
 281     } while (parent != NULL);
 282
 283     ASSERT(bufsize == 0 || graph - 1 <= SAVE_Hp);
 284
 285     *gamap = PendingGABuffer;
 286     *nGAs = (gaga - PendingGABuffer) / 2;
 287
 288     /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
 289     return (graphroot);
 290 }
 291 #endif  /* PAR */
 292 \end{code}
 293
 294 For GrAnSim:
 295 In general no actual unpacking should be necessary. We just have to walk
 296 over the graph and set the bitmasks appropriately. -- HWL
 297
 298 \begin{code}
 299 #if defined(GRAN)
 300 /* This code fakes the unpacking of a somewhat virtual buffer */
 301 P_
 302 UnpackGraph(buffer)
 303 P_ buffer;
 304 {
 305     W_ size, ptrs, nonptrs, vhs;
 306     P_ bufptr, closurestart;
 307     P_ slotptr;
 308     P_ closure, existing;
 309     P_ ip, oldip;
 310     W_ bufsize, unpackedsize;
 311     P_ graphroot, graph, parent;
 312     W_ pptr = 0, pptrs = 0, pvhs;
 313     char str[80];
 314     int i;
 315     P_ tso;
 316
 317     bufptr = buffer + PACK_HDR_SIZE;
 318     graphroot = *bufptr;
 319
 320 #  if defined(GRAN_CHECK) && defined(GRAN)  /* Just for testing */
 321     if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
 322       fprintf(stderr,"Qagh: no magic flag at start of packet @ 0x%lx\n",
 323                       buffer);
 324       EXIT(EXIT_FAILURE);
 325    }
 326 #  endif
 327
 328     tso = buffer[PACK_TSO_LOCN];
 329
 330     /* Unpack the header */
 331     unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
 332     bufsize = buffer[PACK_SIZE_LOCN];
 333
 334 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 335     if ( RTSflags.GranFlags.debug & 0x100 )
 336         fprintf(stderr,"\nUnpacking buffer @ 0x%x (root @ 0x%x, PE %d,size
 337 = %d), demanded by TSO 0x%x (%d)(PE %d)\n",
 338                 buffer,graphroot,where_is(graphroot), bufsize, tso, TSO_ID(tso), where_is(tso));
 339 #  endif
 340
 341     do {
 342         closurestart = bufptr;
 343         closure = *bufptr++;       /* that's all we need for GrAnSim -- HWL */
 344
 345         /* Actually only ip is needed; rest is useful for TESTING -- HWL */
 346         ip = get_closure_info(closure,
 347                               &size, &ptrs, &nonptrs, &vhs, str);
 348
 349 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 350         if ( RTSflags.GranFlags.debug & 0x100 )
 351             fprintf(stderr,"(0x%x): Bitmask changed [%s]: 0x%x ",
 352                     closure, (IS_NF(INFO_PTR(closure)) ? "NF" : "__"),
 353                     PROCS(closure));
 354 #  endif
 355
 356         if ( (INFO_TYPE(ip) == INFO_SPEC_RBH_TYPE) ||
 357              (INFO_TYPE(ip) == INFO_GEN_RBH_TYPE) ) {
 358             PROCS(closure) = PE_NUMBER(CurrentProc);          /* Move node */
 359 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 360             if ( RTSflags.GranFlags.debug & 0x100 ) {
 361                 fprintf(stderr," ---> 0x%x\n", PROCS(closure));
 362                 fprintf(stderr,"< Converting RBH @ 0x%x into an updatable
 363 closure again\n",
 364                       closure);
 365             }
 366 #  endif
 367             convertFromRBH(closure);  /* In GUM that's done by convertToFetchMe */
 368         } else if (IS_BLACK_HOLE(ip)) {
 369             PROCS(closure) |= PE_NUMBER(CurrentProc);         /* Copy node */
 370         } else if ( (PROCS(closure) & PE_NUMBER(CurrentProc)) == 0 ) {
 371           if (IS_NF(ip))                            /* Old: || IS_BQ(node) */
 372             PROCS(closure) |= PE_NUMBER(CurrentProc);         /* Copy node */
 373           else
 374             PROCS(closure) = PE_NUMBER(CurrentProc);          /* Move node */
 375         }
 376
 377 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 378         if ( RTSflags.GranFlags.debug & 0x100 )
 379           fprintf(stderr," ---> 0x%x\n",   PROCS(closure));
 380 #  endif
 381
 382     } while (bufptr<(buffer+bufsize)) ;   /*  (parent != NULL);  */
 383
 384     /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
 385     free(buffer);
 386
 387     return (graphroot);
 388 }
 389 #endif  /* GRAN */
 390 \end{code}
 391