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