ghc/runtime/main/Threads.lc

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[Threads.lc]{Thread Control Routines}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 %************************************************************************
  11 %
  12 \subsection[thread-overview]{Overview of the Thread Management System}
  13 %
  14 %************************************************************************
  15
  16 %************************************************************************
  17 %
  18 \subsection[thread-decls]{Thread Declarations}
  19 %
  20 %************************************************************************
  21
  22 % I haven't checked if GRAN can work with QP profiling. But as we use our
  23 % own profiling (GR profiling) that should be irrelevant. -- HWL
  24
  25 \begin{code}
  26
  27 #if defined(CONCURRENT) /* the whole module! */
  28
  29 # define NON_POSIX_SOURCE /* so says Solaris */
  30
  31 # include "rtsdefs.h"
  32 # include <setjmp.h>
  33
  34 #include "LLC.h"
  35 #include "HLC.h"
  36
  37 static void init_qp_profiling(STG_NO_ARGS); /* forward decl */
  38 \end{code}
  39
  40 @AvailableStack@ is used to determine whether an existing stack can be
  41 reused without new allocation, so reducing garbage collection, and
  42 stack setup time.  At present, it is only used for the first stack
  43 chunk of a thread, the one that's got
  44 @RTSflags.ConcFlags.stkChunkSize@ words.
  45
  46 \begin{code}
  47 P_ AvailableStack = Prelude_Z91Z93_closure;
  48 P_ AvailableTSO = Prelude_Z91Z93_closure;
  49 \end{code}
  50
  51 Macros for dealing with the new and improved GA field for simulating
  52 parallel execution. Based on @CONCURRENT@ package. The GA field now
  53 contains a mask, where the n-th bit stands for the n-th processor,
  54 on which this data can be found. In case of multiple copies, several bits
  55 are set.  The total number of processors is bounded by @MAX_PROC@,
  56 which should be <= the length of a word in bits.  -- HWL
  57
  58 {{GranSim.lc}Daq ngoq' roQlu'ta'}
  59 (Code has been moved to GranSim.lc).
  60
  61 %****************************************************************
  62 %*                                                              *
  63 \subsection[thread-getthread]{The Thread Scheduler}
  64 %*                                                              *
  65 %****************************************************************
  66
  67 This is the heart of the thread scheduling code.
  68
  69 Most of the changes for GranSim are in this part of the RTS.
  70 Especially the @ReSchedule@ routine has been blown up quite a lot
  71 It now contains the top-level event-handling loop.
  72
  73 Parts of the code that are not necessary for GranSim, but convenient to
  74 have when developing it are marked with a @GRAN_CHECK@ variable.
  75
  76 \begin{code}
  77 STGRegisterTable *CurrentRegTable = NULL;
  78 P_ CurrentTSO = NULL;
  79
  80 #if defined(GRAN)
  81
  82 /* Only needed for GranSim Light; costs of operations during rescheduling
  83    are associated to the virtual processor on which ActiveTSO is living */
  84 P_ ActiveTSO = NULL;
  85 rtsBool             resched = rtsFalse;  /* debugging only !!*/
  86
  87 /* Pointers to the head and tail of the runnable queues for each PE */
  88 /* In GranSim Light only the thread/spark-queues of proc 0 are used */
  89 P_ RunnableThreadsHd[MAX_PROC];
  90 P_ RunnableThreadsTl[MAX_PROC];
  91
  92 P_ WaitThreadsHd[MAX_PROC];
  93 P_ WaitThreadsTl[MAX_PROC];
  94
  95 sparkq PendingSparksHd[MAX_PROC][SPARK_POOLS];
  96 sparkq PendingSparksTl[MAX_PROC][SPARK_POOLS];
  97
  98 /* One clock for each PE */
  99 W_ CurrentTime[MAX_PROC];
 100
 101 /* Useful to restrict communication; cf fishing model in GUM */
 102 I_ OutstandingFetches[MAX_PROC], OutstandingFishes[MAX_PROC];
 103
 104 /* Status of each PE (new since but independent of GranSim Light) */
 105 enum proc_status procStatus[MAX_PROC];
 106
 107 #if defined(GRAN) && defined(GRAN_CHECK)
 108 /* To check if the RTS ever tries to run a thread that should be blocked
 109    because of fetching remote data */
 110 P_ BlockedOnFetch[MAX_PROC];
 111 #endif
 112
 113 W_ SparksAvail = 0;     /* How many sparks are available */
 114 W_ SurplusThreads = 0;  /* How many excess threads are there */
 115
 116 TIME SparkStealTime();
 117
 118 # else                                                            /* !GRAN */
 119
 120 P_ RunnableThreadsHd = Prelude_Z91Z93_closure;
 121 P_ RunnableThreadsTl = Prelude_Z91Z93_closure;
 122
 123 P_ WaitingThreadsHd = Prelude_Z91Z93_closure;
 124 P_ WaitingThreadsTl = Prelude_Z91Z93_closure;
 125
 126 TYPE_OF_SPARK PendingSparksBase[SPARK_POOLS];
 127 TYPE_OF_SPARK PendingSparksLim[SPARK_POOLS];
 128
 129 TYPE_OF_SPARK PendingSparksHd[SPARK_POOLS];
 130 TYPE_OF_SPARK PendingSparksTl[SPARK_POOLS];
 131
 132 #endif                                                      /* GRAN ; HWL */
 133
 134 static jmp_buf scheduler_loop;
 135
 136 I_ required_thread_count = 0;
 137 I_ advisory_thread_count = 0;
 138
 139 EXTFUN(resumeThread);
 140
 141 /* Misc prototypes */
 142 #if defined(GRAN)
 143 P_ NewThread PROTO((P_, W_, I_));
 144 I_ blockFetch PROTO((P_, PROC, P_));
 145 I_ HandleFetchRequest PROTO((P_, PROC, P_));
 146 rtsBool InsertThread PROTO((P_ tso));
 147 sparkq delete_from_spark_queue PROTO((sparkq, sparkq));
 148 sparkq prev, spark;
 149 #else
 150 P_ NewThread PROTO((P_, W_));
 151 #endif
 152
 153 I_ context_switch = 0;
 154 I_ contextSwitchTime = 10000;
 155
 156 I_ threadId = 0;
 157
 158 /* NB: GRAN and GUM use different representations of spark pools.
 159        GRAN sparks are more flexible (containing e.g. granularity info)
 160        but slower than GUM sparks. There is no fixed upper bound on the
 161        number of GRAN sparks either. -- HWL
 162 */
 163 #if !defined(GRAN)
 164
 165 I_ sparksIgnored =0;
 166
 167 I_ SparkLimit[SPARK_POOLS];
 168
 169 rtsBool
 170 initThreadPools(STG_NO_ARGS)
 171 {
 172     I_ i, size = RTSflags.ConcFlags.maxLocalSparks;
 173
 174     SparkLimit[ADVISORY_POOL] = SparkLimit[REQUIRED_POOL] = size;
 175
 176     if ((PendingSparksBase[ADVISORY_POOL] = (TYPE_OF_SPARK) malloc(size * SIZE_OF_SPARK)) == NULL)
 177         return rtsFalse;
 178
 179     if ((PendingSparksBase[REQUIRED_POOL] = (TYPE_OF_SPARK) malloc(size * SIZE_OF_SPARK)) == NULL)
 180         return rtsFalse;
 181     PendingSparksLim[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL] + size;
 182     PendingSparksLim[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL] + size;
 183     return rtsTrue;
 184
 185 }
 186 #endif  /* !GRAN */
 187
 188 #ifdef PAR
 189 rtsBool sameThread;
 190 #endif
 191
 192 void
 193 ScheduleThreads(topClosure)
 194 P_ topClosure;
 195 {
 196 #ifdef GRAN
 197     I_ i;
 198 #endif
 199     P_ tso;
 200
 201 #if defined(PROFILING) || defined(PAR)
 202     if (time_profiling || RTSflags.ConcFlags.ctxtSwitchTime > 0) {
 203         if (initialize_virtual_timer(RTSflags.CcFlags.msecsPerTick)) {
 204 #else
 205     if (RTSflags.ConcFlags.ctxtSwitchTime > 0) {
 206         if (initialize_virtual_timer(RTSflags.ConcFlags.ctxtSwitchTime)) {
 207 #endif
 208             fflush(stdout);
 209             fprintf(stderr, "Can't initialize virtual timer.\n");
 210             EXIT(EXIT_FAILURE);
 211         }
 212     } else
 213         context_switch = 0 /* 1 HWL */;
 214
 215 #  if defined(GRAN_CHECK) && defined(GRAN)                           /* HWL */
 216     if ( RTSflags.GranFlags.Light && RTSflags.GranFlags.proc!=1 ) {
 217       fprintf(stderr,"Qagh: In GrAnSim Light setup .proc must be 1\n");
 218       EXIT(EXIT_FAILURE);
 219     }
 220
 221     if ( RTSflags.GranFlags.debug & 0x40 ) {
 222       fprintf(stderr,"Doing init in ScheduleThreads now ...\n");
 223     }
 224 #  endif
 225
 226 #if defined(GRAN)                                                     /* KH */
 227     /* Init thread and spark queues on all processors */
 228     for (i=0; i<RTSflags.GranFlags.proc; i++)
 229       {
 230         /* Init of RunnableThreads{Hd,Tl} etc now in main */
 231         OutstandingFetches[i] = OutstandingFishes[i] = 0;
 232         procStatus[i] = Idle;
 233 # if defined(GRAN_CHECK) && defined(GRAN)                           /* HWL */
 234         BlockedOnFetch[i] = NULL;
 235 # endif
 236       }
 237
 238     CurrentProc = MainProc;
 239 #endif /* GRAN */
 240
 241     if (DO_QP_PROF)
 242         init_qp_profiling();
 243     /*
 244      * We perform GC so that a signal handler can install a new
 245      * TopClosure and start a new main thread.
 246      */
 247 #ifdef PAR
 248     if (IAmMainThread) {
 249 #endif
 250 #if defined(GRAN)
 251     if ((tso = NewThread(topClosure, T_MAIN, MAIN_PRI)) == NULL) {
 252 #else
 253     if ((tso = NewThread(topClosure, T_MAIN)) == NULL) {
 254 #endif
 255         /* kludge to save the top closure as a root */
 256         CurrentTSO = topClosure;
 257         ReallyPerformThreadGC(0, rtsTrue);
 258         topClosure = CurrentTSO;
 259 #if defined(GRAN)
 260         if ((tso = NewThread(topClosure, T_MAIN, MAIN_PRI)) == NULL) {
 261 #else
 262         if ((tso = NewThread(topClosure, T_MAIN)) == NULL) {
 263 #endif
 264             fflush(stdout);
 265             fprintf(stderr, "Not enough heap for main thread\n");
 266             EXIT(EXIT_FAILURE);
 267         }
 268     }
 269 #if !defined(GRAN)
 270     RunnableThreadsHd = RunnableThreadsTl = tso;
 271 #else
 272     /* NB: CurrentProc must have been set to MainProc before that! -- HWL */
 273     ThreadQueueHd = ThreadQueueTl = tso;
 274
 275 # if defined(GRAN_CHECK)
 276     if ( RTSflags.GranFlags.debug & 0x40 ) {
 277       fprintf(stderr,"MainTSO has been initialized (0x%x)\n", tso);
 278     }
 279 # endif
 280 #endif /* GRAN */
 281
 282 #ifdef PAR
 283     if (RTSflags.ParFlags.granSimStats) {
 284         DumpGranEvent(GR_START, tso);
 285         sameThread = rtsTrue;
 286     }
 287 #elif defined(GRAN)
 288     if (RTSflags.GranFlags.granSimStats && !RTSflags.GranFlags.labelling)
 289         DumpRawGranEvent(CurrentProc,(PROC)0,GR_START,
 290                          tso,topClosure,0);
 291 #endif
 292
 293 #if defined(GRAN)
 294     MAKE_BUSY(MainProc);  /* Everything except the main PE is idle */
 295     if (RTSflags.GranFlags.Light)
 296       ActiveTSO = tso;
 297 #endif
 298
 299     required_thread_count = 1;
 300     advisory_thread_count = 0;
 301 #ifdef PAR
 302     }   /*if IAmMainThread ...*/
 303 #endif
 304
 305     /* ----------------------------------------------------------------- */
 306     /* This part is the MAIN SCHEDULER LOOP; jumped at from ReSchedule   */
 307     /* ----------------------------------------------------------------- */
 308
 309     if(setjmp(scheduler_loop) < 0)
 310         return;
 311
 312 #if defined(GRAN) && defined(GRAN_CHECK)
 313     if ( RTSflags.GranFlags.debug & 0x80 ) {
 314       fprintf(stderr,"MAIN Schedule Loop; ThreadQueueHd is ");
 315       G_TSO(ThreadQueueHd,1);
 316       /* if (ThreadQueueHd == MainTSO) {
 317         fprintf(stderr,"D> Event Queue is now:\n");
 318         GEQ();
 319       } */
 320     }
 321 #endif
 322
 323 #ifdef PAR
 324     if (PendingFetches != Prelude_Z91Z93_closure) {
 325         processFetches();
 326     }
 327
 328 #elif defined(GRAN)
 329     if (ThreadQueueHd == Prelude_Z91Z93_closure) {
 330         fprintf(stderr, "Qu'vatlh! No runnable threads!\n");
 331         EXIT(EXIT_FAILURE);
 332     }
 333     if (DO_QP_PROF > 1 && CurrentTSO != ThreadQueueHd) {
 334         QP_Event1("AG", ThreadQueueHd);
 335     }
 336 #else
 337     while (RunnableThreadsHd == Prelude_Z91Z93_closure) {
 338         /* If we've no work */
 339         if (WaitingThreadsHd == Prelude_Z91Z93_closure) {
 340             fflush(stdout);
 341             fprintf(stderr, "No runnable threads!\n");
 342             EXIT(EXIT_FAILURE);
 343         }
 344         /* Block indef. waiting for I/O and timer expire */
 345         AwaitEvent(0);
 346     }
 347 #endif
 348
 349 #ifdef PAR
 350     if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
 351         if (advisory_thread_count < RTSflags.ConcFlags.maxThreads &&
 352           (PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL] ||
 353           PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL])) {
 354             /*
 355              * If we're here (no runnable threads) and we have pending
 356              * sparks, we must have a space problem.  Get enough space
 357              * to turn one of those pending sparks into a
 358              * thread... ReallyPerformGC doesn't return until the
 359              * space is available, so it may force global GC.  ToDo:
 360              * Is this unnecessary here?  Duplicated in ReSchedule()?
 361              * --JSM
 362              */
 363             ReallyPerformThreadGC(THREAD_SPACE_REQUIRED, rtsTrue);
 364             SAVE_Hp -= THREAD_SPACE_REQUIRED;
 365         } else {
 366             /*
 367              * We really have absolutely no work.  Send out a fish
 368              * (there may be some out there already), and wait for
 369              * something to arrive.  We clearly can't run any threads
 370              * until a SCHEDULE or RESUME arrives, and so that's what
 371              * we're hoping to see.  (Of course, we still have to
 372              * respond to other types of messages.)
 373              */
 374             if (!fishing)
 375                 sendFish(choosePE(), mytid, NEW_FISH_AGE, NEW_FISH_HISTORY,
 376                   NEW_FISH_HUNGER);
 377
 378             processMessages();
 379         }
 380         ReSchedule(0);
 381     } else if (PacketsWaiting()) {  /* Look for incoming messages */
 382         processMessages();
 383     }
 384 #endif /* PAR */
 385
 386 #if !defined(GRAN)
 387     if (DO_QP_PROF > 1 && CurrentTSO != RunnableThreadsHd) {
 388       QP_Event1("AG", RunnableThreadsHd);
 389 }
 390 #endif
 391
 392 #ifdef PAR
 393     if (RTSflags.ParFlags.granSimStats && !sameThread)
 394         DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
 395 #endif
 396
 397 #if defined(GRAN)
 398     TimeOfNextEvent = get_time_of_next_event();
 399     CurrentTSO = ThreadQueueHd;
 400     if (RTSflags.GranFlags.Light) {
 401       /* Save time of `virt. proc' which was active since last getevent and
 402          restore time of `virt. proc' where CurrentTSO is living on. */
 403       if(RTSflags.GranFlags.DoFairSchedule)
 404         {
 405             if (RTSflags.GranFlags.granSimStats &&
 406                 RTSflags.GranFlags.debug & 0x20000)
 407               DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
 408         }
 409       TSO_CLOCK(ActiveTSO) = CurrentTime[CurrentProc];
 410       ActiveTSO = NULL;
 411       CurrentTime[CurrentProc] = TSO_CLOCK(CurrentTSO);
 412       if(RTSflags.GranFlags.DoFairSchedule &&  resched )
 413         {
 414             resched = rtsFalse;
 415             if (RTSflags.GranFlags.granSimStats &&
 416                 RTSflags.GranFlags.debug & 0x20000)
 417               DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
 418         }
 419       /*
 420       if (TSO_LINK(ThreadQueueHd)!=Prelude_Z91Z93_closure &&
 421           (TimeOfNextEvent == 0 ||
 422            TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000<TimeOfNextEvent)) {
 423         new_event(CurrentProc,CurrentProc,TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000,
 424                   CONTINUETHREAD,TSO_LINK(ThreadQueueHd),Prelude_Z91Z93_closure,NULL);
 425         TimeOfNextEvent = get_time_of_next_event();
 426       }
 427       */
 428     }
 429     EndOfTimeSlice = CurrentTime[CurrentProc]+RTSflags.GranFlags.time_slice;
 430 #else /* !GRAN */
 431     CurrentTSO = RunnableThreadsHd;
 432     RunnableThreadsHd = TSO_LINK(RunnableThreadsHd);
 433     TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
 434
 435     if (RunnableThreadsHd == Prelude_Z91Z93_closure)
 436         RunnableThreadsTl = Prelude_Z91Z93_closure;
 437 #endif
 438
 439     /* If we're not running a timer, just leave the flag on */
 440     if (RTSflags.ConcFlags.ctxtSwitchTime > 0)
 441         context_switch = 0;
 442
 443 #if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 444     if (CurrentTSO == Prelude_Z91Z93_closure) {
 445         fprintf(stderr,"Qagh: Trying to execute Prelude_Z91Z93_closure on proc %d (@ %d)\n",
 446                 CurrentProc,CurrentTime[CurrentProc]);
 447         EXIT(EXIT_FAILURE);
 448       }
 449
 450     if (RTSflags.GranFlags.debug & 0x04) {
 451       if (BlockedOnFetch[CurrentProc]) {
 452         fprintf(stderr,"Qagh: Trying to execute TSO 0x%x on proc %d (@ %d) which is blocked-on-fetch by TSO 0x%x\n",
 453               CurrentTSO,CurrentProc,CurrentTime[CurrentProc],BlockedOnFetch[CurrentProc]);
 454         EXIT(EXIT_FAILURE);
 455       }
 456     }
 457
 458     if ( (RTSflags.GranFlags.debug & 0x10) &&
 459          (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) ) {
 460            fprintf(stderr,"Qagh: Trying to execute TSO 0x%x on proc %d (@ %d) which should be asleep!\n",
 461               CurrentTSO,CurrentProc,CurrentTime[CurrentProc]);
 462         EXIT(EXIT_FAILURE);
 463     }
 464 #endif
 465
 466 #if 0 && defined(CONCURRENT)
 467     fprintf(stderr, "ScheduleThreads: About to resume thread:%#x\n",
 468                     CurrentTSO);
 469 #endif
 470     miniInterpret((StgFunPtr)resumeThread);
 471 }
 472 \end{code}
 473
 474 % Some remarks on GrAnSim -- HWL
 475
 476 The ReSchedule fct is the heart of GrAnSim.  Based on its parameter it issues
 477 a CONTINUETRHEAD to carry on executing the current thread in due course or it watches out for new work (e.g. called from EndThread).
 478
 479 Then it picks the next   event (get_next_event) and handles it  appropriately
 480 (see switch construct). Note that a continue  in the switch causes the next
 481 event to be handled  and a break  causes a jmp  to the scheduler_loop where
 482 the TSO at the head of the current processor's runnable queue is executed.
 483
 484 ReSchedule is mostly  entered from HpOverflow.lc:PerformReSchedule which is
 485 itself called via the GRAN_RESCHEDULE macro in the compiler generated code.
 486
 487 \begin{code}
 488 /*
 489   GrAnSim rules here! Others stay out or you will be crashed.
 490   Concurrent and parallel guys: please use the next door (a few pages down;
 491   turn left at the !GRAN sign).
 492 */
 493
 494 #if defined(GRAN)
 495
 496 /* Prototypes of event handling functions. Only needed in ReSchedule */
 497 void do_the_globalblock PROTO((eventq event));
 498 void do_the_unblock PROTO((eventq event));
 499 void do_the_fetchnode PROTO((eventq event));
 500 void do_the_fetchreply PROTO((eventq event));
 501 void do_the_movethread PROTO((eventq event));
 502 void do_the_movespark PROTO((eventq event));
 503 void gimme_spark PROTO((rtsBool *found_res, sparkq *prev_res, sparkq *spark_res));
 504 void munch_spark PROTO((rtsBool found, sparkq prev, sparkq spark));
 505
 506 void
 507 ReSchedule(what_next)
 508 int what_next;           /* Run the current thread again? */
 509 {
 510   sparkq spark, nextspark;
 511   P_ tso;
 512   P_ node, closure;
 513   eventq event;
 514   int rc;
 515
 516 #  if defined(GRAN_CHECK) && defined(GRAN)
 517   if ( RTSflags.GranFlags.debug & 0x80 ) {
 518     fprintf(stderr,"Entering ReSchedule with mode %u; tso is\n",what_next);
 519     G_TSO(ThreadQueueHd,1);
 520   }
 521 #  endif
 522
 523 #  if defined(GRAN_CHECK) && defined(GRAN)
 524   if ( (RTSflags.GranFlags.debug & 0x80) || (RTSflags.GranFlags.debug & 0x40 ) )
 525       if (what_next<FIND_THREAD || what_next>END_OF_WORLD)
 526         fprintf(stderr,"Qagh {ReSchedule}Daq: illegal parameter %u for what_next\n",
 527                 what_next);
 528 #  endif
 529
 530   if (RTSflags.GranFlags.Light) {
 531     /* Save current time; GranSim Light only */
 532     TSO_CLOCK(CurrentTSO) = CurrentTime[CurrentProc];
 533   }
 534
 535   /* Run the current thread again (if there is one) */
 536   if(what_next==SAME_THREAD && ThreadQueueHd != Prelude_Z91Z93_closure)
 537     {
 538       /* A bit of a hassle if the event queue is empty, but ... */
 539       CurrentTSO = ThreadQueueHd;
 540
 541       resched = rtsFalse;
 542       if (RTSflags.GranFlags.Light &&
 543           TSO_LINK(ThreadQueueHd)!=Prelude_Z91Z93_closure &&
 544           TSO_CLOCK(ThreadQueueHd)>TSO_CLOCK(TSO_LINK(ThreadQueueHd))) {
 545           if(RTSflags.GranFlags.granSimStats &&
 546              RTSflags.GranFlags.debug & 0x20000 )
 547             DumpGranEvent(GR_DESCHEDULE,ThreadQueueHd);
 548           resched = rtsTrue;
 549           ThreadQueueHd =           TSO_LINK(CurrentTSO);
 550           if (ThreadQueueHd==Prelude_Z91Z93_closure)
 551             ThreadQueueTl=Prelude_Z91Z93_closure;
 552           TSO_LINK(CurrentTSO) =    Prelude_Z91Z93_closure;
 553           InsertThread(CurrentTSO);
 554       }
 555
 556       /* This code does round-Robin, if preferred. */
 557       if(!RTSflags.GranFlags.Light &&
 558          RTSflags.GranFlags.DoFairSchedule &&
 559          TSO_LINK(CurrentTSO) != Prelude_Z91Z93_closure &&
 560          CurrentTime[CurrentProc]>=EndOfTimeSlice)
 561         {
 562           ThreadQueueHd =           TSO_LINK(CurrentTSO);
 563           TSO_LINK(ThreadQueueTl) = CurrentTSO;
 564           ThreadQueueTl =           CurrentTSO;
 565           TSO_LINK(CurrentTSO) =    Prelude_Z91Z93_closure;
 566           CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
 567           if ( RTSflags.GranFlags.granSimStats )
 568               DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
 569           CurrentTSO = ThreadQueueHd;
 570         }
 571
 572       new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
 573                CONTINUETHREAD,CurrentTSO,Prelude_Z91Z93_closure,NULL);
 574     }
 575   /* Schedule `next thread' which is at ThreadQueueHd now i.e. thread queue */
 576   /* has been updated before that already. */
 577   else if(what_next==NEW_THREAD && ThreadQueueHd != Prelude_Z91Z93_closure)
 578     {
 579 #  if defined(GRAN_CHECK) && defined(GRAN)
 580       fprintf(stderr,"Qagh: ReSchedule(NEW_THREAD) shouldn't be used with DoReScheduleOnFetch!!\n");
 581       EXIT(EXIT_FAILURE);
 582
 583 #  endif
 584
 585       if(RTSflags.GranFlags.granSimStats &&
 586          (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
 587         DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
 588
 589       CurrentTSO = ThreadQueueHd;
 590       new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
 591                CONTINUETHREAD,CurrentTSO,Prelude_Z91Z93_closure,NULL);
 592
 593       CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
 594     }
 595
 596   /* We go in here if the current thread is blocked on fetch => don'd CONT */
 597   else if(what_next==CHANGE_THREAD)
 598     {
 599       /* just fall into event handling loop for next event */
 600     }
 601
 602   /* We go in here if we have no runnable threads or what_next==0 */
 603   else
 604     {
 605       procStatus[CurrentProc] = Idle;
 606       /* That's now done in HandleIdlePEs!
 607       new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
 608                FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
 609       */
 610       CurrentTSO = Prelude_Z91Z93_closure;
 611     }
 612
 613   /* ----------------------------------------------------------------- */
 614   /* This part is the EVENT HANDLING LOOP                              */
 615   /* ----------------------------------------------------------------- */
 616
 617   do {
 618     /* Choose the processor with the next event */
 619     event = get_next_event();
 620     CurrentProc = EVENT_PROC(event);
 621     CurrentTSO = EVENT_TSO(event);
 622     if (RTSflags.GranFlags.Light) {
 623       P_ tso;
 624       W_ tmp;
 625       /* Restore local clock of the virtual processor attached to CurrentTSO.
 626          All costs will be associated to the `virt. proc' on which the tso
 627          is living. */
 628      if (ActiveTSO != NULL) {                     /* already in system area */
 629        TSO_CLOCK(ActiveTSO) = CurrentTime[CurrentProc];
 630        if (RTSflags.GranFlags.DoFairSchedule)
 631         {
 632             if (RTSflags.GranFlags.granSimStats &&
 633                 RTSflags.GranFlags.debug & 0x20000)
 634               DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
 635         }
 636      }
 637      switch (EVENT_TYPE(event))
 638       {
 639         case CONTINUETHREAD:
 640         case FINDWORK:       /* inaccurate this way */
 641                              ActiveTSO = ThreadQueueHd;
 642                              break;
 643         case RESUMETHREAD:
 644         case STARTTHREAD:
 645         case MOVESPARK:      /* has tso of virt proc in tso field of event */
 646                              ActiveTSO = EVENT_TSO(event);
 647                              break;
 648         default: fprintf(stderr,"Illegal event type %s (%d) in GrAnSim Light setup\n",
 649                                 event_names[EVENT_TYPE(event)],EVENT_TYPE(event));
 650                  EXIT(EXIT_FAILURE);
 651       }
 652       CurrentTime[CurrentProc] = TSO_CLOCK(ActiveTSO);
 653       if(RTSflags.GranFlags.DoFairSchedule)
 654         {
 655             if (RTSflags.GranFlags.granSimStats &&
 656                 RTSflags.GranFlags.debug & 0x20000)
 657               DumpGranEvent(GR_SYSTEM_START,ActiveTSO);
 658         }
 659     }
 660
 661     if(EVENT_TIME(event) > CurrentTime[CurrentProc] &&
 662        EVENT_TYPE(event)!=CONTINUETHREAD)
 663        CurrentTime[CurrentProc] = EVENT_TIME(event);
 664
 665 #  if defined(GRAN_CHECK) && defined(GRAN)                           /* HWL */
 666     if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
 667       fprintf(stderr,"Qagh {ReSchedule}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
 668       EXIT(EXIT_FAILURE);
 669     }
 670 #  endif
 671     /* MAKE_BUSY(CurrentProc); don't think that's right in all cases now */
 672     /*                               -- HWL */
 673
 674 #  if defined(GRAN_CHECK) && defined(GRAN)
 675     if (RTSflags.GranFlags.debug & 0x80)
 676       fprintf(stderr,"After get_next_event, before HandleIdlePEs\n");
 677 #  endif
 678
 679     /* Deal with the idlers */
 680     if ( !RTSflags.GranFlags.Light )
 681       HandleIdlePEs();
 682
 683 #  if defined(GRAN_CHECK) && defined(GRAN)
 684     if ( RTSflags.GranFlags.event_trace_all ||
 685          ( RTSflags.GranFlags.event_trace && EVENT_TYPE(event) != CONTINUETHREAD) ||
 686          (RTSflags.GranFlags.debug & 0x80) )
 687       print_event(event);
 688 #  endif
 689
 690     switch (EVENT_TYPE(event))
 691       {
 692         /* Should just be continuing execution */
 693         case CONTINUETHREAD:
 694 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 695               if ( (RTSflags.GranFlags.debug & 0x100) &&
 696                    (EVENT_TSO(event)!=RunnableThreadsHd[EVENT_PROC(event)]) ) {
 697                 fprintf(stderr,"Warning: Wrong TSO in CONTINUETHREAD: %#lx (%x) (PE: %d  Hd: 0x%lx)\n",
 698                         EVENT_TSO(event), TSO_ID(EVENT_TSO(event)),
 699                         EVENT_PROC(event),
 700                         RunnableThreadsHd[EVENT_PROC(event)]);
 701               }
 702               if ( (RTSflags.GranFlags.debug & 0x04) &&
 703                    BlockedOnFetch[CurrentProc]) {
 704                 fprintf(stderr,"Warning: Discarding CONTINUETHREAD on blocked proc %u  @ %u\n",
 705                         CurrentProc,CurrentTime[CurrentProc]);
 706                 print_event(event);
 707                 continue;
 708               }
 709 #  endif
 710           if(ThreadQueueHd==Prelude_Z91Z93_closure)
 711             {
 712               new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
 713                        FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
 714               continue; /* Catches superfluous CONTINUEs -- should be unnecessary */
 715             }
 716           else
 717             break;   /* fall into scheduler loop */
 718
 719         case FETCHNODE:
 720           do_the_fetchnode(event);
 721           continue;                    /* handle next event in event queue  */
 722
 723         case GLOBALBLOCK:
 724           do_the_globalblock(event);
 725           continue;                    /* handle next event in event queue  */
 726
 727         case FETCHREPLY:
 728           do_the_fetchreply(event);
 729           continue;                    /* handle next event in event queue  */
 730
 731         case UNBLOCKTHREAD:   /* Move from the blocked queue to the tail of */
 732           do_the_unblock(event);
 733           continue;                    /* handle next event in event queue  */
 734
 735         case RESUMETHREAD:  /* Move from the blocked queue to the tail of */
 736                             /* the runnable queue ( i.e. Qu' SImqa'lu') */
 737           TSO_BLOCKTIME(EVENT_TSO(event)) += CurrentTime[CurrentProc] -
 738                                              TSO_BLOCKEDAT(EVENT_TSO(event));
 739           StartThread(event,GR_RESUME);
 740           continue;
 741
 742         case STARTTHREAD:
 743           StartThread(event,GR_START);
 744           continue;
 745
 746         case MOVETHREAD:
 747           do_the_movethread(event);
 748           continue;                    /* handle next event in event queue  */
 749
 750         case MOVESPARK:
 751           do_the_movespark(event);
 752           continue;                    /* handle next event in event queue  */
 753
 754         case FINDWORK:
 755           { /* Make sure that we have enough heap for creating a new
 756                thread. This is a conservative estimate of the required heap.
 757                This eliminates special checks for GC around NewThread within
 758                munch_spark.                                                 */
 759
 760             I_ req_heap = TSO_HS + TSO_CTS_SIZE + STKO_HS +
 761                           RTSflags.ConcFlags.stkChunkSize;
 762
 763             if (SAVE_Hp + req_heap >= SAVE_HpLim ) {
 764               ReallyPerformThreadGC(req_heap, rtsFalse);
 765               SAVE_Hp -= req_heap;
 766               if (IS_SPARKING(CurrentProc))
 767                 MAKE_IDLE(CurrentProc);
 768               continue;
 769             }
 770           }
 771
 772           if( RTSflags.GranFlags.DoAlwaysCreateThreads ||
 773               (ThreadQueueHd == Prelude_Z91Z93_closure &&
 774               (RTSflags.GranFlags.FetchStrategy >= 2 ||
 775                OutstandingFetches[CurrentProc] == 0)) )
 776             {
 777               rtsBool found;
 778               sparkq  prev, spark;
 779
 780               /* ToDo: check */
 781               ASSERT(procStatus[CurrentProc]==Sparking ||
 782                      RTSflags.GranFlags.DoAlwaysCreateThreads);
 783
 784               /* SImmoHwI' yInej! Search spark queue! */
 785               gimme_spark (&found, &prev, &spark);
 786
 787               /* DaH chu' Qu' yIchen! Now create new work! */
 788               munch_spark (found, prev, spark);
 789
 790               /* ToDo: check ; not valid if GC occurs in munch_spark
 791               ASSERT(procStatus[CurrentProc]==Starting ||
 792                      procStatus[CurrentProc]==Idle ||
 793                      RTSflags.GranFlags.DoAlwaysCreateThreads); */
 794             }
 795           continue; /* to the next event */
 796
 797         default:
 798           fprintf(stderr,"Illegal event type %u\n",EVENT_TYPE(event));
 799           continue;
 800       }  /* switch */
 801     longjmp(scheduler_loop, 1);
 802   } while(1);
 803 }
 804
 805 /* -----------------------------------------------------------------  */
 806 /* The main event handling functions; called from ReSchedule (switch) */
 807 /* -----------------------------------------------------------------  */
 808
 809 void
 810 do_the_globalblock(eventq event)
 811 {
 812   PROC proc = EVENT_PROC(event);      /* proc that requested node */
 813   P_ tso  = EVENT_TSO(event),         /* tso that requested node */
 814      node = EVENT_NODE(event);        /* requested, remote node */
 815
 816 #  if defined(GRAN_CHECK) && defined(GRAN)
 817   if ( RTSflags.GranFlags.Light ) {
 818     fprintf(stderr,"Qagh: There should be no GLOBALBLOCKs in GrAnSim Light setup\n");
 819     EXIT(EXIT_FAILURE);
 820   }
 821
 822   if (!RTSflags.GranFlags.DoGUMMFetching) {
 823     fprintf(stderr,"Qagh: GLOBALBLOCK events only valid with GUMM fetching\n");
 824     EXIT(EXIT_FAILURE);
 825   }
 826
 827   if ( (RTSflags.GranFlags.debug & 0x100) &&
 828         IS_LOCAL_TO(PROCS(node),proc) ) {
 829     fprintf(stderr,"Qagh: GLOBALBLOCK: Blocking on LOCAL node 0x %x (PE %d).\n",
 830             node,proc);
 831   }
 832 #  endif
 833   /* CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime; */
 834   if ( blockFetch(tso,proc,node) != 0 )
 835     return;                     /* node has become local by now */
 836
 837   if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* head of queue is next thread */
 838     P_ tso = RunnableThreadsHd[proc];       /* awaken next thread */
 839     if(tso != Prelude_Z91Z93_closure) {
 840       new_event(proc,proc,CurrentTime[proc],
 841                CONTINUETHREAD,tso,Prelude_Z91Z93_closure,NULL);
 842       CurrentTime[proc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
 843       if(RTSflags.GranFlags.granSimStats)
 844         DumpRawGranEvent(proc,CurrentProc,GR_SCHEDULE,tso,
 845                          Prelude_Z91Z93_closure,0);
 846       MAKE_BUSY(proc);                     /* might have been fetching */
 847     } else {
 848       MAKE_IDLE(proc);                     /* no work on proc now */
 849     }
 850   } else {  /* RTSflags.GranFlags.DoReScheduleOnFetch i.e. block-on-fetch */
 851               /* other thread is already running */
 852               /* 'oH 'utbe' 'e' vIHar ; I think that's not needed -- HWL
 853               new_event(proc,proc,CurrentTime[proc],
 854                        CONTINUETHREAD,EVENT_TSO(event),
 855                        (RTSflags.GranFlags.DoGUMMFetching ? closure :
 856                        EVENT_NODE(event)),NULL);
 857               */
 858   }
 859 }
 860
 861 void
 862 do_the_unblock(eventq event)
 863 {
 864   PROC proc = EVENT_PROC(event),       /* proc that requested node */
 865        creator = EVENT_CREATOR(event); /* proc that requested node */
 866   P_ tso  = EVENT_TSO(event),          /* tso that requested node */
 867      node = EVENT_NODE(event);         /* requested, remote node */
 868
 869 #  if defined(GRAN) && defined(GRAN_CHECK)
 870   if ( RTSflags.GranFlags.Light ) {
 871     fprintf(stderr,"Qagh: There should be no UNBLOCKs in GrAnSim Light setup\n");
 872     EXIT(EXIT_FAILURE);
 873   }
 874 #  endif
 875
 876   if (!RTSflags.GranFlags.DoReScheduleOnFetch) {  /* block-on-fetch */
 877     /* We count block-on-fetch as normal block time */
 878     TSO_BLOCKTIME(tso) += CurrentTime[proc] - TSO_BLOCKEDAT(tso);
 879     /* No costs for contextswitch or thread queueing in this case */
 880     if(RTSflags.GranFlags.granSimStats)
 881         DumpRawGranEvent(proc,CurrentProc,GR_RESUME,tso, Prelude_Z91Z93_closure,0);
 882     new_event(proc,proc,CurrentTime[proc],CONTINUETHREAD,tso,node,NULL);
 883   } else {
 884     /* Reschedule on fetch causes additional costs here: */
 885     /* Bring the TSO from the blocked queue into the threadq */
 886     new_event(proc,proc,CurrentTime[proc]+RTSflags.GranFlags.gran_threadqueuetime,
 887               RESUMETHREAD,tso,node,NULL);
 888   }
 889 }
 890
 891 void
 892 do_the_fetchnode(eventq event)
 893 {
 894   I_ rc;
 895
 896 #  if defined(GRAN_CHECK) && defined(GRAN)
 897   if ( RTSflags.GranFlags.Light ) {
 898     fprintf(stderr,"Qagh: There should be no FETCHNODEs in GrAnSim Light setup\n");
 899     EXIT(EXIT_FAILURE);
 900   }
 901
 902   if (RTSflags.GranFlags.SimplifiedFetch) {
 903     fprintf(stderr,"Qagh: FETCHNODE events not valid with simplified fetch\n");
 904     EXIT(EXIT_FAILURE);
 905   }
 906 #  endif
 907   CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
 908   do {
 909     rc = HandleFetchRequest(EVENT_NODE(event),
 910                             EVENT_CREATOR(event),
 911                             EVENT_TSO(event));
 912     if (rc == 4) {                                     /* trigger GC */
 913 #  if defined(GRAN_CHECK)  && defined(GRAN)
 914      if (RTSflags.GcFlags.giveStats)
 915        fprintf(RTSflags.GcFlags.statsFile,"*****   veQ boSwI'  PackNearbyGraph(node %#lx, tso %#lx (%x))\n",
 916                 EVENT_NODE(event), EVENT_TSO(event), TSO_ID(EVENT_TSO(event)));
 917 #  endif
 918      prepend_event(event);
 919      ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
 920 #  if defined(GRAN_CHECK)  && defined(GRAN)
 921      if (RTSflags.GcFlags.giveStats) {
 922        fprintf(RTSflags.GcFlags.statsFile,"*****      SAVE_Hp=%#lx, SAVE_HpLim=%#lx, PACK_HEAP_REQUIRED=%#lx\n",
 923                 SAVE_Hp, SAVE_HpLim, PACK_HEAP_REQUIRED);
 924        fprintf(stderr,"*****      No. of packets so far: %d (total size: %d)\n",
 925                 tot_packets,tot_packet_size);
 926      }
 927 #  endif
 928      event = grab_event();
 929      SAVE_Hp -= PACK_HEAP_REQUIRED;
 930
 931      /* GC knows that events are special and follows the pointer i.e. */
 932      /* events are valid even if they moved. An EXIT is triggered */
 933      /* if there is not enough heap after GC. */
 934     }
 935   } while (rc == 4);
 936 }
 937
 938 void
 939 do_the_fetchreply(eventq event)
 940 {
 941   P_ tso, closure;
 942
 943 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 944   if ( RTSflags.GranFlags.Light ) {
 945     fprintf(stderr,"Qagh: There should be no FETCHREPLYs in GrAnSim Light setup\n");
 946     EXIT(EXIT_FAILURE);
 947   }
 948
 949   if (RTSflags.GranFlags.SimplifiedFetch) {
 950     fprintf(stderr,"Qagh: FETCHREPLY events not valid with simplified fetch\n");
 951     EXIT(EXIT_FAILURE);
 952   }
 953
 954   if (RTSflags.GranFlags.debug & 0x10) {
 955     if (TSO_TYPE(EVENT_TSO(event)) & FETCH_MASK_TSO) {
 956       TSO_TYPE(EVENT_TSO(event)) &= ~FETCH_MASK_TSO;
 957     } else {
 958       fprintf(stderr,"Qagh: FETCHREPLY: TSO %#x (%x) has fetch mask not set @ %d\n",
 959               CurrentTSO,TSO_ID(CurrentTSO),CurrentTime[CurrentProc]);
 960       EXIT(EXIT_FAILURE);
 961     }
 962   }
 963
 964   if (RTSflags.GranFlags.debug & 0x04) {
 965     if (BlockedOnFetch[CurrentProc]!=ThreadQueueHd) {
 966       fprintf(stderr,"Qagh: FETCHREPLY: Proc %d (with TSO %#x (%x)) not blocked-on-fetch by TSO %#lx (%x)\n",
 967               CurrentProc,CurrentTSO,TSO_ID(CurrentTSO),
 968               BlockedOnFetch[CurrentProc], TSO_ID(BlockedOnFetch[CurrentProc]));
 969       EXIT(EXIT_FAILURE);
 970     } else {
 971      BlockedOnFetch[CurrentProc] = 0; /*- rtsFalse; -*/
 972     }
 973   }
 974 #  endif
 975
 976    CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
 977
 978    if (RTSflags.GranFlags.DoGUMMFetching) {      /* bulk (packet) fetching */
 979      P_ buffer = EVENT_NODE(event);
 980      PROC p = EVENT_PROC(event);
 981      I_ size = buffer[PACK_SIZE_LOCN];
 982
 983      tso = EVENT_TSO(event);
 984
 985      /* NB: Fetch misses can't occur with GUMM fetching, as */
 986      /* updatable closure are turned into RBHs and therefore locked */
 987      /* for other processors that try to grab them. */
 988
 989      closure = UnpackGraph(buffer);
 990      CurrentTime[CurrentProc] += size * RTSflags.GranFlags.gran_munpacktime;
 991    } else
 992       /* Copy or  move node to CurrentProc */
 993       if (FetchNode(EVENT_NODE(event),
 994                   EVENT_CREATOR(event),
 995                   EVENT_PROC(event)) ) {
 996         /* Fetch has failed i.e. node has been grabbed by another PE */
 997         P_ node = EVENT_NODE(event), tso = EVENT_TSO(event);
 998         PROC p = where_is(node);
 999         TIME fetchtime;
1000
1001 #  if defined(GRAN_CHECK) && defined(GRAN)
1002         if (RTSflags.GranFlags.PrintFetchMisses) {
1003            fprintf(stderr,"Fetch miss @ %lu: node %#lx is at proc %u (rather than proc %u)\n",
1004                    CurrentTime[CurrentProc],node,p,EVENT_CREATOR(event));
1005            fetch_misses++;
1006         }
1007 #  endif  /* GRAN_CHECK */
1008
1009         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
1010
1011         /* Count fetch again !? */
1012         ++TSO_FETCHCOUNT(tso);
1013         TSO_FETCHTIME(tso) += RTSflags.GranFlags.gran_fetchtime;
1014
1015         fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
1016                     RTSflags.GranFlags.gran_latency;
1017
1018         /* Chase the grabbed node */
1019         new_event(p,CurrentProc,fetchtime,FETCHNODE,tso,node,NULL);
1020
1021 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
1022         if (RTSflags.GranFlags.debug & 0x04)
1023           BlockedOnFetch[CurrentProc] = tso; /*-rtsTrue;-*/
1024
1025         if (RTSflags.GranFlags.debug & 0x10)
1026           TSO_TYPE(tso) |= FETCH_MASK_TSO;
1027 #  endif
1028
1029         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
1030
1031         return; /* NB: no REPLy has been processed; tso still sleeping */
1032     }
1033
1034     /* -- Qapla'! Fetch has been successful; node is here, now  */
1035     ++TSO_FETCHCOUNT(EVENT_TSO(event));
1036     TSO_FETCHTIME(EVENT_TSO(event)) += RTSflags.GranFlags.gran_fetchtime;
1037
1038     if (RTSflags.GranFlags.granSimStats)
1039        DumpRawGranEvent(CurrentProc,EVENT_CREATOR(event),GR_REPLY,
1040                         EVENT_TSO(event),
1041                         (RTSflags.GranFlags.DoGUMMFetching ?
1042                                closure :
1043                                EVENT_NODE(event)),
1044                         0);
1045
1046     --OutstandingFetches[CurrentProc];
1047     ASSERT(OutstandingFetches[CurrentProc] >= 0);
1048 #  if 0 && defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
1049    if (OutstandingFetches[CurrentProc] < 0) {
1050      fprintf(stderr,"Qagh: OutstandingFetches of proc %u has become negative\n",CurrentProc);
1051      EXIT(EXIT_FAILURE);
1052    }
1053 #  endif
1054     new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
1055              UNBLOCKTHREAD,EVENT_TSO(event),
1056              (RTSflags.GranFlags.DoGUMMFetching ?
1057                closure :
1058                EVENT_NODE(event)),
1059              NULL);
1060 }
1061
1062 void
1063 do_the_movethread(eventq event) {
1064  P_ tso = EVENT_TSO(event);
1065 #  if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
1066  if ( RTSflags.GranFlags.Light && CurrentProc!=1 ) {
1067    fprintf(stderr,"Qagh: There should be no MOVETHREADs in GrAnSim Light setup\n");
1068    EXIT(EXIT_FAILURE);
1069  }
1070  if (!RTSflags.GranFlags.DoThreadMigration) {
1071    fprintf(stderr,"Qagh: MOVETHREAD events should never occur without -bM\n");
1072    EXIT(EXIT_FAILURE);
1073  }
1074  if (PROCS(tso)!=0) {
1075    fprintf(stderr,"Qagh: Moved thread has a bitmask of 0%o (proc %d); should be 0\n",
1076                    PROCS(tso), where_is(tso));
1077    EXIT(EXIT_FAILURE);
1078  }
1079 #  endif
1080  --OutstandingFishes[CurrentProc];
1081  ASSERT(OutstandingFishes[CurrentProc]>=0);
1082  SET_PROCS(tso,ThisPE);
1083  CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
1084  StartThread(event,GR_STOLEN);
1085 }
1086
1087 void
1088 do_the_movespark(eventq event){
1089  sparkq spark = EVENT_SPARK(event);
1090
1091  CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
1092
1093  if (RTSflags.GranFlags.granSimStats_Sparks)
1094     DumpRawGranEvent(CurrentProc,(PROC)0,SP_ACQUIRED,Prelude_Z91Z93_closure,
1095     SPARK_NODE(spark),
1096     spark_queue_len(CurrentProc,ADVISORY_POOL));
1097
1098 #if defined(GRAN) && defined(GRAN_CHECK)
1099  if (!SHOULD_SPARK(SPARK_NODE(spark)))
1100    withered_sparks++;
1101    /* Not adding the spark to the spark queue would be the right */
1102    /* thing here, but it also would be cheating, as this info can't be */
1103    /* available in a real system. -- HWL */
1104 #endif
1105  --OutstandingFishes[CurrentProc];
1106  ASSERT(OutstandingFishes[CurrentProc]>=0);
1107
1108  add_to_spark_queue(spark);
1109
1110  if (procStatus[CurrentProc]==Fishing)
1111    procStatus[CurrentProc] = Idle;
1112
1113  /* add_to_spark_queue will increase the time of the current proc. */
1114  /* Just falling into FINDWORK is wrong as we might have other */
1115  /* events that are happening before that. Therefore, just create */
1116  /* a FINDWORK event and go back to main event handling loop. */
1117
1118  /* Should we treat stolen sparks specially? Currently, we don't. */
1119 #if 0
1120  /* Now FINDWORK is created in HandleIdlePEs */
1121   new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
1122             FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
1123   sparking[CurrentProc]=rtsTrue;
1124 #endif
1125 }
1126
1127 /* Search the spark queue of the CurrentProc for a spark that's worth
1128    turning into a thread */
1129 void
1130 gimme_spark (rtsBool *found_res, sparkq *prev_res, sparkq *spark_res)
1131 {
1132    P_ node;
1133    rtsBool found;
1134    sparkq spark_of_non_local_node = NULL, spark_of_non_local_node_prev = NULL,
1135           low_priority_spark = NULL, low_priority_spark_prev = NULL,
1136           spark = NULL, prev = NULL, tmp = NULL;
1137
1138    /* Choose a spark from the local spark queue */
1139    spark = SparkQueueHd;
1140    found = rtsFalse;
1141
1142    while (spark != NULL && !found)
1143      {
1144        node = SPARK_NODE(spark);
1145        if (!SHOULD_SPARK(node))
1146          {
1147            if(RTSflags.GranFlags.granSimStats_Sparks)
1148              DumpRawGranEvent(CurrentProc,(PROC)0,SP_PRUNED,Prelude_Z91Z93_closure,
1149                                  SPARK_NODE(spark),
1150                                  spark_queue_len(CurrentProc,ADVISORY_POOL));
1151
1152               ASSERT(spark != NULL);
1153
1154               --SparksAvail;
1155               spark = delete_from_spark_queue (prev,spark);
1156          }
1157        /* -- node should eventually be sparked */
1158        else if (RTSflags.GranFlags.PreferSparksOfLocalNodes &&
1159                !IS_LOCAL_TO(PROCS(node),CurrentProc))
1160          {
1161            /* Remember first low priority spark */
1162            if (spark_of_non_local_node==NULL) {
1163                 spark_of_non_local_node_prev = prev;
1164              spark_of_non_local_node = spark;
1165               }
1166
1167            if (SPARK_NEXT(spark)==NULL) {
1168              ASSERT(spark==SparkQueueTl);  /* just for testing */
1169              prev = spark_of_non_local_node_prev;
1170              spark = spark_of_non_local_node;
1171              found = rtsTrue;
1172              break;
1173            }
1174
1175 #  if defined(GRAN) && defined(GRAN_CHECK)
1176            /* Should never happen; just for testing */
1177            if (spark==SparkQueueTl) {
1178              fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
1179                 EXIT(EXIT_FAILURE);
1180            }
1181 #  endif
1182            prev = spark;
1183            spark = SPARK_NEXT(spark);
1184            --SparksAvail;
1185          }
1186        else if ( RTSflags.GranFlags.DoPrioritySparking ||
1187                  (SPARK_GRAN_INFO(spark)>=RTSflags.GranFlags.SparkPriority2) )
1188          {
1189            found = rtsTrue;
1190          }
1191        else /* only used if SparkPriority2 is defined */
1192          {
1193            /* Remember first low priority spark */
1194            if (low_priority_spark==NULL) {
1195                 low_priority_spark_prev = prev;
1196              low_priority_spark = spark;
1197               }
1198
1199            if (SPARK_NEXT(spark)==NULL) {
1200                 ASSERT(spark==SparkQueueTl);  /* just for testing */
1201                 prev = low_priority_spark_prev;
1202                 spark = low_priority_spark;
1203              found = rtsTrue;       /* take low pri spark => rc is 2  */
1204              break;
1205            }
1206
1207            /* Should never happen; just for testing */
1208            if (spark==SparkQueueTl) {
1209              fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
1210                 EXIT(EXIT_FAILURE);
1211              break;
1212            }
1213               prev = spark;
1214               spark = SPARK_NEXT(spark);
1215 #  if defined(GRAN_CHECK) && defined(GRAN)
1216               if ( RTSflags.GranFlags.debug & 0x40 ) {
1217                 fprintf(stderr,"Ignoring spark of priority %u (SparkPriority=%u); node=0x%lx; name=%u\n",
1218                         SPARK_GRAN_INFO(spark), RTSflags.GranFlags.SparkPriority,
1219                         SPARK_NODE(spark), SPARK_NAME(spark));
1220                       }
1221 #  endif  /* GRAN_CHECK */
1222            }
1223    }  /* while (spark!=NULL && !found) */
1224
1225    *spark_res = spark;
1226    *prev_res = prev;
1227    *found_res = found;
1228 }
1229
1230 void
1231 munch_spark (rtsBool found, sparkq prev, sparkq spark)
1232 {
1233   P_ tso, node;
1234
1235   /* We've found a node; now, create thread (DaH Qu' yIchen) */
1236   if (found)
1237     {
1238 #  if defined(GRAN_CHECK) && defined(GRAN)
1239      if ( SPARK_GRAN_INFO(spark) < RTSflags.GranFlags.SparkPriority2 ) {
1240        tot_low_pri_sparks++;
1241        if ( RTSflags.GranFlags.debug & 0x40 ) {
1242          fprintf(stderr,"GRAN_TNG: No high priority spark available; low priority (%u) spark chosen: node=0x%lx; name=%u\n",
1243               SPARK_GRAN_INFO(spark),
1244               SPARK_NODE(spark), SPARK_NAME(spark));
1245          }
1246      }
1247 #  endif
1248      CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcreatetime;
1249
1250      node = SPARK_NODE(spark);
1251      if((tso = NewThread(node, T_REQUIRED, SPARK_GRAN_INFO(spark)))==NULL)
1252        {
1253          /* Some kind of backoff needed here in case there's too little heap */
1254 #  if defined(GRAN_CHECK) && defined(GRAN)
1255          if (RTSflags.GcFlags.giveStats)
1256            fprintf(RTSflags.GcFlags.statsFile,"***** vIS Qu' chen veQ boSwI'; spark=%#x, node=%#x;  name=%u\n",
1257                  /* (found==2 ? "no hi pri spark" : "hi pri spark"), */
1258                  spark, node,SPARK_NAME(spark));
1259 #  endif
1260          new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc]+1,
1261                   FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
1262          ReallyPerformThreadGC(TSO_HS+TSO_CTS_SIZE,rtsFalse);
1263          SAVE_Hp -= TSO_HS+TSO_CTS_SIZE;
1264          spark = NULL;
1265          return; /* was: continue; */ /* to the next event, eventually */
1266        }
1267
1268      if(RTSflags.GranFlags.granSimStats_Sparks)
1269           DumpRawGranEvent(CurrentProc,(PROC)0,SP_USED,Prelude_Z91Z93_closure,
1270                              SPARK_NODE(spark),
1271                              spark_queue_len(CurrentProc,ADVISORY_POOL));
1272
1273      TSO_EXPORTED(tso) =  SPARK_EXPORTED(spark);
1274      TSO_LOCKED(tso) =    !SPARK_GLOBAL(spark);
1275      TSO_SPARKNAME(tso) = SPARK_NAME(spark);
1276
1277      new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
1278               STARTTHREAD,tso,node,NULL);
1279
1280      procStatus[CurrentProc] = Starting;
1281
1282      ASSERT(spark != NULL);
1283
1284      spark = delete_from_spark_queue (prev, spark);
1285     }
1286    else /* !found  */
1287      /* Make the PE idle if nothing sparked and we have no threads. */
1288      {
1289        if(ThreadQueueHd == Prelude_Z91Z93_closure)
1290         {
1291            MAKE_IDLE(CurrentProc);
1292 #    if defined(GRAN_CHECK) && defined(GRAN)
1293            if ( (RTSflags.GranFlags.debug & 0x80) )
1294              fprintf(stderr,"Warning in FINDWORK handling: No work found for PROC %u\n",CurrentProc);
1295 #    endif  /* GRAN_CHECK */
1296          }
1297 #if 0
1298         else
1299         /* ut'lu'Qo' ; Don't think that's necessary any more -- HWL
1300          new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
1301                   CONTINUETHREAD,ThreadQueueHd,Prelude_Z91Z93_closure,NULL);
1302                   */
1303 #endif
1304     }
1305
1306 }
1307 \end{code}
1308
1309 Here follows the non-GRAN @ReSchedule@.
1310
1311 \begin{code}
1312 #else      /* !GRAN */
1313
1314 /* If you are concurrent and maybe even parallel please use this door. */
1315
1316 void
1317 ReSchedule(again)
1318 int again;                              /* Run the current thread again? */
1319 {
1320     P_ spark;
1321     PP_ sparkp;
1322     P_ tso;
1323
1324 #ifdef PAR
1325     /*
1326      * In the parallel world, we do unfair scheduling for the moment.
1327      * Ultimately, this should all be merged with the more
1328      * sophisticated GrAnSim scheduling options.  (Of course, some
1329      * provision should be made for *required* threads to make sure
1330      * that they don't starve, but for now we assume that no one is
1331      * running concurrent Haskell on a multi-processor platform.)
1332      */
1333
1334     sameThread = again;
1335
1336     if (again) {
1337         if (RunnableThreadsHd == Prelude_Z91Z93_closure)
1338             RunnableThreadsTl = CurrentTSO;
1339         TSO_LINK(CurrentTSO) = RunnableThreadsHd;
1340         RunnableThreadsHd = CurrentTSO;
1341     }
1342
1343 #else
1344
1345     /*
1346      * In the sequential world, we assume that the whole point of running
1347      * the threaded build is for concurrent Haskell, so we provide round-robin
1348      * scheduling.
1349      */
1350
1351     if (again) {
1352         if(RunnableThreadsHd == Prelude_Z91Z93_closure) {
1353             RunnableThreadsHd = CurrentTSO;
1354         } else {
1355             TSO_LINK(RunnableThreadsTl) = CurrentTSO;
1356             if (DO_QP_PROF > 1) {
1357                 QP_Event1("GA", CurrentTSO);
1358             }
1359         }
1360         RunnableThreadsTl = CurrentTSO;
1361     }
1362 #endif
1363
1364 #if 1
1365     /*
1366      * Debugging code, which is useful enough (and cheap enough) to compile
1367      * in all the time.  This makes sure that we don't access saved registers,
1368      * etc. in threads which are supposed to be sleeping.
1369      */
1370     CurrentTSO = Prelude_Z91Z93_closure;
1371     CurrentRegTable = NULL;
1372 #endif
1373
1374     /* First the required sparks */
1375
1376     for (sparkp = PendingSparksHd[REQUIRED_POOL];
1377       sparkp < PendingSparksTl[REQUIRED_POOL]; sparkp++) {
1378         spark = *sparkp;
1379         if (SHOULD_SPARK(spark)) {
1380             if ((tso = NewThread(spark, T_REQUIRED)) == NULL)
1381                 break;
1382             if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
1383                 RunnableThreadsHd = tso;
1384 #ifdef PAR
1385                 if (RTSflags.ParFlags.granSimStats) {
1386                     DumpGranEvent(GR_START, tso);
1387                     sameThread = rtsTrue;
1388                 }
1389 #endif
1390             } else {
1391                 TSO_LINK(RunnableThreadsTl) = tso;
1392 #ifdef PAR
1393                 if (RTSflags.ParFlags.granSimStats)
1394                     DumpGranEvent(GR_STARTQ, tso);
1395 #endif
1396             }
1397             RunnableThreadsTl = tso;
1398         } else {
1399            if (DO_QP_PROF)
1400                 QP_Event0(threadId++, spark);
1401 #if 0
1402             /* ToDo: Fix log entries for pruned sparks in GUM -- HWL */
1403             if(RTSflags.GranFlags.granSimStats_Sparks)
1404                 DumpGranEvent(SP_PRUNED,threadId++);
1405                                         ^^^^^^^^ should be a TSO
1406 #endif
1407         }
1408     }
1409     PendingSparksHd[REQUIRED_POOL] = sparkp;
1410
1411     /* Now, almost the same thing for advisory sparks */
1412
1413     for (sparkp = PendingSparksHd[ADVISORY_POOL];
1414       sparkp < PendingSparksTl[ADVISORY_POOL]; sparkp++) {
1415         spark = *sparkp;
1416         if (SHOULD_SPARK(spark)) {
1417             if (
1418 #ifdef PAR
1419     /* In the parallel world, don't create advisory threads if we are
1420      * about to rerun the same thread, or already have runnable threads,
1421      *  or the main thread has terminated */
1422               (RunnableThreadsHd != Prelude_Z91Z93_closure ||
1423                (required_thread_count == 0 && IAmMainThread)) ||
1424 #endif
1425               advisory_thread_count == RTSflags.ConcFlags.maxThreads ||
1426               (tso = NewThread(spark, T_ADVISORY)) == NULL)
1427                 break;
1428             advisory_thread_count++;
1429             if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
1430                 RunnableThreadsHd = tso;
1431 #ifdef PAR
1432                 if (RTSflags.ParFlags.granSimStats) {
1433                     DumpGranEvent(GR_START, tso);
1434                     sameThread = rtsTrue;
1435                 }
1436 #endif
1437             } else {
1438                 TSO_LINK(RunnableThreadsTl) = tso;
1439 #ifdef PAR
1440                 if (RTSflags.ParFlags.granSimStats)
1441                     DumpGranEvent(GR_STARTQ, tso);
1442 #endif
1443             }
1444             RunnableThreadsTl = tso;
1445         } else {
1446             if (DO_QP_PROF)
1447                 QP_Event0(threadId++, spark);
1448 #if 0
1449             /* ToDo: Fix log entries for pruned sparks in GUM -- HWL */
1450             if(RTSflags.GranFlags.granSimStats_Sparks)
1451                 DumpGranEvent(SP_PRUNED,threadId++);
1452                                         ^^^^^^^^ should be a TSO
1453 #endif
1454         }
1455     }
1456     PendingSparksHd[ADVISORY_POOL] = sparkp;
1457
1458 #ifndef PAR
1459     longjmp(scheduler_loop, required_thread_count == 0 ? -1 : 1);
1460 #else
1461     longjmp(scheduler_loop, required_thread_count == 0 && IAmMainThread ? -1 : 1);
1462 #endif
1463 }
1464
1465 #endif  /* !GRAN */
1466
1467 \end{code}
1468
1469 %****************************************************************************
1470 %
1471 \subsection[thread-gransim-execution]{Starting, Idling and Migrating
1472                                         Threads (GrAnSim only)}
1473 %
1474 %****************************************************************************
1475
1476 Thread start, idle and migration code for GrAnSim (i.e. simulating multiple
1477 processors).
1478
1479 \begin{code}
1480 #if defined(GRAN)
1481
1482 /* ngoqvam che' {GrAnSim}! */
1483
1484 #  if defined(GRAN_CHECK)
1485 /* This routine  is only  used for keeping   a statistics  of thread  queue
1486    lengths to evaluate the impact of priority scheduling. -- HWL
1487    {spark_queue_len}vo' jInIHta'
1488 */
1489 I_
1490 thread_queue_len(PROC proc)
1491 {
1492  P_ prev, next;
1493  I_ len;
1494
1495  for (len = 0, prev = Prelude_Z91Z93_closure, next = RunnableThreadsHd[proc];
1496       next != Prelude_Z91Z93_closure;
1497       len++, prev = next, next = TSO_LINK(prev))
1498    {}
1499
1500  return (len);
1501 }
1502 #  endif  /* GRAN_CHECK */
1503 \end{code}
1504
1505 A large portion of @StartThread@ deals with maintaining a sorted thread
1506 queue, which is needed for the Priority Sparking option. Without that
1507 complication the code boils down to FIFO handling.
1508
1509 \begin{code}
1510 StartThread(event,event_type)
1511 eventq event;
1512 enum gran_event_types event_type;
1513 {
1514   P_ tso = EVENT_TSO(event),
1515      node = EVENT_NODE(event);
1516   PROC proc = EVENT_PROC(event),
1517        creator = EVENT_CREATOR(event);
1518   P_ prev, next;
1519   I_ count = 0;
1520   rtsBool found = rtsFalse;
1521
1522   ASSERT(CurrentProc==proc);
1523
1524 #  if defined(GRAN_CHECK)
1525   if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
1526     fprintf(stderr,"Qagh {StartThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
1527     EXIT(EXIT_FAILURE);
1528   }
1529
1530   /* A wee bit of statistics gathering */
1531   ++tot_add_threads;
1532   tot_tq_len += thread_queue_len(CurrentProc);
1533 #  endif
1534
1535   ASSERT(TSO_LINK(CurrentTSO)==Prelude_Z91Z93_closure);
1536
1537   /* Idle proc; same for pri spark and basic version */
1538   if(ThreadQueueHd==Prelude_Z91Z93_closure)
1539     {
1540       CurrentTSO = ThreadQueueHd = ThreadQueueTl = tso;
1541
1542       CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadqueuetime;
1543       new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
1544                 CONTINUETHREAD,tso,Prelude_Z91Z93_closure,NULL);
1545
1546       if(RTSflags.GranFlags.granSimStats &&
1547          !( (event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
1548           DumpRawGranEvent(CurrentProc,creator,event_type,
1549                            tso,node,
1550                            TSO_SPARKNAME(tso));
1551                            /* ^^^  SN (spark name) as optional info */
1552                            /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
1553                            /* ^^^  spark length as optional info */
1554
1555       ASSERT(IS_IDLE(CurrentProc) || event_type==GR_RESUME ||
1556              (procStatus[CurrentProc]==Fishing && event_type==GR_STOLEN) ||
1557              procStatus[CurrentProc]==Starting);
1558       MAKE_BUSY(CurrentProc);
1559       return;
1560     }
1561
1562   /* In GrAnSim-Light we always have an idle `virtual' proc.
1563      The semantics of the one-and-only thread queue is different here:
1564      all threads in the queue are running (each on its own virtual processor);
1565      the queue is only needed internally in the simulator to interleave the
1566      reductions of the different processors.
1567      The one-and-only thread queue is sorted by the local clocks of the TSOs.
1568   */
1569   if(RTSflags.GranFlags.Light)
1570     {
1571       ASSERT(ThreadQueueHd!=Prelude_Z91Z93_closure);
1572       ASSERT(TSO_LINK(tso)==Prelude_Z91Z93_closure);
1573
1574       /* If only one thread in queue so far we emit DESCHEDULE in debug mode */
1575       if(RTSflags.GranFlags.granSimStats &&
1576          (RTSflags.GranFlags.debug & 0x20000) &&
1577          TSO_LINK(ThreadQueueHd)==Prelude_Z91Z93_closure) {
1578         DumpRawGranEvent(CurrentProc,CurrentProc,GR_DESCHEDULE,
1579                          ThreadQueueHd,Prelude_Z91Z93_closure,0);
1580         resched = rtsTrue;
1581       }
1582
1583       if ( InsertThread(tso) ) {                        /* new head of queue */
1584         new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
1585                   CONTINUETHREAD,tso,Prelude_Z91Z93_closure,NULL);
1586
1587       }
1588       if(RTSflags.GranFlags.granSimStats &&
1589          !(( event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
1590         DumpRawGranEvent(CurrentProc,creator,event_type,
1591                    tso,node,
1592                    TSO_SPARKNAME(tso));
1593                    /* ^^^  SN (spark name) as optional info */
1594                    /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
1595                    /* ^^^  spark length as optional info */
1596
1597       /* MAKE_BUSY(CurrentProc); */
1598       return;
1599     }
1600
1601   /* Only for Pri Sparking */
1602   if (RTSflags.GranFlags.DoPriorityScheduling && TSO_PRI(tso)!=0)
1603     /* {add_to_spark_queue}vo' jInIHta'; Qu' wa'DIch yIleghQo' */
1604     for (prev = ThreadQueueHd, next =  TSO_LINK(ThreadQueueHd), count=0;
1605          (next != Prelude_Z91Z93_closure) &&
1606          !(found = (TSO_PRI(tso) >= TSO_PRI(next)));
1607          prev = next, next = TSO_LINK(next), count++)
1608      {}
1609
1610
1611   ASSERT(!IS_IDLE(CurrentProc));
1612
1613   /* found can only be rtsTrue if pri sparking enabled */
1614   if (found) {
1615 #  if defined(GRAN_CHECK)
1616      ++non_end_add_threads;
1617 #  endif
1618      /* Add tso to ThreadQueue between prev and next */
1619      TSO_LINK(tso) = next;
1620      if ( next == Prelude_Z91Z93_closure ) {
1621        ThreadQueueTl = tso;
1622      } else {
1623        /* no back link for TSO chain */
1624      }
1625
1626      if ( prev == Prelude_Z91Z93_closure ) {
1627        /* Never add TSO as first elem of thread queue; the first */
1628        /* element should be the one that is currently running -- HWL */
1629 #  if defined(GRAN_CHECK)
1630        fprintf(stderr,"Qagh: NewThread (w/ PriorityScheduling): Trying to add TSO %#lx (PRI=%d) as first elem of threadQ (%#lx) on proc %u (@ %u)\n",
1631                     tso, TSO_PRI(tso), ThreadQueueHd, CurrentProc,
1632                     CurrentTime[CurrentProc]);
1633 #  endif
1634      } else {
1635       TSO_LINK(prev) = tso;
1636      }
1637   } else { /* !found */ /* or not pri sparking! */
1638     /* Add TSO to the end of the thread queue on that processor */
1639     TSO_LINK(ThreadQueueTl) = EVENT_TSO(event);
1640     ThreadQueueTl = EVENT_TSO(event);
1641   }
1642   CurrentTime[CurrentProc] += count *
1643                               RTSflags.GranFlags.gran_pri_sched_overhead +
1644                               RTSflags.GranFlags.gran_threadqueuetime;
1645
1646   if(RTSflags.GranFlags.DoThreadMigration)
1647     ++SurplusThreads;
1648
1649   if(RTSflags.GranFlags.granSimStats &&
1650      !(( event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
1651     DumpRawGranEvent(CurrentProc,creator,event_type+1,
1652                      tso,node,
1653                      TSO_SPARKNAME(tso));
1654                      /* ^^^  SN (spark name) as optional info */
1655                      /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
1656                      /* ^^^  spark length as optional info */
1657
1658 #  if defined(GRAN_CHECK)
1659   /* Check if thread queue is sorted. Only for testing, really!  HWL */
1660   if ( RTSflags.GranFlags.DoPriorityScheduling && (RTSflags.GranFlags.debug & 0x400) ) {
1661     rtsBool sorted = rtsTrue;
1662     P_ prev, next;
1663
1664     if (ThreadQueueHd==Prelude_Z91Z93_closure || TSO_LINK(ThreadQueueHd)==Prelude_Z91Z93_closure) {
1665       /* just 1 elem => ok */
1666     } else {
1667       /* Qu' wa'DIch yIleghQo' (ignore first elem)! */
1668       for (prev = TSO_LINK(ThreadQueueHd), next = TSO_LINK(prev);
1669            (next != Prelude_Z91Z93_closure) ;
1670            prev = next, next = TSO_LINK(prev)) {
1671         sorted = sorted &&
1672                  (TSO_PRI(prev) >= TSO_PRI(next));
1673       }
1674     }
1675     if (!sorted) {
1676       fprintf(stderr,"Qagh: THREADQ on PE %d is not sorted:\n",
1677               CurrentProc);
1678       G_THREADQ(ThreadQueueHd,0x1);
1679     }
1680   }
1681 #  endif
1682
1683   CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadqueuetime;
1684 }
1685 \end{code}
1686
1687 @InsertThread@, which is only used for GranSim Light, is similar to
1688 @StartThread@ in that it adds a TSO to a thread queue. However, it assumes
1689 that the thread queue is sorted by local clocks and it inserts the TSO at the
1690 right place in the queue. Don't create any event, just insert.
1691
1692 \begin{code}
1693 rtsBool
1694 InsertThread(tso)
1695 P_ tso;
1696 {
1697   P_ prev, next;
1698   I_ count = 0;
1699   rtsBool found = rtsFalse;
1700
1701 #  if defined(GRAN_CHECK)
1702   if ( !RTSflags.GranFlags.Light ) {
1703     fprintf(stderr,"Qagh {InsertThread}Daq: InsertThread should only be used in a  GrAnSim Light setup\n");
1704     EXIT(EXIT_FAILURE);
1705   }
1706
1707   if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
1708     fprintf(stderr,"Qagh {StartThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
1709     EXIT(EXIT_FAILURE);
1710   }
1711 #  endif
1712
1713   /* Idle proc; same for pri spark and basic version */
1714   if(ThreadQueueHd==Prelude_Z91Z93_closure)
1715     {
1716       ThreadQueueHd = ThreadQueueTl = tso;
1717       /* MAKE_BUSY(CurrentProc); */
1718       return (rtsTrue);
1719     }
1720
1721   for (prev = ThreadQueueHd, next =  TSO_LINK(ThreadQueueHd), count=0;
1722        (next != Prelude_Z91Z93_closure) &&
1723        !(found = (TSO_CLOCK(tso) < TSO_CLOCK(next)));
1724        prev = next, next = TSO_LINK(next), count++)
1725    {}
1726
1727   /* found can only be rtsTrue if pri sparking enabled */
1728   if (found) {
1729      /* Add tso to ThreadQueue between prev and next */
1730      TSO_LINK(tso) = next;
1731      if ( next == Prelude_Z91Z93_closure ) {
1732        ThreadQueueTl = tso;
1733      } else {
1734        /* no back link for TSO chain */
1735      }
1736
1737      if ( prev == Prelude_Z91Z93_closure ) {
1738        ThreadQueueHd = tso;
1739      } else {
1740        TSO_LINK(prev) = tso;
1741      }
1742   } else { /* !found */ /* or not pri sparking! */
1743     /* Add TSO to the end of the thread queue on that processor */
1744     TSO_LINK(ThreadQueueTl) = tso;
1745     ThreadQueueTl = tso;
1746   }
1747   return (prev == Prelude_Z91Z93_closure);
1748 }
1749
1750 \end{code}
1751
1752 Export work to idle PEs. This function is called from @ReSchedule@ before
1753   dispatching on the current event. @HandleIdlePEs@ iterates over all PEs,
1754 trying to get work for idle PEs. Note, that this is a simplification
1755 compared to GUM's fishing model. We try to compensate for that by making
1756 the cost for stealing work dependent on the number of idle processors and
1757 thereby on the probability with which a randomly sent fish would find work.
1758
1759 \begin{code}
1760 HandleIdlePEs()
1761 {
1762   PROC proc;
1763
1764 #  if defined(GRAN) && defined(GRAN_CHECK)
1765   if ( RTSflags.GranFlags.Light ) {
1766     fprintf(stderr,"Qagh {HandleIdlePEs}Daq: Should never be entered in GrAnSim Light setup\n");
1767     EXIT(EXIT_FAILURE);
1768   }
1769 #  endif
1770
1771   if(ANY_IDLE)
1772     for(proc = 0; proc < RTSflags.GranFlags.proc; proc++)
1773       if(IS_IDLE(proc)) /*  && IS_SPARKING(proc) && IS_STARTING(proc) */
1774         /* First look for local work! */
1775         if (PendingSparksHd[proc][ADVISORY_POOL]!=NULL)
1776          {
1777           new_event(proc,proc,CurrentTime[proc],
1778                     FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
1779           MAKE_SPARKING(proc);
1780          }
1781         /* Then try to get remote work! */
1782         else if ((RTSflags.GranFlags.max_fishes==0 ||
1783                  OutstandingFishes[proc]<RTSflags.GranFlags.max_fishes) )
1784
1785          {
1786           if(RTSflags.GranFlags.DoStealThreadsFirst &&
1787              (RTSflags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[proc] == 0))
1788             {
1789               if (SurplusThreads > 0l)                    /* Steal a thread */
1790                 StealThread(proc);
1791
1792               if(!IS_IDLE(proc))
1793                 break;
1794             }
1795
1796           if(SparksAvail > 0l &&
1797              (RTSflags.GranFlags.FetchStrategy >= 3 || OutstandingFetches[proc] == 0)) /* Steal a spark */
1798             StealSpark(proc);
1799
1800           if (SurplusThreads > 0l &&
1801               (RTSflags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[proc] == 0)) /* Steal a thread */
1802             StealThread(proc);
1803         }
1804 }
1805 \end{code}
1806
1807 Steal a spark and schedule  moving it to  proc. We want  to look at PEs  in
1808 clock order -- most retarded first.  Currently  sparks are only stolen from
1809 the @ADVISORY_POOL@ never from the @REQUIRED_POOL@. Eventually, this should
1810 be changed to first steal from the former then from the latter.
1811
1812 We model a sort of fishing mechanism by counting the number of sparks and
1813 threads we are currently stealing.
1814
1815 \begin{code}
1816 StealSpark(proc)
1817 PROC proc;
1818 {
1819   PROC p;
1820   sparkq spark, prev, next;
1821   rtsBool stolen = rtsFalse;
1822   TIME times[MAX_PROC], stealtime;
1823   unsigned ntimes=0, i, j;
1824   int first_later, upb, r;
1825
1826 #  if defined(GRAN) && defined(GRAN_CHECK)
1827   if ( RTSflags.GranFlags.Light ) {
1828     fprintf(stderr,"Qagh {StealSpark}Daq: Should never be entered in GrAnSim Light setup\n");
1829     EXIT(EXIT_FAILURE);
1830   }
1831 #  endif
1832
1833   /* times shall contain processors from which we may steal sparks */
1834   for(p=0; p < RTSflags.GranFlags.proc; ++p)
1835     if(proc != p &&
1836        PendingSparksHd[p][ADVISORY_POOL] != NULL &&
1837        CurrentTime[p] <= CurrentTime[CurrentProc])
1838       times[ntimes++] = p;
1839
1840   /* sort times */
1841   for(i=0; i < ntimes; ++i)
1842     for(j=i+1; j < ntimes; ++j)
1843       if(CurrentTime[times[i]] > CurrentTime[times[j]])
1844         {
1845           unsigned temp = times[i];
1846           times[i] = times[j];
1847           times[j] = temp;
1848         }
1849
1850   /* Choose random processor to steal spark from; first look at processors */
1851   /* that are earlier than the current one (i.e. proc) */
1852
1853   for(first_later=0;
1854       (first_later < ntimes) && (CurrentTime[times[first_later]] < CurrentTime[proc]);
1855       ++first_later)
1856     /* nothing */ ;
1857
1858   while (!stolen && (ntimes>0)) {
1859     long unsigned int r, q=0;
1860
1861     upb = (first_later==0) ? ntimes : first_later;
1862
1863     if (RTSflags.GranFlags.RandomSteal) {
1864       r = lrand48();                                /* [0, RAND_MAX] */
1865     } else {
1866       r = 0;
1867     }
1868     /* -- ASSERT(r<=RAND_MAX); */
1869     i = (unsigned int) (r % upb);                  /* [0, upb) */
1870     /* -- ASSERT((i>=0) && (i<=upb)); */
1871     p = times[i];
1872     /* -- ASSERT((p>=0) && (p<MAX_PROC)); */
1873
1874 #  if defined(GRAN_CHECK)
1875     if ( RTSflags.GranFlags.debug & 0x2000 )
1876       fprintf(stderr,"RANDOM_STEAL: [index %u of %u] from %u (@ %lu) to %u (@ %lu) (q=%d) [rand value: %lu]\n",
1877                      i, ntimes, p, CurrentTime[p], proc, CurrentTime[proc], q, r);
1878 #  endif
1879
1880       /* Now go through sparkq and steal the first one that should be sparked*/
1881       for(prev=NULL, spark = PendingSparksHd[p][ADVISORY_POOL];
1882           spark != NULL && !stolen;
1883           spark=next)
1884         {
1885           next = SPARK_NEXT(spark);
1886
1887           if ((IS_IDLE(p) || procStatus[p]==Sparking || procStatus[p]==Fishing) &&
1888               SPARK_NEXT(spark)==NULL)
1889             {
1890               /* Be social! Don't steal the only spark of an idle processor */
1891               break;
1892             }
1893           else if(SHOULD_SPARK(SPARK_NODE(spark)))
1894             {
1895               /* Don't Steal local sparks */
1896               if(!SPARK_GLOBAL(spark))
1897                 {
1898                   prev=spark;
1899                   continue;
1900                 }
1901
1902               /* Prepare message for sending spark */
1903               CurrentTime[p] += RTSflags.GranFlags.gran_mpacktime;
1904
1905               if(RTSflags.GranFlags.granSimStats_Sparks)
1906                 DumpRawGranEvent(p,(PROC)0,SP_EXPORTED,Prelude_Z91Z93_closure,
1907                                  SPARK_NODE(spark),
1908                                  spark_queue_len(p,ADVISORY_POOL));
1909
1910               SPARK_NEXT(spark) = NULL;
1911
1912               stealtime = (CurrentTime[p] > CurrentTime[proc] ?
1913                              CurrentTime[p] :
1914                              CurrentTime[proc])
1915                           + SparkStealTime();
1916
1917
1918               new_event(proc,p /* CurrentProc */,stealtime,
1919                        MOVESPARK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,spark);
1920
1921               /* MAKE_BUSY(proc);     not yet; busy when TSO in threadq */
1922               stolen = rtsTrue;
1923               ++OutstandingFishes[proc];
1924               if (IS_IDLE(proc))
1925                 MAKE_FISHING(proc);
1926               ++SPARK_GLOBAL(spark);
1927               --SparksAvail;
1928
1929               CurrentTime[p] += RTSflags.GranFlags.gran_mtidytime;
1930             }
1931           else   /* !(SHOULD_SPARK(SPARK_NODE(spark))) */
1932             {
1933               if(RTSflags.GranFlags.granSimStats_Sparks)
1934                 DumpRawGranEvent(p,(PROC)0,SP_PRUNED,Prelude_Z91Z93_closure,
1935                                  SPARK_NODE(spark),
1936                                  spark_queue_len(p,ADVISORY_POOL));
1937               --SparksAvail;
1938               DisposeSpark(spark);
1939             }
1940
1941           if(spark == PendingSparksHd[p][ADVISORY_POOL])
1942             PendingSparksHd[p][ADVISORY_POOL] = next;
1943
1944           if(prev!=NULL)
1945             SPARK_NEXT(prev) = next;
1946         }                    /* for (spark=...    iterating over sparkq */
1947
1948       if(PendingSparksHd[p][ADVISORY_POOL] == NULL)
1949         PendingSparksTl[p][ADVISORY_POOL] = NULL;
1950
1951       if (!stolen && (ntimes>0)) {  /* nothing stealable from proc p :( */
1952         ASSERT(times[i]==p);
1953
1954         /* remove p from the list (at pos i) */
1955         for (j=i; j+1<ntimes; j++)
1956           times[j] = times[j+1];
1957         ntimes--;
1958
1959         /* update index to first proc which is later (or equal) than proc */
1960         for ( ;
1961              (first_later>0) &&
1962              (CurrentTime[times[first_later-1]]>CurrentTime[proc]);
1963              first_later--)
1964           /* nothing */ ;
1965       }
1966     }  /* while */
1967 #  if defined(GRAN_CHECK)
1968     if (stolen && (i!=0)) { /* only for statistics */
1969       rs_sp_count++;
1970       ntimes_total += ntimes;
1971       fl_total += first_later;
1972       no_of_steals++;
1973     }
1974 #  endif
1975 }
1976 \end{code}
1977
1978 Steal a spark and schedule moving it to proc.
1979
1980 \begin{code}
1981 StealThread(proc)
1982 PROC proc;
1983 {
1984   PROC p;
1985   rtsBool found;
1986   P_ thread, prev;
1987   TIME times[MAX_PROC], stealtime;
1988   unsigned ntimes=0, i, j;
1989   int first_later, upb, r;
1990
1991   /* Hunt for a thread */
1992
1993 #  if defined(GRAN) && defined(GRAN_CHECK)
1994   if ( RTSflags.GranFlags.Light ) {
1995     fprintf(stderr,"Qagh {StealThread}: Should never be entered in GrAnSim Light setup\n");
1996     EXIT(EXIT_FAILURE);
1997   }
1998 #  endif
1999
2000   /* times shall contain processors from which we may steal threads */
2001   for(p=0; p < RTSflags.GranFlags.proc; ++p)
2002     if(proc != p && RunnableThreadsHd[p] != Prelude_Z91Z93_closure &&
2003        CurrentTime[p] <= CurrentTime[CurrentProc])
2004       times[ntimes++] = p;
2005
2006   /* sort times */
2007   for(i=0; i < ntimes; ++i)
2008     for(j=i+1; j < ntimes; ++j)
2009       if(CurrentTime[times[i]] > CurrentTime[times[j]])
2010         {
2011           unsigned temp = times[i];
2012           times[i] = times[j];
2013           times[j] = temp;
2014         }
2015
2016   /* Choose random processor to steal spark from; first look at processors */
2017   /* that are earlier than the current one (i.e. proc) */
2018
2019   for(first_later=0;
2020       (first_later < ntimes) && (CurrentTime[times[first_later]] < CurrentTime[proc]);
2021       ++first_later)
2022     /* nothing */ ;
2023
2024   while (!found && (ntimes>0)) {
2025     long unsigned int r, q=0;
2026
2027     upb = (first_later==0) ? ntimes : first_later;
2028
2029     if (RTSflags.GranFlags.RandomSteal) {
2030       r = lrand48();                                /* [0, RAND_MAX] */
2031     } else {
2032       r = 0;
2033     }
2034     /* -- ASSERT(r<=RAND_MAX); */
2035     if ( RTSflags.GranFlags.debug & 0x2000 )
2036       fprintf(stderr,"rand value: %d  " , r);
2037     i = (unsigned int) (r % upb);                  /* [0, upb] */
2038     /* -- ASSERT((i>=0) && (i<=upb)); */
2039     p = times[i];
2040     /* -- ASSERT((p>=0) && (p<MAX_PROC)); */
2041
2042 #  if defined(GRAN_CHECK)
2043     if ( RTSflags.GranFlags.debug & 0x2000 )
2044       fprintf(stderr,"RANDOM_STEAL; [index %u] from %u (@ %lu) to %u (@ %lu) (q=%d)\n",
2045                      i, p, CurrentTime[p], proc, CurrentTime[proc], q);
2046 #  endif
2047
2048       /* Steal the first exportable thread in the runnable queue after the */
2049       /* first one */
2050
2051       if(RunnableThreadsHd[p] != Prelude_Z91Z93_closure)
2052         {
2053           for(prev = RunnableThreadsHd[p], thread = TSO_LINK(RunnableThreadsHd[p]);
2054               thread != Prelude_Z91Z93_closure && TSO_LOCKED(thread);
2055               prev = thread, thread = TSO_LINK(thread))
2056             /* SKIP */;
2057
2058           if(thread != Prelude_Z91Z93_closure)   /* Take thread out of runnable queue */
2059             {
2060               TSO_LINK(prev) = TSO_LINK(thread);
2061
2062               TSO_LINK(thread) = Prelude_Z91Z93_closure;
2063
2064               if(RunnableThreadsTl[p] == thread)
2065                 RunnableThreadsTl[p] = prev;
2066
2067               /* Turn magic constants into params !? -- HWL */
2068
2069               CurrentTime[p] += 5l * RTSflags.GranFlags.gran_mpacktime;
2070
2071               stealtime = (CurrentTime[p] > CurrentTime[proc] ?
2072                              CurrentTime[p] :
2073                              CurrentTime[proc])
2074                           + SparkStealTime()
2075                           + 4l * RTSflags.GranFlags.gran_additional_latency
2076                           + 5l * RTSflags.GranFlags.gran_munpacktime;
2077
2078               /* Move the thread; set bitmask to 0 while TSO is `on-the-fly' */
2079               SET_PROCS(thread,Nowhere /* PE_NUMBER(proc) */);
2080
2081               /* Move from one queue to another */
2082               new_event(proc,p,stealtime,MOVETHREAD,thread,Prelude_Z91Z93_closure,NULL);
2083               /* MAKE_BUSY(proc);  not yet; only when thread is in threadq */
2084               ++OutstandingFishes[proc];
2085               if (IS_IDLE(proc))
2086                 MAKE_FISHING(proc);
2087               --SurplusThreads;
2088
2089               if(RTSflags.GranFlags.granSimStats)
2090                 DumpRawGranEvent(p,proc,GR_STEALING,thread,
2091                                  Prelude_Z91Z93_closure,0);
2092
2093               CurrentTime[p] += 5l * RTSflags.GranFlags.gran_mtidytime;
2094
2095               /* Found one */
2096               found = rtsTrue;
2097               /* break; */
2098             }
2099         }
2100
2101       if (!found && (ntimes>0)) {  /* nothing stealable from proc p */
2102         ASSERT(times[i]==p);
2103
2104         /* remove p from the list (at pos i) */
2105         for (j=i; j+1<ntimes; j++)
2106           times[j] = times[j+1];
2107         ntimes--;
2108       }
2109     } /* while */
2110 #  if defined(GRAN_CHECK) && defined(GRAN)
2111     if (found && (i!=0)) { /* only for statistics */
2112       rs_t_count++;
2113     }
2114 #  endif
2115 }
2116
2117 TIME
2118 SparkStealTime(void)
2119 {
2120   double fishdelay, sparkdelay, latencydelay;
2121   fishdelay =  (double)RTSflags.GranFlags.proc/2;
2122   sparkdelay = fishdelay -
2123           ((fishdelay-1)/(double)(RTSflags.GranFlags.proc-1))*(double)idlers();
2124   latencydelay = sparkdelay*((double)RTSflags.GranFlags.gran_latency);
2125
2126   return((TIME)latencydelay);
2127 }
2128 #endif                                                       /* GRAN ; HWL */
2129
2130 \end{code}
2131
2132
2133 %****************************************************************************
2134 %
2135 \subsection[thread-execution]{Executing Threads}
2136 %
2137 %****************************************************************************
2138
2139 First a set of functions for handling sparks and spark-queues that are
2140 attached to the processors. Currently, there are two spark-queues per
2141 processor:
2142
2143 \begin{itemize}
2144 \item  A queue of @REQUIRED@  sparks  i.e. these  sparks will be definitely
2145   turned into threads ({\em non-discardable\/}). They are mainly used in concurrent
2146   Haskell. We don't use them in GrAnSim.
2147 \item A queue of @ADVISORY@ sparks i.e. they may be turned into threads if
2148   the RTS thinks that it is a good idea. However, these sparks are {\em
2149     discardable}. They will be discarded if the associated closure is
2150   generally not worth creating a new thread (indicated by a tag in the
2151   closure) or they may be pruned during GC if there are too many sparks
2152   around already.
2153 \end{itemize}
2154
2155 \begin{code}
2156 EXTDATA_RO(StkO_info);
2157 EXTDATA_RO(TSO_info);
2158 EXTDATA_RO(WorldStateToken_closure);
2159
2160 EXTFUN(EnterNodeCode);
2161 UNVEC(EXTFUN(stopThreadDirectReturn);,EXTDATA(vtbl_stopStgWorld);)
2162
2163 #if defined(GRAN)
2164 /* ngoqvam che' {GrAnSim} */
2165
2166 /* Slow but relatively reliable method uses stgMallocBytes */
2167 /* Eventually change that to heap allocated sparks. */
2168
2169 /* -------------------------------------------------------------------------
2170    This is the main point where handling granularity information comes into
2171    play.
2172    ------------------------------------------------------------------------- */
2173
2174 #define MAX_RAND_PRI    100
2175
2176 /*
2177    Granularity info transformers.
2178    Applied to the GRAN_INFO field of a spark.
2179 */
2180 static I_ ID(I_ x) { return(x); };
2181 static I_ INV(I_ x) { return(-x); };
2182 static I_ IGNORE(I_ x) { return (0); };
2183 static I_ RAND(I_ x) { return ((lrand48() % MAX_RAND_PRI) + 1); }
2184
2185 /* NB: size_info and par_info are currently unused (what a shame!) -- HWL */
2186
2187 sparkq
2188 NewSpark(node,name,gran_info,size_info,par_info,local)
2189 P_ node;
2190 I_ name, gran_info, size_info, par_info, local;
2191 {
2192   I_ pri;
2193   sparkq newspark;
2194
2195   pri = RTSflags.GranFlags.RandomPriorities ? RAND(gran_info) :
2196         RTSflags.GranFlags.InversePriorities ? INV(gran_info) :
2197         RTSflags.GranFlags.IgnorePriorities ? IGNORE(gran_info) :
2198                            gran_info;
2199
2200   if ( RTSflags.GranFlags.SparkPriority!=0 && pri<RTSflags.GranFlags.SparkPriority ) {
2201     if ( RTSflags.GranFlags.debug & 0x40 ) {
2202       fprintf(stderr,"NewSpark: Ignoring spark of priority %u (SparkPriority=%u); node=0x%lx; name=%u\n",
2203               pri, RTSflags.GranFlags.SparkPriority, node, name);
2204     }
2205     return ((sparkq)NULL);
2206   }
2207
2208   newspark = (sparkq) stgMallocBytes(sizeof(struct spark), "NewSpark");
2209   SPARK_PREV(newspark) = SPARK_NEXT(newspark) = NULL;
2210   SPARK_NODE(newspark) = node;
2211   SPARK_NAME(newspark) = (name==1) ? TSO_SPARKNAME(CurrentTSO) : name;
2212   SPARK_GRAN_INFO(newspark) = pri;
2213   SPARK_GLOBAL(newspark) = !local;      /* Check that with parAt, parAtAbs !!*/
2214   return(newspark);
2215 }
2216
2217 /* To make casm more convenient use this function to label strategies */
2218 int
2219 set_sparkname(P_ tso, int name) {
2220   TSO_SPARKNAME(tso) = name ;
2221
2222   if(0 && RTSflags.GranFlags.granSimStats)
2223         DumpRawGranEvent(CurrentProc,99,GR_START,
2224                          tso,Prelude_Z91Z93_closure,
2225                          TSO_SPARKNAME(tso));
2226                          /* ^^^  SN (spark name) as optional info */
2227                          /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
2228                          /* ^^^  spark length as optional info */
2229
2230   return(0); }
2231
2232 int
2233 reset_sparkname(P_ tso) {
2234   TSO_SPARKNAME(tso) = 0;
2235   return (0);
2236 }
2237
2238 /*
2239    With PrioritySparking add_to_spark_queue performs an insert sort to keep
2240    the spark queue sorted. Otherwise the spark is just added to the end of
2241    the queue.
2242 */
2243
2244 void
2245 add_to_spark_queue(spark)
2246 sparkq spark;
2247 {
2248   sparkq prev, next;
2249   I_ count = 0;
2250   rtsBool found = rtsFalse;
2251
2252   if ( spark == (sparkq)NULL ) {
2253     return;
2254   }
2255
2256   if (RTSflags.GranFlags.DoPrioritySparking && (SPARK_GRAN_INFO(spark)!=0) ) {
2257
2258     for (prev = NULL, next = PendingSparksHd[CurrentProc][ADVISORY_POOL], count=0;
2259          (next != NULL) &&
2260          !(found = (SPARK_GRAN_INFO(spark) >= SPARK_GRAN_INFO(next)));
2261          prev = next, next = SPARK_NEXT(next), count++)
2262      {}
2263
2264   } else {   /* 'utQo' */
2265
2266     found = rtsFalse;   /* to add it at the end */
2267
2268   }
2269
2270   if (found) {
2271     SPARK_NEXT(spark) = next;
2272     if ( next == NULL ) {
2273       PendingSparksTl[CurrentProc][ADVISORY_POOL] = spark;
2274     } else {
2275       SPARK_PREV(next) = spark;
2276     }
2277     SPARK_PREV(spark) = prev;
2278     if ( prev == NULL ) {
2279       PendingSparksHd[CurrentProc][ADVISORY_POOL] = spark;
2280     } else {
2281       SPARK_NEXT(prev) = spark;
2282     }
2283   } else {  /* (RTSflags.GranFlags.DoPrioritySparking && !found) || !DoPrioritySparking */
2284     SPARK_NEXT(spark) = NULL;
2285     SPARK_PREV(spark) = PendingSparksTl[CurrentProc][ADVISORY_POOL];
2286     if (PendingSparksHd[CurrentProc][ADVISORY_POOL] == NULL)
2287       PendingSparksHd[CurrentProc][ADVISORY_POOL] = spark;
2288     else
2289       SPARK_NEXT(PendingSparksTl[CurrentProc][ADVISORY_POOL]) = spark;
2290     PendingSparksTl[CurrentProc][ADVISORY_POOL] = spark;
2291   }
2292   ++SparksAvail;
2293
2294   if (RTSflags.GranFlags.DoPrioritySparking) {
2295     CurrentTime[CurrentProc] += count * RTSflags.GranFlags.gran_pri_spark_overhead;
2296   }
2297
2298 #  if defined(GRAN_CHECK)
2299   if ( RTSflags.GranFlags.debug & 0x1000 ) {
2300     for (prev = NULL, next =  PendingSparksHd[CurrentProc][ADVISORY_POOL];
2301          (next != NULL);
2302          prev = next, next = SPARK_NEXT(next))
2303       {}
2304     if ( (prev!=NULL) && (prev!=PendingSparksTl[CurrentProc][ADVISORY_POOL]) )
2305       fprintf(stderr,"SparkQ inconsistency after adding spark %#lx: (PE %u, pool %u) PendingSparksTl (%#lx) not end of queue (%#lx)\n",
2306               spark,CurrentProc,ADVISORY_POOL,
2307               PendingSparksTl[CurrentProc][ADVISORY_POOL], prev);
2308   }
2309 #  endif
2310
2311 #  if defined(GRAN_CHECK)
2312   /* Check if the sparkq is still sorted. Just for testing, really!  */
2313   if ( RTSflags.GranFlags.debug & 0x400 ) {
2314     rtsBool sorted = rtsTrue;
2315     sparkq prev, next;
2316
2317     if (PendingSparksHd[CurrentProc][ADVISORY_POOL] == NULL ||
2318         SPARK_NEXT(PendingSparksHd[CurrentProc][ADVISORY_POOL]) == NULL ) {
2319       /* just 1 elem => ok */
2320     } else {
2321       for (prev = PendingSparksHd[CurrentProc][ADVISORY_POOL],
2322            next = SPARK_NEXT(PendingSparksHd[CurrentProc][ADVISORY_POOL]);
2323            (next != NULL) ;
2324            prev = next, next = SPARK_NEXT(next)) {
2325         sorted = sorted &&
2326                  (SPARK_GRAN_INFO(prev) >= SPARK_GRAN_INFO(next));
2327       }
2328     }
2329     if (!sorted) {
2330       fprintf(stderr,"Warning: SPARKQ on PE %d is not sorted:\n",
2331               CurrentProc);
2332       G_SPARKQ(PendingSparksHd[CurrentProc][ADVISORY_POOL],1);
2333     }
2334   }
2335 #  endif
2336 }
2337
2338 void
2339 DisposeSpark(spark)
2340 sparkq spark;
2341 {
2342   /* A SP_PRUNED line should be dumped when this is called from pruning or */
2343   /* discarding a spark! */
2344
2345   if(spark!=NULL)
2346     free(spark);
2347
2348   --SparksAvail;
2349 }
2350
2351 void
2352 DisposeSparkQ(spark)
2353 sparkq spark;
2354 {
2355   if (spark==NULL)
2356     return;
2357
2358   DisposeSparkQ(SPARK_NEXT(spark));
2359
2360 #  ifdef GRAN_CHECK
2361   if (SparksAvail < 0)
2362     fprintf(stderr,"DisposeSparkQ: SparksAvail<0 after disposing sparkq @ 0x%lx\n", spark);
2363 #  endif
2364
2365   free(spark);
2366 }
2367
2368 #endif /* GRAN */
2369 \end{code}
2370
2371 % {GrAnSim}vaD (Notes on GrAnSim) -- HWL:
2372 % Qu'vaD ngoq
2373 % NB: mayQo' wIvwI'
2374
2375 \paragraph{Notes on GrAnSim:}
2376 The following routines are for handling threads. Currently, we use an
2377 unfair scheduling policy in GrAnSim. Thus there are no explicit functions for
2378 scheduling here. If other scheduling policies are added to the system that
2379 code should go in here.
2380
2381 \begin{code}
2382 /* Create a new TSO, with the specified closure to enter and thread type */
2383
2384 #if defined(GRAN)
2385 P_
2386 NewThread(topClosure, type, pri)
2387 P_ topClosure;
2388 W_ type;
2389 I_ pri;
2390 #else
2391 P_
2392 NewThread(topClosure, type)
2393 P_ topClosure;
2394 W_ type;
2395 #endif /* GRAN */
2396 {
2397     P_ stko, tso;
2398
2399 #  if defined(GRAN) && defined(GRAN_CHECK)
2400     if ( RTSflags.GranFlags.Light && CurrentProc!=0) {
2401       fprintf(stderr,"Qagh {NewThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
2402       EXIT(EXIT_FAILURE);
2403     }
2404 #  endif
2405     if (AvailableTSO != Prelude_Z91Z93_closure) {
2406         tso = AvailableTSO;
2407 #if defined(GRAN)
2408         SET_PROCS(tso,ThisPE);  /* Allocate it locally! */
2409 #endif
2410         AvailableTSO = TSO_LINK(tso);
2411     } else if (SAVE_Hp + TSO_HS + TSO_CTS_SIZE > SAVE_HpLim) {
2412         return(NULL);
2413     } else {
2414         ALLOC_TSO(TSO_HS,BYTES_TO_STGWORDS(sizeof(STGRegisterTable)),
2415                   BYTES_TO_STGWORDS(sizeof(StgDouble)));
2416         tso = SAVE_Hp + 1;
2417         SAVE_Hp += TSO_HS + TSO_CTS_SIZE;
2418         SET_TSO_HDR(tso, TSO_info, CCC);
2419     }
2420
2421     TSO_LINK(tso) = Prelude_Z91Z93_closure;
2422 #if defined(GRAN)
2423     TSO_PRI(tso) =  pri;                  /* Priority of that TSO -- HWL */
2424 #endif
2425 #ifdef PAR
2426     TSO_CCC(tso) = (CostCentre)STATIC_CC_REF(CC_MAIN);
2427 #endif
2428     TSO_NAME(tso) = (P_) INFO_PTR(topClosure); /* A string would be nicer -- JSM */
2429     TSO_ID(tso) = threadId++;
2430     TSO_TYPE(tso) = type;
2431     TSO_PC1(tso) = TSO_PC2(tso) = EnterNodeCode;
2432     TSO_ARG1(tso) = /* TSO_ARG2(tso) = */ 0;
2433     TSO_SWITCH(tso) = NULL;
2434
2435 #ifdef TICKY_TICKY
2436     TSO_AHWM(tso) = 0;
2437     TSO_BHWM(tso) = 0;
2438 #endif
2439
2440 #if defined(GRAN) || defined(PAR)
2441     TSO_SPARKNAME(tso)    = 0;
2442 #  if defined(GRAN)
2443     TSO_STARTEDAT(tso)    = CurrentTime[CurrentProc];
2444 #  else
2445     TSO_STARTEDAT(tso)    = CURRENT_TIME;
2446 #  endif
2447     TSO_EXPORTED(tso)     = 0;
2448     TSO_BASICBLOCKS(tso)  = 0;
2449     TSO_ALLOCS(tso)       = 0;
2450     TSO_EXECTIME(tso)     = 0;
2451     TSO_FETCHTIME(tso)    = 0;
2452     TSO_FETCHCOUNT(tso)   = 0;
2453     TSO_BLOCKTIME(tso)    = 0;
2454     TSO_BLOCKCOUNT(tso)   = 0;
2455     TSO_BLOCKEDAT(tso)    = 0;
2456     TSO_GLOBALSPARKS(tso) = 0;
2457     TSO_LOCALSPARKS(tso)  = 0;
2458 #  if defined(GRAN)
2459     if (RTSflags.GranFlags.Light)
2460       TSO_CLOCK(tso)  = TSO_STARTEDAT(tso); /* local clock */
2461     else
2462 #  endif
2463       TSO_CLOCK(tso)  = 0;
2464 #endif
2465     /*
2466      * set pc, Node (R1), liveness
2467      */
2468     CurrentRegTable = TSO_INTERNAL_PTR(tso);
2469     SAVE_Liveness = LIVENESS_R1;
2470     SAVE_R1.p = topClosure;
2471
2472 # ifndef PAR
2473     if (type == T_MAIN) {
2474         stko = MainStkO;
2475     } else {
2476 # endif
2477         if (AvailableStack != Prelude_Z91Z93_closure) {
2478             stko = AvailableStack;
2479 #if defined(GRAN)
2480             SET_PROCS(stko,ThisPE);
2481 #endif
2482             AvailableStack = STKO_LINK(AvailableStack);
2483         } else if (SAVE_Hp + STKO_HS + RTSflags.ConcFlags.stkChunkSize > SAVE_HpLim) {
2484             return(NULL);
2485         } else {
2486             /* ALLOC_STK(STKO_HS,STKO_CHUNK_SIZE,0);   use RTSflag now*/
2487             ALLOC_STK(STKO_HS,RTSflags.ConcFlags.stkChunkSize,0);
2488             stko = SAVE_Hp + 1;
2489             SAVE_Hp += STKO_HS + RTSflags.ConcFlags.stkChunkSize;
2490             SET_STKO_HDR(stko, StkO_info, CCC);
2491         }
2492         STKO_SIZE(stko) = RTSflags.ConcFlags.stkChunkSize + STKO_VHS;
2493         STKO_SpB(stko) = STKO_SuB(stko) = STKO_BSTK_BOT(stko) + BREL(1);
2494         STKO_SpA(stko) = STKO_SuA(stko) = STKO_ASTK_BOT(stko) + AREL(1);
2495         STKO_LINK(stko) = Prelude_Z91Z93_closure;
2496         STKO_RETURN(stko) = NULL;
2497 # ifndef PAR
2498     }
2499 # endif
2500
2501 #ifdef TICKY_TICKY
2502     STKO_ADEP(stko) = STKO_BDEP(stko) = 0;
2503 #endif
2504
2505     if (type == T_MAIN) {
2506         STKO_SpA(stko) -= AREL(1);
2507         *STKO_SpA(stko) = (P_) WorldStateToken_closure;
2508     }
2509
2510     SAVE_Ret = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
2511     SAVE_StkO = stko;
2512
2513     if (DO_QP_PROF) {
2514         QP_Event1(do_qp_prof > 1 ? "*A" : "*G", tso);
2515     }
2516 #if defined(GRAN_CHECK)
2517     tot_sq_len += spark_queue_len(CurrentProc,ADVISORY_POOL);
2518     tot_sq_probes++;
2519 #endif
2520     return tso;
2521 }
2522
2523 \end{code}
2524
2525 In GrAnSim the @EndThread@ function is the place where statistics about the
2526 simulation are printed. I guess, that could be moved into @main.lc@.
2527
2528 \begin{code}
2529
2530 void
2531 EndThread(STG_NO_ARGS)
2532 {
2533     P_ stko;
2534 #if defined(PAR)
2535     TIME now = CURRENT_TIME;
2536 #endif
2537
2538 #ifdef TICKY_TICKY
2539     if (RTSflags.TickyFlags.showTickyStats) {
2540         fprintf(RTSflags.TickyFlags.tickyFile,
2541                 "Thread %d (%lx)\n\tA stack max. depth: %ld words\n",
2542                 TSO_ID(CurrentTSO), TSO_NAME(CurrentTSO), TSO_AHWM(CurrentTSO));
2543         fprintf(RTSflags.TickyFlags.tickyFile,
2544                 "\tB stack max. depth: %ld words\n",
2545                 TSO_BHWM(CurrentTSO));
2546     }
2547 #endif
2548
2549     if (DO_QP_PROF) {
2550         QP_Event1("G*", CurrentTSO);
2551     }
2552
2553 #if defined(GRAN)
2554     ASSERT(CurrentTSO == ThreadQueueHd);
2555
2556     if (RTSflags.GranFlags.DoThreadMigration)
2557       --SurplusThreads;
2558
2559     if(TSO_TYPE(CurrentTSO)==T_MAIN)
2560         {
2561           int i;
2562           rtsBool is_first;
2563           for(i=0; i < RTSflags.GranFlags.proc; ++i) {
2564             is_first = rtsTrue;
2565             while(RunnableThreadsHd[i] != Prelude_Z91Z93_closure)
2566               {
2567                 /* We schedule runnable threads before killing them to */
2568                 /* make the job of bookkeeping the running, runnable, */
2569                 /* blocked threads easier for scripts like gr2ps  -- HWL */
2570
2571                 if (RTSflags.GranFlags.granSimStats && !is_first &&
2572                     (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
2573                   DumpRawGranEvent(i,(PROC)0,GR_SCHEDULE,
2574                                    RunnableThreadsHd[i],
2575                                    Prelude_Z91Z93_closure,0);
2576                   if (!RTSflags.GranFlags.granSimStats_suppressed &&
2577                       TSO_TYPE(RunnableThreadsHd[i])!=T_MAIN)
2578                     DumpGranInfo(i,RunnableThreadsHd[i],rtsTrue);
2579                 RunnableThreadsHd[i] = TSO_LINK(RunnableThreadsHd[i]);
2580                 is_first = rtsFalse;
2581               }
2582           }
2583
2584           ThreadQueueHd = Prelude_Z91Z93_closure;
2585           /* Printing of statistics has been moved into end_gr_simulation */
2586         } /* ... T_MAIN */
2587
2588       if (RTSflags.GranFlags.labelling && RTSflags.GranFlags.granSimStats &&
2589           !RTSflags.GranFlags.granSimStats_suppressed)
2590         DumpStartEventAt(TSO_STARTEDAT(CurrentTSO),where_is(CurrentTSO),0,GR_START,
2591                          CurrentTSO,Prelude_Z91Z93_closure,
2592                          TSO_SPARKNAME(CurrentTSO));
2593                          /* ^^^  SN (spark name) as optional info */
2594                          /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
2595                          /* ^^^  spark length as optional info */
2596
2597       if (RTSflags.GranFlags.granSimStats &&
2598           !RTSflags.GranFlags.granSimStats_suppressed)
2599         DumpGranInfo(CurrentProc,CurrentTSO,
2600                      TSO_TYPE(CurrentTSO) != T_ADVISORY);
2601
2602       if (RTSflags.GranFlags.granSimStats_Binary &&
2603           TSO_TYPE(CurrentTSO)==T_MAIN &&
2604           !RTSflags.GranFlags.granSimStats_suppressed)
2605         grterminate(CurrentTime[CurrentProc]);
2606
2607       if (TSO_TYPE(CurrentTSO)!=T_MAIN)
2608         ActivateNextThread(CurrentProc);
2609
2610       /* Note ThreadQueueHd is Nil when the main thread terminates
2611       if(ThreadQueueHd != Prelude_Z91Z93_closure)
2612         {
2613           if (RTSflags.GranFlags.granSimStats && !RTSflags.GranFlags.granSimStats_suppressed &&
2614              (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
2615             DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
2616           CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadscheduletime;
2617         }
2618       */
2619
2620 #endif  /* GRAN */
2621
2622 #ifdef PAR
2623     if (RTSflags.ParFlags.granSimStats) {
2624         TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
2625         DumpGranInfo(thisPE, CurrentTSO, TSO_TYPE(CurrentTSO) != T_ADVISORY);
2626     }
2627 #endif
2628
2629     switch (TSO_TYPE(CurrentTSO)) {
2630     case T_MAIN:
2631         required_thread_count--;
2632
2633 #ifdef PAR
2634         if (GRANSIMSTATS_BINARY)
2635             grterminate(now);
2636 #endif
2637 #ifdef GRAN
2638         longjmp(scheduler_loop, -1); /* i.e. the world comes to an end NOW */
2639 #else
2640         ReSchedule(0);    /* i.e. the world will eventually come to an end */
2641 #endif
2642
2643     case T_REQUIRED:
2644         required_thread_count--;
2645         break;
2646
2647     case T_ADVISORY:
2648         advisory_thread_count--;
2649         break;
2650
2651     case T_FAIL:
2652         EXIT(EXIT_FAILURE);
2653
2654     default:
2655         fflush(stdout);
2656         fprintf(stderr, "EndThread: %x unknown\n", TSO_TYPE(CurrentTSO));
2657         EXIT(EXIT_FAILURE);
2658     }
2659
2660     /* Reuse stack object space */
2661     ASSERT(STKO_LINK(SAVE_StkO) == Prelude_Z91Z93_closure);
2662     STKO_LINK(SAVE_StkO) = AvailableStack;
2663     AvailableStack = SAVE_StkO;
2664     /* Reuse TSO */
2665     TSO_LINK(CurrentTSO) = AvailableTSO;
2666     AvailableTSO = CurrentTSO;
2667     CurrentTSO = Prelude_Z91Z93_closure;
2668     CurrentRegTable = NULL;
2669
2670 #if defined(GRAN)
2671     /* NB: Now ThreadQueueHd is either the next runnable thread on this */
2672     /* proc or it's Prelude_Z91Z93_closure. In the latter case, a FINDWORK will be */
2673     /* issued by ReSchedule. */
2674     ReSchedule(SAME_THREAD);                /* back for more! */
2675 #else
2676     ReSchedule(0);                          /* back for more! */
2677 #endif
2678 }
2679
2680 \end{code}
2681
2682 %****************************************************************************
2683 %
2684 \subsection[thread-blocking]{Local Blocking}
2685 %
2686 %****************************************************************************
2687
2688 \begin{code}
2689
2690 #if defined(GRAN_COUNT)
2691 /* Some non-essential maybe-useful statistics-gathering */
2692 void CountnUPDs() { ++nUPDs; }
2693 void CountnUPDs_old() { ++nUPDs_old; }
2694 void CountnUPDs_new() { ++nUPDs_new; }
2695
2696 void CountnPAPs() { ++nPAPs; }
2697 #endif
2698
2699 EXTDATA_RO(BQ_info);
2700
2701 #ifndef GRAN
2702 /* NB: non-GRAN version ToDo
2703  *
2704  * AwakenBlockingQueue awakens a list of TSOs and FBQs.
2705  */
2706
2707 P_ PendingFetches = Prelude_Z91Z93_closure;
2708
2709 void
2710 AwakenBlockingQueue(bqe)
2711   P_ bqe;
2712 {
2713     P_ last_tso = NULL;
2714
2715 # ifdef PAR
2716     P_ next;
2717     TIME now = CURRENT_TIME;
2718
2719 # endif
2720
2721 # ifndef PAR
2722     while (bqe != Prelude_Z91Z93_closure) {
2723 # else
2724     while (IS_MUTABLE(INFO_PTR(bqe))) {
2725         switch (INFO_TYPE(INFO_PTR(bqe))) {
2726         case INFO_TSO_TYPE:
2727 # endif
2728             if (DO_QP_PROF) {
2729                 QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
2730             }
2731 # ifdef PAR
2732             if (RTSflags.ParFlags.granSimStats) {
2733                 DumpGranEvent(GR_RESUMEQ, bqe);
2734                 switch (TSO_QUEUE(bqe)) {
2735                 case Q_BLOCKED:
2736                     TSO_BLOCKTIME(bqe) += now - TSO_BLOCKEDAT(bqe);
2737                     break;
2738                 case Q_FETCHING:
2739                     TSO_FETCHTIME(bqe) += now - TSO_BLOCKEDAT(bqe);
2740                     break;
2741                 default:
2742                     fflush(stdout);
2743                     fprintf(stderr, "ABQ: TSO_QUEUE invalid.\n");
2744                     EXIT(EXIT_FAILURE);
2745                 }
2746             }
2747 # endif
2748             if (last_tso == NULL) {
2749                 if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
2750                     RunnableThreadsHd = bqe;
2751                 } else {
2752                     TSO_LINK(RunnableThreadsTl) = bqe;
2753                 }
2754             }
2755             last_tso = bqe;
2756             bqe = TSO_LINK(bqe);
2757 # ifdef PAR
2758             break;
2759         case INFO_BF_TYPE:
2760             next = BF_LINK(bqe);
2761             BF_LINK(bqe) = PendingFetches;
2762             PendingFetches = bqe;
2763             bqe = next;
2764             if (last_tso != NULL)
2765                 TSO_LINK(last_tso) = next;
2766             break;
2767         default:
2768             fprintf(stderr, "Unexpected IP (%#lx) in blocking queue at %#lx\n",
2769               INFO_PTR(bqe), (W_) bqe);
2770             EXIT(EXIT_FAILURE);
2771         }
2772     }
2773 #  else
2774     }
2775 # endif
2776     if (last_tso != NULL) {
2777         RunnableThreadsTl = last_tso;
2778 # ifdef PAR
2779         TSO_LINK(last_tso) = Prelude_Z91Z93_closure;
2780 # endif
2781     }
2782 }
2783 #endif /* !GRAN */
2784
2785 #ifdef GRAN
2786
2787 #  if defined(GRAN_CHECK)
2788
2789 /* First some useful test functions */
2790
2791 EXTFUN(RBH_Save_0_info);
2792 EXTFUN(RBH_Save_1_info);
2793 EXTFUN(RBH_Save_2_info);
2794
2795 void
2796 PRINT_BQ(bqe)
2797 P_ bqe;
2798 {
2799     W_ it;
2800     P_ last = NULL;
2801     char str[80], str0[80];
2802
2803     fprintf(stderr,"\n[PE %d] @ %lu BQ: ",
2804                     CurrentProc,CurrentTime[CurrentProc]);
2805     if ( bqe == Prelude_Z91Z93_closure ) {
2806       fprintf(stderr," NIL.\n");
2807       return;
2808     }
2809     if ( bqe == NULL ) {
2810       fprintf(stderr," NULL\n");
2811       return;
2812     }
2813     while (IS_MUTABLE(INFO_PTR(bqe))) {  /* This distinguishes TSOs from */
2814       W_ proc;                           /* RBH_Save_? closures! */
2815
2816       /* Find where the tso lives */
2817       proc = where_is(bqe);
2818       it = INFO_TYPE(INFO_PTR(bqe));
2819
2820       switch (it) {
2821           case INFO_TSO_TYPE:
2822             strcpy(str0,"TSO");
2823             break;
2824           case INFO_BQ_TYPE:
2825             strcpy(str0,"BQ");
2826             break;
2827           default:
2828             strcpy(str0,"???");
2829             break;
2830           }
2831
2832       if(proc == CurrentProc)
2833         fprintf(stderr," %#lx (%x) L %s,", bqe, TSO_ID(bqe), str0);
2834       else
2835         fprintf(stderr," %#lx (%x) G (PE %d) %s,", bqe, TSO_ID(bqe), proc, str0);
2836
2837       last = bqe;
2838       switch (it) {
2839           case INFO_TSO_TYPE:
2840             bqe = TSO_LINK(bqe);
2841             break;
2842           case INFO_BQ_TYPE:
2843             bqe = TSO_LINK(bqe);
2844             break;
2845           default:
2846             bqe = Prelude_Z91Z93_closure;
2847             break;
2848           }
2849       /* TSO_LINK(last_tso) = Prelude_Z91Z93_closure; */
2850     }
2851     if ( bqe == Prelude_Z91Z93_closure )
2852       fprintf(stderr," NIL.\n");
2853     else if (
2854          (INFO_PTR(bqe) == (P_) RBH_Save_0_info) ||
2855          (INFO_PTR(bqe) == (P_) RBH_Save_1_info) ||
2856          (INFO_PTR(bqe) == (P_) RBH_Save_2_info) )
2857       fprintf(stderr," RBH.\n");
2858     /* fprintf(stderr,"\n%s\n",str); */
2859   }
2860
2861 rtsBool
2862 CHECK_BQ(node, tso, proc)
2863 P_ node, tso;
2864 PROC proc;
2865 {
2866   P_ bqe;
2867   W_ it;
2868   P_ last = NULL;
2869   PROC p = where_is(tso);
2870   rtsBool ok = rtsTrue;
2871
2872   if ( p != proc) {
2873     fprintf(stderr,"ERROR in CHECK_BQ: CurrentTSO %#lx (%x) on proc %d but CurrentProc = %d\n",
2874             tso, TSO_ID(tso), proc);
2875     ok = rtsFalse;
2876   }
2877
2878   switch (INFO_TYPE(INFO_PTR(node))) {
2879     case INFO_BH_TYPE:
2880     case INFO_BH_U_TYPE:
2881       bqe = (P_) BQ_ENTRIES(node);
2882       return (rtsTrue);           /* BHs don't have BQs */
2883       break;
2884     case INFO_BQ_TYPE:
2885       bqe = (P_) BQ_ENTRIES(node);
2886       break;
2887     case INFO_FMBQ_TYPE:
2888       fprintf(stderr,"CHECK_BQ: ERROR: FMBQ closure (%#lx) found in GrAnSim (TSO=%#lx (%x))\n",
2889               node, tso, TSO_ID(tso));
2890       EXIT(EXIT_FAILURE);
2891       break;
2892     case INFO_SPEC_RBH_TYPE:
2893       bqe = (P_) SPEC_RBH_BQ(node);
2894       break;
2895     case INFO_GEN_RBH_TYPE:
2896       bqe = (P_) GEN_RBH_BQ(node);
2897       break;
2898     default:
2899       {
2900         P_ info_ptr;
2901         I_ size, ptrs, nonptrs, vhs;
2902         char info_hdr_ty[80];
2903
2904         fprintf(stderr, "CHECK_BQ: thought %#lx was a black hole (IP %#lx)",
2905               node, INFO_PTR(node));
2906         info_ptr = get_closure_info(node,
2907                                     &size, &ptrs, &nonptrs, &vhs,
2908                                     info_hdr_ty);
2909         fprintf(stderr, " %s\n",info_hdr_ty);
2910         /* G_PRINT_NODE(node); */
2911         return (rtsFalse);
2912         /* EXIT(EXIT_FAILURE); */
2913         }
2914     }
2915
2916   while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
2917     W_ proc;                          /* RBH_Save_? closures! */
2918
2919     /* Find where the tso lives */
2920     proc = where_is(bqe);
2921     it = INFO_TYPE(INFO_PTR(bqe));
2922
2923     if ( bqe == tso ) {
2924       fprintf(stderr,"ERROR in CHECK_BQ [Node = 0x%lx, PE %d]: TSO %#lx (%x) already in BQ: ",
2925               node, proc, tso, TSO_ID(tso));
2926       PRINT_BQ(BQ_ENTRIES(node));
2927       ok = rtsFalse;
2928     }
2929
2930     bqe = TSO_LINK(bqe);
2931   }
2932   return (ok);
2933 }
2934 /* End of test functions */
2935 #  endif   /* GRAN_CHECK */
2936
2937 /* This version of AwakenBlockingQueue has been originally taken from the
2938    GUM code. It is now assimilated into GrAnSim */
2939
2940 /* Note: This version assumes a pointer to a blocking queue rather than a
2941    node with an attached blocking queue as input */
2942
2943 P_
2944 AwakenBlockingQueue(bqe)
2945 P_ bqe;
2946 {
2947     /* P_ tso = (P_) BQ_ENTRIES(node); */
2948     P_ last = NULL;
2949     /* P_ prev; */
2950     W_ notifytime;
2951
2952 #  if 0
2953     if(do_gr_sim)
2954 #  endif
2955
2956     /* Compatibility mode with old libaries! 'oH jIvoQmoH */
2957     if (IS_BQ_CLOSURE(bqe))
2958       bqe = (P_)BQ_ENTRIES(bqe);
2959     else if ( INFO_TYPE(INFO_PTR(bqe)) == INFO_SPEC_RBH_TYPE )
2960       bqe = (P_)SPEC_RBH_BQ(bqe);
2961     else if ( INFO_TYPE(INFO_PTR(bqe)) == INFO_GEN_RBH_TYPE )
2962       bqe = (P_)GEN_RBH_BQ(bqe);
2963
2964 #  if defined(GRAN_CHECK)
2965     if ( RTSflags.GranFlags.debug & 0x100 ) {
2966       PRINT_BQ(bqe);
2967     }
2968 #  endif
2969
2970 #  if defined(GRAN_COUNT)
2971         ++nUPDs;
2972         if (tso != Prelude_Z91Z93_closure)
2973           ++nUPDs_BQ;
2974 #  endif
2975
2976 #  if defined(GRAN_CHECK)
2977     if (RTSflags.GranFlags.debug & 0x100)
2978       fprintf(stderr,"----- AwBQ: ");
2979 #  endif
2980
2981     while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
2982       W_ proc;                          /* RBH_Save_? closures! */
2983       ASSERT(INFO_TYPE(INFO_PTR(bqe)) == INFO_TSO_TYPE);
2984
2985       if (DO_QP_PROF) {
2986         QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
2987       }
2988 #  if defined(GRAN_COUNT)
2989           ++BQ_lens;
2990 #  endif
2991
2992       /* Find where the tso lives */
2993       proc = where_is(bqe);
2994
2995       if(proc == CurrentProc) {
2996         notifytime = CurrentTime[CurrentProc] + RTSflags.GranFlags.gran_lunblocktime;
2997       } else {
2998         /* A better way of handling this would be to introduce a
2999            GLOBALUNBLOCK event which is created here. -- HWL */
3000         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
3001         notifytime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[proc]) +
3002                      RTSflags.GranFlags.gran_gunblocktime;
3003         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
3004         /* new_event(proc, CurrentProc, notifytime,
3005                     GLOBALUNBLOCK,bqe,Prelude_Z91Z93_closure,NULL); */
3006       }
3007       /* cost the walk over the queue */
3008       CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_lunblocktime;
3009       /* GrAnSim Light: make blocked TSO aware of the time that passed */
3010       if (RTSflags.GranFlags.Light)
3011         TSO_CLOCK(bqe) = notifytime;
3012       /* and create a resume message */
3013       new_event(proc, CurrentProc, notifytime,
3014                RESUMETHREAD,bqe,Prelude_Z91Z93_closure,NULL);
3015
3016       if (notifytime<TimeOfNextEvent)
3017         TimeOfNextEvent = notifytime;
3018
3019 #  if defined(GRAN_CHECK)
3020       if (RTSflags.GranFlags.debug & 0x100) {
3021         fprintf(stderr," TSO %x (PE %d) %s,",
3022                 TSO_ID(bqe), proc, ( (proc==CurrentProc) ? "L" : "G") );
3023       }
3024 #  endif
3025
3026       last = bqe;
3027       bqe = TSO_LINK(bqe);
3028       TSO_LINK(last) = Prelude_Z91Z93_closure;
3029     }    /* while */
3030
3031 #  if 0
3032     /* This was once used in a !do_gr_sim setup. Now only GrAnSim setup is */
3033     /* supported. */
3034     else /* Check if this is still valid for non-GrAnSim code -- HWL */
3035       {
3036         if (ThreadQueueHd == Prelude_Z91Z93_closure)
3037           ThreadQueueHd = bqe;
3038         else
3039           TSO_LINK(ThreadQueueTl) = bqe;
3040
3041         if (RunnableThreadsHd == Prelude_Z91Z93_closure)
3042           RunnableThreadsHd = tso;
3043         else
3044           TSO_LINK(RunnableThreadsTl) = tso;
3045
3046
3047         while(TSO_LINK(bqe) != Prelude_Z91Z93_closure) {
3048           assert(TSO_INTERNAL_PTR(bqe)->rR[0].p == node);
3049 #    if 0
3050           if (DO_QP_PROF) {
3051             QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
3052           }
3053 #    endif
3054           bqe = TSO_LINK(bqe);
3055         }
3056
3057         assert(TSO_INTERNAL_PTR(bqe)->rR[0].p == node);
3058 #    if 0
3059         if (DO_QP_PROF) {
3060           QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
3061         }
3062 #    endif
3063       }
3064 #  endif  /* 0 */
3065
3066     if (RTSflags.GranFlags.debug & 0x100)
3067         fprintf(stderr,".\n");
3068
3069     return (bqe);
3070     /* ngo' {GrAnSim}Qo' ngoq: RunnableThreadsTl = tso; */
3071 }
3072 #endif /* GRAN */
3073
3074 EXTFUN(Continue);
3075
3076
3077 #if defined(GRAN)
3078
3079 /* Different interface for GRAN */
3080 void
3081 Yield(liveness)
3082 W_ liveness;
3083 {
3084     SAVE_Liveness = liveness;
3085     TSO_PC1(CurrentTSO) = Continue;
3086     if (DO_QP_PROF) {
3087         QP_Event1("GR", CurrentTSO);
3088     }
3089     ReSchedule(SAME_THREAD);
3090 }
3091
3092 #else /* !GRAN */
3093
3094 void
3095 Yield(args)
3096 W_ args;
3097 {
3098     SAVE_Liveness = args >> 1;
3099     TSO_PC1(CurrentTSO) = Continue;
3100     if (DO_QP_PROF) {
3101         QP_Event1("GR", CurrentTSO);
3102     }
3103 #ifdef PAR
3104     if (RTSflags.ParFlags.granSimStats) {
3105         /* Note that CURRENT_TIME may perform an unsafe call */
3106         TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
3107     }
3108 #endif
3109     ReSchedule(args & 1);
3110 }
3111
3112 #endif  /* GRAN */
3113 \end{code}
3114
3115
3116 %****************************************************************************
3117 %
3118 \subsection[gr-fetch]{Fetching Nodes (GrAnSim only)}
3119 %
3120 %****************************************************************************
3121
3122 The following GrAnSim routines simulate the fetching of nodes from a remote
3123 processor. We use a 1 word bitmask to indicate on which processor a node is
3124 lying. Thus,  moving or copying a  node from one  processor to another just
3125 requires  an     appropriate  change in this     bitmask  (using @SET_GA@).
3126 Additionally, the clocks have to be updated.
3127
3128 A special case arises when the node that is  needed by processor A has been
3129 moved from a  processor B to a processor   C between sending  out a @FETCH@
3130 (from A) and its arrival at B. In that case the @FETCH@ has to be forwarded
3131 to C.
3132
3133
3134 \begin{code}
3135 #if defined(GRAN)
3136 /* ngoqvam che' {GrAnSim}! */
3137
3138 /* Fetch node "node" to processor "p" */
3139
3140 int
3141 FetchNode(node,from,to)
3142 P_ node;
3143 PROC from, to;
3144 {
3145   /* In case of RTSflags.GranFlags.DoGUMMFetching this fct should never be
3146      entered! Instead, UnpackGraph is used in ReSchedule */
3147   P_ closure;
3148
3149   ASSERT(to==CurrentProc);
3150
3151 #  if defined(GRAN) && defined(GRAN_CHECK)
3152   if ( RTSflags.GranFlags.Light ) {
3153     fprintf(stderr,"Qagh {FetchNode}Daq: Should never be entered  in GrAnSim Light setup\n");
3154     EXIT(EXIT_FAILURE);
3155   }
3156 #  endif
3157
3158   if ( RTSflags.GranFlags.DoGUMMFetching ) {
3159     fprintf(stderr,"Qagh: FetchNode should never be entered with DoGUMMFetching\n");
3160     EXIT(EXIT_FAILURE);
3161   }
3162
3163   /* Now fetch the children */
3164   if (!IS_LOCAL_TO(PROCS(node),from) &&
3165       !IS_LOCAL_TO(PROCS(node),to) )
3166     return 1;
3167
3168   if(IS_NF(INFO_PTR(node)))                 /* Old: || IS_BQ(node) */
3169     PROCS(node) |= PE_NUMBER(to);           /* Copy node */
3170   else
3171     PROCS(node) = PE_NUMBER(to);            /* Move node */
3172
3173   return 0;
3174 }
3175
3176 /* --------------------------------------------------
3177    Cost of sending a packet of size n = C + P*n
3178    where C = packet construction constant,
3179          P = cost of packing one word into a packet
3180    [Should also account for multiple packets].
3181    -------------------------------------------------- */
3182
3183 /* Return codes:
3184     0 ... ok (FETCHREPLY event with a buffer containing addresses of the
3185               nearby graph has been scheduled)
3186     1 ... node is already local (fetched by somebody else; no event is
3187                                   scheduled in here)
3188     2 ... fetch request has been forwrded to the PE that now contains the
3189            node
3190     3 ... node is a black hole (BH, BQ or RBH); no event is scheduled, and
3191            the current TSO is put into the blocking queue of that node
3192     4 ... out of heap in PackNearbyGraph; GC should be triggered in calling
3193           function to guarantee that the tso and node inputs are valid
3194           (they may be moved during GC).
3195
3196   ToDo: Symbolic return codes; clean up code (separate GUMMFetching from
3197         single node fetching.
3198 */
3199
3200 I_
3201 HandleFetchRequest(node,p,tso)
3202 P_ node, tso;
3203 PROC p;
3204 {
3205   ASSERT(!RTSflags.GranFlags.Light);
3206
3207   if (IS_LOCAL_TO(PROCS(node),p) )  /* Somebody else moved node already => */
3208     {                               /* start tso */
3209 #  if defined(GRAN_CHECK)
3210       if (RTSflags.GranFlags.debug & 0x100 ) {
3211         P_ info_ptr;
3212         I_ size, ptrs, nonptrs, vhs;
3213         char info_hdr_ty[80];
3214
3215         info_ptr = get_closure_info(node,
3216                                     &size, &ptrs, &nonptrs, &vhs,
3217                                     info_hdr_ty);
3218         fprintf(stderr,"Warning: HandleFetchRequest entered with local node %#lx (%s) (PE %d)\n",
3219                 node,info_hdr_ty,p);
3220       }
3221 #  endif
3222       if (RTSflags.GranFlags.DoGUMMFetching) {
3223         W_ size;
3224         P_ graph;
3225
3226         /* Create a 1-node-buffer and schedule a FETCHREPLY now */
3227         graph = PackOneNode(node, tso, &size);
3228         new_event(p,CurrentProc,CurrentTime[CurrentProc],
3229                  FETCHREPLY,tso,graph,NULL);
3230       } else {
3231         new_event(p,CurrentProc,CurrentTime[CurrentProc],
3232                  FETCHREPLY,tso,node,NULL);
3233       }
3234       return (1);
3235     }
3236   else if (IS_LOCAL_TO(PROCS(node),CurrentProc) )   /* Is node still here? */
3237     {
3238       if(RTSflags.GranFlags.DoGUMMFetching) {    /* {GUM}vo' ngoqvam vInIHta' (code from GUM) */
3239         W_ size;
3240         P_ graph;
3241
3242         if (IS_BLACK_HOLE(INFO_PTR(node))) {   /* block on BH or RBH */
3243           new_event(p,CurrentProc,CurrentTime[p],
3244                    GLOBALBLOCK,tso,node,NULL);
3245           /* Note: blockFetch is done when handling GLOBALBLOCK event */
3246           /* When this thread is reawoken it does the usual: it tries to
3247              enter the updated node and issues a fetch if it's remote.
3248              It has forgotten that it has sent a fetch already (i.e. a
3249              FETCHNODE is swallowed by a BH, leaving the thread in a BQ */
3250           --OutstandingFetches[p];
3251           return (3);
3252         }
3253
3254 #  if defined(GRAN_CHECK)
3255         if (!RTSflags.GranFlags.DoReScheduleOnFetch && (tso != RunnableThreadsHd[p])) {
3256           fprintf(stderr,"Qagh {HandleFetchRequest}Daq: tso 0x%lx (%x) not at head of proc %d (0x%lx)\n",
3257                   tso, TSO_ID(tso), p, RunnableThreadsHd[p]);
3258           EXIT(EXIT_FAILURE);
3259         }
3260 #  endif
3261
3262         if ((graph = PackNearbyGraph(node, tso, &size)) == NULL)
3263           return (4);  /* out of heap */
3264
3265         /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
3266         /* Send a reply to the originator */
3267         /* ToDo: Replace that by software costs for doing graph packing! */
3268         CurrentTime[CurrentProc] += size * RTSflags.GranFlags.gran_mpacktime;
3269
3270         new_event(p,CurrentProc,CurrentTime[CurrentProc]+RTSflags.GranFlags.gran_latency,
3271                  FETCHREPLY,tso,graph,NULL);
3272
3273         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
3274         return (0);
3275       } else {                   /* incremental (single closure) fetching */
3276         /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
3277         /* Send a reply to the originator */
3278         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
3279
3280         new_event(p,CurrentProc,CurrentTime[CurrentProc]+RTSflags.GranFlags.gran_latency,
3281                  FETCHREPLY,tso,node,NULL);
3282
3283         CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
3284         return (0);
3285       }
3286     }
3287   else       /* Qu'vatlh! node has been grabbed by another proc => forward */
3288     {
3289       PROC p_new = where_is(node);
3290       TIME fetchtime;
3291
3292 #  if defined(GRAN_CHECK)
3293       if (RTSflags.GranFlags.debug & 0x2)
3294         fprintf(stderr,"Qu'vatlh! node %#lx has been grabbed by PE %d (current=%d; demander=%d) @ %d\n",
3295                 node,p_new,CurrentProc,p,CurrentTime[CurrentProc]);
3296 #  endif
3297       /* Prepare FORWARD message to proc p_new */
3298       CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
3299
3300       fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p_new]) +
3301                   RTSflags.GranFlags.gran_latency;
3302
3303       new_event(p_new,p,fetchtime,FETCHNODE,tso,node,NULL);
3304
3305       CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
3306
3307       return (2);
3308     }
3309 }
3310 #endif
3311 \end{code}
3312
3313 @blockFetch@ blocks a @BlockedFetch@ node on some kind of black hole.
3314
3315 Taken from gum/HLComms.lc.   [find a  better  place for that ?] --  HWL
3316
3317 {\bf Note:} In  GranSim we don't  have @FETCHME@ nodes and therefore  don't
3318 create  @FMBQ@'s    (FetchMe   blocking   queues) to  cope    with   global
3319 blocking. Instead,  non-local TSO are put  into the BQ in  the same  way as
3320 local TSOs. However, we have to check if a TSO is  local or global in order
3321 to account for the latencies involved  and for keeping  track of the number
3322 of fetches that are really going on.
3323
3324 \begin{code}
3325 #if defined(GRAN)
3326
3327 /* Return codes:
3328     0 ... ok; tso is now at beginning of BQ attached to the bh closure
3329     1 ... the bh closure is no BH any more; tso is immediately unblocked
3330 */
3331
3332 I_
3333 blockFetch(tso, proc, bh)
3334 P_ tso;                        /* TSO which gets blocked */
3335 PROC proc;                     /* PE where that tso was running */
3336 P_ bh;                         /* closure to block on (BH, RBH, BQ) */
3337 {
3338 #  if defined(GRAN_CHECK)
3339     if ( RTSflags.GranFlags.debug & 0x100 ) {
3340         P_ info_ptr;
3341         I_ size, ptrs, nonptrs, vhs;
3342         char info_hdr_ty[80];
3343
3344         info_ptr = get_closure_info(bh,
3345                                     &size, &ptrs, &nonptrs, &vhs,
3346                                     info_hdr_ty);
3347         fprintf(stderr,"Blocking TSO %#lx (%x)(PE %d) on node %#lx (%s) (PE %d). No graph is packed!\n",
3348                 tso, TSO_ID(tso), proc, bh, info_hdr_ty, where_is(bh));
3349     }
3350
3351     if ( !RTSflags.GranFlags.DoReScheduleOnFetch && (tso != RunnableThreadsHd[proc]) ) {
3352       fprintf(stderr,"Qagh {blockFetch}Daq: TSO 0x%lx (%x) is not first on runnable list of proc %d (first is 0x%lx)\n",
3353               tso,TSO_ID(tso),proc,RunnableThreadsHd[proc]);
3354       EXIT(EXIT_FAILURE);
3355     }
3356 #  endif
3357
3358     if (!IS_BLACK_HOLE(INFO_PTR(bh))) {            /* catches BHs and RBHs */
3359 #  if defined(GRAN_CHECK)
3360       if ( RTSflags.GranFlags.debug & 0x100 ) {
3361         P_ info;
3362         W_ size, ptrs, nonptrs, vhs;
3363         char str[80], junk_str[80];
3364
3365         info = get_closure_info(bh, &size, &ptrs, &nonptrs, &vhs, str);
3366         fprintf(stderr,"blockFetch: node %#lx (%s) is not a BH => awakening TSO %#lx (%x) (PE %u)\n",
3367                 bh, str, tso, TSO_ID(tso), proc);
3368         G_PRINT_NODE(bh);
3369       }
3370 #  endif
3371       /* No BH anymore => immediately unblock tso */
3372       new_event(proc,proc,CurrentTime[proc],
3373                UNBLOCKTHREAD,tso,bh,NULL);
3374
3375       /* Is this always a REPLY to a FETCH in the profile ? */
3376       if (RTSflags.GranFlags.granSimStats)
3377         DumpRawGranEvent(proc,proc,GR_REPLY,tso,bh,0);
3378       return (1);
3379     }
3380
3381     /* DaH {BQ}Daq Qu' Suq 'e' wISov!
3382        Now we know that we have to put the tso into the BQ.
3383        2 case: If block-on-fetch, tso is at head of threadq =>
3384                => take it out of threadq and into BQ
3385                If reschedule-on-fetch, tso is only pointed to be event
3386                => just put it into BQ
3387     */
3388     if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* block-on-fetch */
3389       GranSimBlock(tso, proc, bh);  /* get tso out of threadq & activate next
3390                                        thread (same as in BQ_entry) */
3391     } else {                                       /*  reschedule-on-fetch */
3392       if(RTSflags.GranFlags.granSimStats)
3393          DumpRawGranEvent(proc,where_is(bh),GR_BLOCK,tso,bh,0);
3394
3395       ++TSO_BLOCKCOUNT(tso);
3396       TSO_BLOCKEDAT(tso) = CurrentTime[proc];
3397     }
3398
3399     ASSERT(TSO_LINK(tso)==Prelude_Z91Z93_closure);
3400
3401     /* Put tso into BQ */
3402     switch (INFO_TYPE(INFO_PTR(bh))) {
3403       case INFO_BH_TYPE:
3404       case INFO_BH_U_TYPE:
3405         TSO_LINK(tso) = Prelude_Z91Z93_closure;
3406         SET_INFO_PTR(bh, BQ_info);
3407         BQ_ENTRIES(bh) = (W_) tso;
3408
3409 #ifdef GC_MUT_REQUIRED
3410         /*
3411          * If we modify a black hole in the old generation, we have to make
3412          * sure it goes on the mutables list
3413          */
3414
3415         if (bh <= StorageMgrInfo.OldLim) {
3416             MUT_LINK(bh) = (W_) StorageMgrInfo.OldMutables;
3417             StorageMgrInfo.OldMutables = bh;
3418         } else
3419             MUT_LINK(bh) = MUT_NOT_LINKED;
3420 #endif
3421         break;
3422     case INFO_BQ_TYPE:
3423         /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
3424         TSO_LINK(tso) = (P_) BQ_ENTRIES(bh);
3425         BQ_ENTRIES(bh) = (W_) tso;
3426         break;
3427     case INFO_FMBQ_TYPE:
3428         fprintf(stderr,"ERROR: FMBQ closure (%#lx) found in GrAnSim (TSO=%#lx (%x))\n",
3429                 bh, tso, TSO_ID(tso));
3430         EXIT(EXIT_FAILURE);
3431     case INFO_SPEC_RBH_TYPE:
3432         /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
3433         TSO_LINK(tso) = (P_) SPEC_RBH_BQ(bh);
3434         SPEC_RBH_BQ(bh) = (W_) tso;
3435         break;
3436     case INFO_GEN_RBH_TYPE:
3437         /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
3438         TSO_LINK(tso) = (P_) GEN_RBH_BQ(bh);
3439         GEN_RBH_BQ(bh) = (W_) tso;
3440         break;
3441     default:
3442         {
3443           P_ info_ptr;
3444           I_ size, ptrs, nonptrs, vhs;
3445           char info_hdr_ty[80];
3446
3447           fprintf(stderr, "Panic: thought %#lx was a black hole (IP %#lx)",
3448                   bh, INFO_PTR(bh));
3449 #  if defined(GRAN_CHECK)
3450           info_ptr = get_closure_info(bh,
3451                                       &size, &ptrs, &nonptrs, &vhs,
3452                                       info_hdr_ty);
3453           fprintf(stderr, " %s\n",info_hdr_ty);
3454           G_PRINT_NODE(bh);
3455 #  endif
3456           EXIT(EXIT_FAILURE);
3457         }
3458       }
3459     return (0);
3460 }
3461
3462 #endif  /* GRAN */
3463 \end{code}
3464
3465 %****************************************************************************
3466 %
3467 \subsection[qp-profile]{Quasi-Parallel Profiling}
3468 %
3469 %****************************************************************************
3470
3471 \begin{code}
3472 /* ToDo: Check if this is really still used anywhere!? */
3473
3474 I_ do_qp_prof;
3475 FILE *qp_file;
3476
3477 /* *Virtual* Time in milliseconds */
3478 #if !defined(GRAN)
3479 long
3480 qp_elapsed_time(STG_NO_ARGS)
3481 {
3482     extern StgDouble usertime();
3483
3484     return ((long) (usertime() * 1e3));
3485 }
3486 #else
3487 long
3488 qp_elapsed_time(STG_NO_ARGS)
3489 {
3490     return ((long) CurrentTime[CurrentProc] );
3491 }
3492 #endif
3493
3494 static void
3495 init_qp_profiling(STG_NO_ARGS)
3496 {
3497     I_ i;
3498     char qp_filename[STATS_FILENAME_MAXLEN];
3499
3500     sprintf(qp_filename, QP_FILENAME_FMT, prog_argv[0]);
3501     if ((qp_file = fopen(qp_filename,"w")) == NULL ) {
3502         fprintf(stderr, "Can't open quasi-parallel profile report file %s\n",
3503             qp_filename);
3504         do_qp_prof = 0;
3505     } else {
3506         fputs(prog_argv[0], qp_file);
3507         for(i = 1; prog_argv[i]; i++) {
3508             fputc(' ', qp_file);
3509             fputs(prog_argv[i], qp_file);
3510         }
3511         fprintf(qp_file, " +RTS -C%d -t%d\n"
3512                 , RTSflags.ConcFlags.ctxtSwitchTime
3513                 , RTSflags.ConcFlags.maxThreads);
3514
3515         fputs(time_str(), qp_file);
3516         fputc('\n', qp_file);
3517     }
3518 }
3519
3520 void
3521 QP_Event0(tid, node)
3522 I_ tid;
3523 P_ node;
3524 {
3525     fprintf(qp_file, "%lu ** %lu 0x%lx\n", qp_elapsed_time(), tid, INFO_PTR(node));
3526 }
3527
3528 void
3529 QP_Event1(event, tso)
3530 char *event;
3531 P_ tso;
3532 {
3533     fprintf(qp_file, "%lu %s %lu 0x%lx\n", qp_elapsed_time(), event,
3534             TSO_ID(tso), TSO_NAME(tso));
3535 }
3536
3537 void
3538 QP_Event2(event, tso1, tso2)
3539 char *event;
3540 P_ tso1, tso2;
3541 {
3542     fprintf(qp_file, "%lu %s %lu 0x%lx %lu 0x%lx\n", qp_elapsed_time(), event,
3543             TSO_ID(tso1), TSO_NAME(tso1), TSO_ID(tso2), TSO_NAME(tso2));
3544 }
3545
3546 \end{code}
3547
3548 %****************************************************************************
3549 %
3550 \subsection[gc-GrAnSim]{Garbage collection routines for GrAnSim objects}
3551 %
3552 %****************************************************************************
3553
3554 Garbage collection code for the event queue.  We walk the event queue
3555 so that if the only reference to a TSO is in some event (e.g. RESUME),
3556 the TSO is still preserved.
3557
3558 The GC code now uses a breadth-first pruning strategy. This prevents
3559 the GC from keeping all sparks of the low-numbered PEs while discarding all
3560 sparks from high-numbered PEs. Such a depth-first pruning may have
3561 disastrous effects for programs that generate a huge number of sparks!
3562
3563 \begin{code}
3564 #if defined(GRAN)
3565
3566 extern smInfo StorageMgrInfo;
3567
3568 /* Auxiliary functions needed in Save/RestoreSparkRoots if breadth-first */
3569 /* pruning is done. */
3570
3571 static W_
3572 arr_and(W_ arr[], I_ max)
3573 {
3574  I_ i;
3575  W_ res;
3576
3577  /* Doesn't work with max==0; but then, many things don't work in this */
3578  /* special case. */
3579  for (i=1, res = arr[0]; i<max; i++)
3580    res &= arr[i];
3581
3582  return (res);
3583 }
3584
3585 static W_
3586 arr_max(W_ arr[], I_ max)
3587 {
3588  I_ i;
3589  W_ res;
3590
3591  /* Doesn't work with max==0; but then, many things don't work in this */
3592  /* special case. */
3593  for (i=1, res = arr[0]; i<max; i++)
3594    res = (arr[i]>res) ? arr[i] : res;
3595
3596  return (res);
3597 }
3598
3599 /*
3600    Routines working on spark queues.
3601    It would be a good idea to make that an ADT!
3602 */
3603
3604 I_
3605 spark_queue_len(PROC proc, I_ pool)
3606 {
3607  sparkq prev, spark;                           /* prev only for testing !! */
3608  I_ len;
3609
3610  for (len = 0, prev = NULL, spark = PendingSparksHd[proc][pool];
3611       spark != NULL;
3612       len++, prev = spark, spark = SPARK_NEXT(spark))
3613    {}
3614
3615 #  if defined(GRAN_CHECK)
3616   if ( RTSflags.GranFlags.debug & 0x1000 )
3617     if ( (prev!=NULL) && (prev!=PendingSparksTl[proc][pool]) )
3618       fprintf(stderr,"ERROR in spark_queue_len: (PE %u, pool %u) PendingSparksTl (%#lx) not end of queue (%#lx)\n",
3619               proc, pool, PendingSparksTl[proc][pool], prev);
3620 #  endif
3621
3622  return (len);
3623 }
3624
3625 sparkq
3626 delete_from_spark_queue (prev,spark)           /* unlink and dispose spark */
3627 sparkq prev, spark;
3628 {                  /* Global Vars: CurrentProc, SparkQueueHd, SparkQueueTl */
3629   sparkq tmp;
3630
3631 #  if defined(GRAN_CHECK)
3632   if ( RTSflags.GranFlags.debug & 0x10000 ) {
3633     fprintf(stderr,"** |%#x:%#x| prev=%#x->(%#x), (%#x)<-spark=%#x->(%#x) <-(%#x)\n",
3634             SparkQueueHd, SparkQueueTl,
3635             prev, (prev==NULL ? 0 : SPARK_NEXT(prev)),
3636             SPARK_PREV(spark), spark, SPARK_NEXT(spark),
3637             (SPARK_NEXT(spark)==NULL ? 0 : SPARK_PREV(SPARK_NEXT(spark))));
3638   }
3639 #  endif
3640
3641   tmp = SPARK_NEXT(spark);
3642   if (prev==NULL) {
3643         SparkQueueHd = SPARK_NEXT(spark);
3644   } else {
3645         SPARK_NEXT(prev) = SPARK_NEXT(spark);
3646   }
3647   if (SPARK_NEXT(spark)==NULL) {
3648         SparkQueueTl = prev;
3649   } else {
3650         SPARK_PREV(SPARK_NEXT(spark)) = prev;
3651   }
3652   if(SparkQueueHd == NULL)
3653         SparkQueueTl = NULL;
3654   SPARK_NEXT(spark) = NULL;
3655
3656   DisposeSpark(spark);
3657
3658   spark = tmp;
3659 #  if defined(GRAN_CHECK)
3660   if ( RTSflags.GranFlags.debug & 0x10000 ) {
3661     fprintf(stderr,"##    prev=%#x->(%#x)\n",
3662             prev, (prev==NULL ? 0 : SPARK_NEXT(prev)));
3663   }
3664 #  endif
3665   return (tmp);
3666 }
3667
3668 #if 0
3669 /* NB: These functions have been replaced by functions:
3670     EvacuateEvents, EvacuateSparks,  (in  ../storage/SMcopying.lc)
3671     LinkEvents, LinkSparks           (in  ../storage/SMcompacting.lc)
3672    Thus, GrAnSim does not need additional entries in the list of roots
3673    any more.
3674 */
3675
3676 I_
3677 SaveEventRoots(num_ptr_roots)
3678 I_ num_ptr_roots;
3679 {
3680   eventq event = EventHd;
3681   while(event != NULL)
3682     {
3683       if(EVENT_TYPE(event) == RESUMETHREAD ||
3684          EVENT_TYPE(event) == MOVETHREAD ||
3685          EVENT_TYPE(event) == CONTINUETHREAD ||
3686          /* EVENT_TYPE(event) >= CONTINUETHREAD1 ||  */
3687          EVENT_TYPE(event) == STARTTHREAD )
3688         StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
3689
3690       else if(EVENT_TYPE(event) == MOVESPARK)
3691         StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(EVENT_SPARK(event));
3692
3693       else if (EVENT_TYPE(event) == FETCHNODE ||
3694                EVENT_TYPE(event) == FETCHREPLY )
3695         {
3696           StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
3697           /* In the case of packet fetching, EVENT_NODE(event) points to */
3698           /* the packet (currently, malloced). The packet is just a list of */
3699           /* closure addresses, with the length of the list at index 1 (the */
3700           /* structure of the packet is defined in Pack.lc). */
3701           if ( RTSflags.GranFlags.DoGUMMFetching && (EVENT_TYPE(event)==FETCHREPLY)) {
3702             P_ buffer = (P_) EVENT_NODE(event);
3703             int size = (int) buffer[PACK_SIZE_LOCN], i;
3704
3705             for (i = PACK_HDR_SIZE; i <= size-1; i++) {
3706               StorageMgrInfo.roots[num_ptr_roots++] = (P_) buffer[i];
3707             }
3708           } else
3709             StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
3710         }
3711       else if (EVENT_TYPE(event) == GLOBALBLOCK)
3712         {
3713           StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
3714           StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
3715         }
3716       else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
3717         {
3718           StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
3719         }
3720       event = EVENT_NEXT(event);
3721     }
3722   return(num_ptr_roots);
3723 }
3724
3725 #if defined(DEPTH_FIRST_PRUNING)
3726 /* Is it worthwhile keeping the depth-first pruning code !? -- HWL */
3727
3728 I_
3729 SaveSparkRoots(num_ptr_roots)
3730 I_ num_ptr_roots;
3731 {
3732   sparkq spark, /* prev, */ disposeQ=NULL;
3733   PROC proc;
3734   I_ i, sparkroots=0, prunedSparks=0;
3735   I_ tot_sparks[MAX_PROC], tot = 0;;
3736
3737   for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
3738     tot_sparks[proc] = 0;
3739     for(i = 0; i < SPARK_POOLS; ++i) {
3740       for(/* prev = &PendingSparksHd[proc][i],*/ spark = PendingSparksHd[proc][i];
3741           spark != NULL;
3742           /* prev = &SPARK_NEXT(spark), */ spark = SPARK_NEXT(spark))
3743         {
3744           if(++sparkroots <= MAX_SPARKS)
3745             {
3746               if ( RTSflags.GcFlags.giveStats )
3747                 if (i==ADVISORY_POOL) {
3748                   tot_sparks[proc]++;
3749                   tot++;
3750                 }
3751               StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
3752             }
3753           else
3754             {
3755               SPARK_NODE(spark) = Prelude_Z91Z93_closure;
3756               if (prunedSparks==0) {
3757                 disposeQ = spark;
3758                 /*
3759                    *prev = NULL;
3760                 */
3761               }
3762               prunedSparks++;
3763             }
3764         }  /* forall spark ... */
3765         if ( (RTSflags.GcFlags.giveStats) && (prunedSparks>0) ) {
3766           fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %d for GC purposes\n",
3767                   prunedSparks,MAX_SPARKS,proc);
3768           if (disposeQ == PendingSparksHd[proc][i])
3769             PendingSparksHd[proc][i] = NULL;
3770           else
3771             SPARK_NEXT(SPARK_PREV(disposeQ)) = NULL;
3772           DisposeSparkQ(disposeQ);
3773           prunedSparks = 0;
3774           disposeQ = NULL;
3775         }
3776         }  /* forall i ... */
3777     }      /*forall proc .. */
3778
3779   if ( RTSflags.GcFlags.giveStats ) {
3780     fprintf(RTSflags.GcFlags.statsFile,
3781             "Spark statistics (after pruning) (total sparks = %d):",tot);
3782     for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
3783       if (proc % 4 == 0)
3784         fprintf(RTSflags.GcFlags.statsFile,"\n> ");
3785       fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
3786     }
3787     fprintf(RTSflags.GcFlags.statsFile,".\n");
3788   }
3789
3790   return(num_ptr_roots);
3791 }
3792
3793 #else /* !DEPTH_FIRST_PRUNING */
3794
3795 /* In case of an excessive number of sparks, depth first pruning is a Bad */
3796 /* Idea as we might end up with all remaining sparks on processor 0 and */
3797 /* none on the other processors. So, this version uses breadth first */
3798 /* pruning. -- HWL */
3799
3800 I_
3801 SaveSparkRoots(num_ptr_roots)
3802 I_ num_ptr_roots;
3803 {
3804   sparkq spark,
3805          curr_spark[MAX_PROC][SPARK_POOLS];
3806   PROC proc;
3807   W_ allProcs = 0,
3808      endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
3809   I_ i, sparkroots=0,
3810      prunedSparks[MAX_PROC][SPARK_POOLS];
3811   I_ tot_sparks[MAX_PROC], tot = 0;;
3812
3813
3814 #  if defined(GRAN_CHECK) && defined(GRAN)
3815   if ( RTSflags.GranFlags.debug & 0x40 )
3816     fprintf(stderr,"D> Saving spark roots for GC ...\n");
3817 #  endif
3818
3819   /* Init */
3820   for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
3821     allProcs |= PE_NUMBER(proc);
3822     tot_sparks[proc] = 0;
3823     for(i = 0; i < SPARK_POOLS; ++i) {
3824       curr_spark[proc][i] = PendingSparksHd[proc][i];
3825       prunedSparks[proc][i] = 0;
3826       endQueues[i] = 0;
3827       finishedQueues[i] = 0;
3828     }
3829   }
3830
3831   /* Breadth first pruning */
3832   do {
3833     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
3834       for(i = 0; i < SPARK_POOLS; ++i) {
3835         spark = curr_spark[proc][i];
3836         if ( spark != NULL ) {
3837
3838           if(++sparkroots <= MAX_SPARKS)
3839             {
3840 #  if defined(GRAN_CHECK) && defined(GRAN)
3841               if ( (RTSflags.GranFlags.debug & 0x1000) &&
3842                    (RTSflags.GcFlags.giveStats) )
3843                 fprintf(RTSflags.GcFlags.statsFile,"Saving Spark Root %d(proc: %d; pool: %d): 0x%lx \t(info ptr=%#lx)\n",
3844                         num_ptr_roots,proc,i,SPARK_NODE(spark),
3845                         INFO_PTR(SPARK_NODE(spark)));
3846 #  endif
3847               if ( RTSflags.GcFlags.giveStats )
3848                 if (i==ADVISORY_POOL) {
3849                   tot_sparks[proc]++;
3850                   tot++;
3851                 }
3852               StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
3853               curr_spark[proc][i] = spark = SPARK_NEXT(spark);
3854             }
3855           else /* sparkroots > MAX_SPARKS */
3856             {
3857               if (curr_spark[proc][i] == PendingSparksHd[proc][i])
3858                 PendingSparksHd[proc][i] = NULL;
3859               else
3860                 SPARK_NEXT(SPARK_PREV(curr_spark[proc][i])) = NULL;
3861               PendingSparksTl[proc][i] = SPARK_PREV(curr_spark[proc][i]);
3862               endQueues[i] |= PE_NUMBER(proc);
3863             }
3864         } else { /* spark == NULL ; actually, this only has to be done once */
3865           endQueues[i] |= PE_NUMBER(proc);
3866         }
3867       }
3868     }
3869   } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
3870
3871   /* The buffer for spark roots in StorageMgrInfo.roots is full */
3872   /* now. Prune all sparks on all processor starting with */
3873   /* curr_spark[proc][i]. */
3874
3875   do {
3876     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
3877       for(i = 0; i < SPARK_POOLS; ++i) {
3878         spark = curr_spark[proc][i];
3879
3880         if ( spark != NULL ) {
3881           SPARK_NODE(spark) = Prelude_Z91Z93_closure;
3882           curr_spark[proc][i] = SPARK_NEXT(spark);
3883
3884           prunedSparks[proc][i]++;
3885           DisposeSpark(spark);
3886         } else {
3887           finishedQueues[i] |= PE_NUMBER(proc);
3888         }
3889       }
3890     }
3891   } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
3892
3893
3894 #  if defined(GRAN_CHECK) && defined(GRAN)
3895   if ( RTSflags.GranFlags.debug & 0x1000) {
3896     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
3897       for(i = 0; i < SPARK_POOLS; ++i) {
3898         if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][i]>0)) {
3899           fprintf(RTSflags.GcFlags.statsFile,
3900                   "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
3901                   prunedSparks[proc][i],proc,i);
3902         }
3903       }
3904     }
3905
3906     if ( RTSflags.GcFlags.giveStats ) {
3907       fprintf(RTSflags.GcFlags.statsFile,
3908               "Spark statistics (after discarding) (total sparks = %d):",tot);
3909       for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
3910         if (proc % 4 == 0)
3911           fprintf(RTSflags.GcFlags.statsFile,"\n> ");
3912         fprintf(RTSflags.GcFlags.statsFile,
3913                 "\tPE %d: %d ",proc,tot_sparks[proc]);
3914       }
3915       fprintf(RTSflags.GcFlags.statsFile,".\n");
3916     }
3917   }
3918 #  endif
3919
3920   return(num_ptr_roots);
3921 }
3922
3923 #endif  /* DEPTH_FIRST_PRUNING */
3924
3925 /*
3926    GC roots must be restored in *reverse order*.
3927    The recursion is a little ugly, but is better than
3928    in-place pointer reversal.
3929 */
3930
3931 static I_
3932 RestoreEvtRoots(event,num_ptr_roots)
3933 eventq event;
3934 I_ num_ptr_roots;
3935 {
3936   if(event != NULL)
3937     {
3938       num_ptr_roots = RestoreEvtRoots(EVENT_NEXT(event),num_ptr_roots);
3939
3940       if(EVENT_TYPE(event) == RESUMETHREAD ||
3941          EVENT_TYPE(event) == MOVETHREAD ||
3942          EVENT_TYPE(event) == CONTINUETHREAD ||
3943          /* EVENT_TYPE(event) >= CONTINUETHREAD1 ||  */
3944          EVENT_TYPE(event) == STARTTHREAD )
3945         EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
3946
3947       else if(EVENT_TYPE(event) == MOVESPARK )
3948         SPARK_NODE(EVENT_SPARK(event)) = StorageMgrInfo.roots[--num_ptr_roots];
3949
3950       else if (EVENT_TYPE(event) == FETCHNODE ||
3951                EVENT_TYPE(event) == FETCHREPLY )
3952         {
3953           if (  RTSflags.GranFlags.DoGUMMFetching && (EVENT_TYPE(event)==FETCHREPLY)) {
3954             P_ buffer = (P_) EVENT_NODE(event);
3955             int size = (int) buffer[PACK_SIZE_LOCN], i;
3956
3957             for (i = size-1; i >= PACK_HDR_SIZE; i--) {
3958               buffer[i] = StorageMgrInfo.roots[--num_ptr_roots];
3959             }
3960           } else
3961             EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
3962
3963           EVENT_TSO(event) =  StorageMgrInfo.roots[--num_ptr_roots];
3964         }
3965       else if (EVENT_TYPE(event) == GLOBALBLOCK)
3966         {
3967           EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
3968           EVENT_TSO(event) =  StorageMgrInfo.roots[--num_ptr_roots];
3969         }
3970       else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
3971         {
3972           EVENT_TSO(event) =  StorageMgrInfo.roots[--num_ptr_roots];
3973         }
3974     }
3975   return(num_ptr_roots);
3976 }
3977
3978 I_
3979 RestoreEventRoots(num_ptr_roots)
3980 I_ num_ptr_roots;
3981 {
3982   return(RestoreEvtRoots(EventHd,num_ptr_roots));
3983 }
3984
3985 #if defined(DEPTH_FIRST_PRUNING)
3986
3987 static I_
3988 RestoreSpkRoots(spark,num_ptr_roots,sparkroots)
3989 sparkq spark;
3990 I_ num_ptr_roots, sparkroots;
3991 {
3992   if(spark != NULL)
3993     {
3994       num_ptr_roots = RestoreSpkRoots(SPARK_NEXT(spark),num_ptr_roots,++sparkroots);
3995       if(sparkroots <= MAX_SPARKS)
3996         {
3997           P_ n = SPARK_NODE(spark);
3998           SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
3999 #  if defined(GRAN_CHECK) && defined(GRAN)
4000           if ( RTSflags.GranFlags.debug & 0x40 )
4001             fprintf(RTSflags.GcFlags.statsFile,
4002                     "Restoring Spark Root %d: 0x%lx \t(info ptr=%#lx\n",
4003                     num_ptr_roots,SPARK_NODE(spark),
4004                     INFO_PTR(SPARK_NODE(spark)));
4005 #  endif
4006         }
4007 #  if defined(GRAN_CHECK) && defined(GRAN)
4008       else
4009           if ( RTSflags.GranFlags.debug & 0x40 )
4010             fprintf(RTSflags.GcFlags.statsFile,
4011                     "Error in RestoreSpkRoots (%d; @ spark %#lx): More than MAX_SPARKS (%d) sparks\n",
4012                     num_ptr_roots,SPARK_NODE(spark),MAX_SPARKS);
4013 #  endif
4014
4015     }
4016   return(num_ptr_roots);
4017 }
4018
4019 I_
4020 RestoreSparkRoots(num_ptr_roots)
4021 I_ num_ptr_roots;
4022 {
4023   PROC proc;
4024   I_   i;
4025
4026 #if defined(GRAN_JSM_SPARKS)
4027   fprintf(stderr,"Error: RestoreSparkRoots should be never be entered in a JSM style sparks set-up\n");
4028   EXIT(EXIT_FAILURE);
4029 #endif
4030
4031   /* NB: PROC is currently an unsigned datatype i.e. proc>=0 is always */
4032   /* true ((PROC)-1 == (PROC)255). So we need a second clause in the head */
4033   /* of the for loop. For i that is currently not necessary. C is really */
4034   /* impressive in datatype abstraction!   -- HWL */
4035
4036   for(proc = RTSflags.GranFlags.proc - 1; (proc >= 0) && (proc < RTSflags.GranFlags.proc); --proc) {
4037     for(i = SPARK_POOLS - 1; (i >= 0) && (i < SPARK_POOLS) ; --i) {
4038       num_ptr_roots = RestoreSpkRoots(PendingSparksHd[proc][i],num_ptr_roots,0);
4039     }
4040   }
4041   return(num_ptr_roots);
4042 }
4043
4044 #else     /* !DEPTH_FIRST_PRUNING */
4045
4046 I_
4047 RestoreSparkRoots(num_ptr_roots)
4048 I_ num_ptr_roots;
4049 {
4050   sparkq spark,
4051          curr_spark[MAX_PROC][SPARK_POOLS];
4052   PROC   proc;
4053   I_     i, max_len, len, pool, count,
4054          queue_len[MAX_PROC][SPARK_POOLS];
4055
4056   /* NB: PROC is currently an unsigned datatype i.e. proc>=0 is always */
4057   /* true ((PROC)-1 == (PROC)255). So we need a second clause in the head */
4058   /* of the for loop. For i that is currently not necessary. C is really */
4059   /* impressive in datatype abstraction!   -- HWL */
4060
4061   max_len=0;
4062   for (proc=0; proc < RTSflags.GranFlags.proc; proc++) {
4063     for (i=0; i<SPARK_POOLS; i++) {
4064       curr_spark[proc][i] = PendingSparksTl[proc][i];
4065       queue_len[proc][i] = spark_queue_len(proc,i);
4066       max_len = (queue_len[proc][i]>max_len) ? queue_len[proc][i] : max_len;
4067     }
4068   }
4069
4070   for (len=max_len; len > 0; len--){
4071     for(proc = RTSflags.GranFlags.proc - 1; (proc >= 0) && (proc < RTSflags.GranFlags.proc); --proc) {
4072       for(i = SPARK_POOLS - 1; (i >= 0) && (i < SPARK_POOLS) ; --i) {
4073         if (queue_len[proc][i]>=len) {
4074           spark = curr_spark[proc][i];
4075           SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
4076 #  if defined(GRAN_CHECK) && defined(GRAN)
4077           count++;
4078           if ( (RTSflags.GranFlags.debug & 0x1000) &&
4079                (RTSflags.GcFlags.giveStats) )
4080             fprintf(RTSflags.GcFlags.statsFile,
4081                     "Restoring Spark Root %d (PE %u, pool %u): 0x%lx \t(info ptr=%#lx)\n",
4082                     num_ptr_roots,proc,i,SPARK_NODE(spark),
4083                     INFO_PTR(SPARK_NODE(spark)));
4084 #  endif
4085           curr_spark[proc][i] = SPARK_PREV(spark);
4086           /*
4087           num_ptr_roots = RestoreSpkRoots(PendingSparksHd[proc][i],
4088                                           num_ptr_roots,0);
4089          */
4090         }
4091       }
4092     }
4093   }
4094 #  if defined(GRAN_CHECK) && defined(GRAN)
4095   if ( (RTSflags.GranFlags.debug & 0x1000) && (RTSflags.GcFlags.giveStats) )
4096     fprintf(RTSflags.GcFlags.statsFile,"Number of restored spark roots: %d\n",
4097             count);
4098 #  endif
4099   return(num_ptr_roots);
4100 }
4101
4102 #endif  /* DEPTH_FIRST_PRUNING */
4103
4104 #endif  /* 0 */
4105
4106 #endif  /* GRAN */
4107
4108 #endif /* CONCURRENT */ /* the whole module! */
4109 \end{code}
4110
4111