ghc/runtime/main/GranSim.lc

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995 - 1996
   3 %     Hans Wolfgang Loidl
   4 %
   5 % Time-stamp: <Wed Jun 19 1996 16:38:25 Stardate: [-31]7683.25 hwloidl>
   6 %
   7 %************************************************************************
   8 %*                                                                      *
   9 \section[GranSim.lc]{Granularity Simulator Routines}
  10 %*                                                                      *
  11 %************************************************************************
  12
  13 Macros for dealing with the new and improved GA field for simulating
  14 parallel execution. Based on @CONCURRENT@ package. The GA field now
  15 contains a mask, where the n-th bit stands for the n-th processor,
  16 where this data can be found. In case of multiple copies, several bits
  17 are set. The total number of processors is bounded by @MAX_PROC@,
  18 which should be <= the length of a word in bits.  -- HWL
  19
  20 \begin{code}
  21 #if defined(GRAN) || defined(PAR)
  22
  23 #define NON_POSIX_SOURCE    /* gettimeofday */
  24
  25 #include "rtsdefs.h"
  26
  27 /* qaStaH nuq Sovpu' ngoqvam ghItlhpu'bogh nuv 'e' vItul */
  28 #  if defined(HAVE_GETCLOCK)
  29 #    if defined(HAVE_SYS_TIMERS_H)
  30 #    define POSIX_4D9 1
  31 #    include <sys/timers.h>
  32 #    endif
  33 #  else
  34 #    if defined(HAVE_GETTIMEOFDAY)
  35 #      if defined(HAVE_SYS_TIME_H)
  36 #      include <sys/time.h>
  37 #      endif
  38 #    else
  39 #      ifdef HAVE_TIME_H
  40 #      include <time.h>
  41 #      endif
  42 #    endif
  43 #  endif
  44 \end{code}
  45
  46
  47 %****************************************************************
  48 %*                                                              *
  49 \subsection[GranSim-data-types]{Basic data types and set-up variables for GranSim}
  50 %*                                                              *
  51 %****************************************************************
  52
  53 \begin{code}
  54
  55 /* See GranSim.lh for the definition of the enum gran_event_types */
  56 char *gran_event_names[] = {
  57     "START", "START(Q)",
  58     "STEALING", "STOLEN", "STOLEN(Q)",
  59     "FETCH", "REPLY", "BLOCK", "RESUME", "RESUME(Q)",
  60     "SCHEDULE", "DESCHEDULE",
  61     "END",
  62     "SPARK", "SPARKAT", "USED", "PRUNED", "EXPORTED", "ACQUIRED",
  63     "ALLOC",
  64     "TERMINATE",
  65     "SYSTEM_START", "SYSTEM_END",           /* only for debugging */
  66     "??"
  67 };
  68
  69 #if defined(GRAN)
  70 char *proc_status_names[] = {
  71   "Idle", "Sparking", "Starting", "Fetching", "Fishing", "Busy",
  72   "UnknownProcStatus"
  73 };
  74
  75 #define RAND_MAX  0x7fffffff    /* 2^31-1 = 0x80000000 - 1 (see lrand48(3)  */
  76
  77 unsigned CurrentProc = 0;
  78 rtsBool IgnoreEvents = rtsFalse; /* HACK only for testing */
  79
  80 #endif  /* GRAN */
  81 \end{code}
  82
  83 The following variables control the behaviour of GrAnSim. In general, there
  84 is one RTS option for enabling each of these features. In getting the
  85 desired setup of GranSim the following questions have to be answered:
  86 \begin{itemize}
  87 \item {\em Which scheduling algorithm} to use (@RTSflags.GranFlags.DoFairSchedule@)?
  88       Currently only unfair scheduling is supported.
  89 \item What to do when remote data is fetched (@RTSflags.GranFlags.DoReScheduleOnFetch@)?
  90       Either block and wait for the
  91       data or reschedule and do some other work.
  92       Thus, if this variable is true, asynchronous communication is
  93       modelled. Block on fetch mainly makes sense for incremental fetching.
  94
  95       There is also a simplified fetch variant available
  96       (@RTSflags.GranFlags.SimplifiedFetch@). This variant does not use events to model
  97       communication. It is faster but the results will be less accurate.
  98 \item How aggressive to be in getting work after a reschedule on fetch
  99       (@RTSflags.GranFlags.FetchStrategy@)?
 100       This is determined by the so-called {\em fetching
 101       strategy\/}. Currently, there are four possibilities:
 102       \begin{enumerate}
 103        \item Only run a runnable thread.
 104        \item Turn a spark into a thread, if necessary.
 105        \item Steal a remote spark, if necessary.
 106        \item Steal a runnable thread from another processor, if necessary.
 107       \end{itemize}
 108       The variable @RTSflags.GranFlags.FetchStrategy@ determines how far to go in this list
 109       when rescheduling on a fetch.
 110 \item Should sparks or threads be stolen first when looking for work
 111       (@RTSflags.GranFlags.DoStealThreadsFirst@)?
 112       The default is to steal sparks first (much cheaper).
 113 \item Should the RTS use a lazy thread creation scheme
 114       (@RTSflags.GranFlags.DoAlwaysCreateThreads@)?  By default yes i.e.\ sparks are only
 115       turned into threads when work is needed. Also note, that sparks
 116       can be discarded by the RTS (this is done in the case of an overflow
 117       of the spark pool). Setting @RTSflags.GranFlags.DoAlwaysCreateThreads@  to @True@ forces
 118       the creation of threads at the next possibility (i.e.\ when new work
 119       is demanded the next time).
 120 \item Should data be fetched closure-by-closure or in packets
 121       (@RTSflags.GranFlags.DoGUMMFetching@)? The default strategy is a GRIP-like incremental
 122       (i.e.\ closure-by-closure) strategy. This makes sense in a
 123       low-latency setting but is bad in a high-latency system. Setting
 124       @RTSflags.GranFlags.DoGUMMFetching@ to @True@ enables bulk (packet) fetching. Other
 125       parameters determine the size of the packets (@pack_buffer_size@) and the number of
 126       thunks that should be put into one packet (@RTSflags.GranFlags.ThunksToPack@).
 127 \item If there is no other possibility to find work, should runnable threads
 128       be moved to an idle processor (@RTSflags.GranFlags.DoThreadMigration@)? In any case, the
 129       RTS tried to get sparks (either local or remote ones) first. Thread
 130       migration is very expensive, since a whole TSO has to be transferred
 131       and probably data locality becomes worse in the process. Note, that
 132       the closure, which will be evaluated next by that TSO is not
 133       transferred together with the TSO (that might block another thread).
 134 \item Should the RTS distinguish between sparks created by local nodes and
 135       stolen sparks (@RTSflags.GranFlags.PreferSparksOfLocalNodes@)?  The idea is to improve
 136       data locality by preferring sparks of local nodes (it is more likely
 137       that the data for those sparks is already on the local processor).
 138       However, such a distinction also imposes an overhead on the spark
 139       queue management, and typically a large number of sparks are
 140       generated during execution. By default this variable is set to @False@.
 141 \item Should the RTS use granularity control mechanisms? The idea of a
 142       granularity control mechanism is to make use of granularity
 143       information provided via annotation of the @par@ construct in order
 144       to prefer bigger threads when either turning a spark into a thread or
 145       when choosing the next thread to schedule. Currently, three such
 146       mechanisms are implemented:
 147       \begin{itemize}
 148         \item Cut-off: The granularity information is interpreted as a
 149               priority. If a threshold priority is given to the RTS, then
 150               only those sparks with a higher priority than the threshold
 151               are actually created. Other sparks are immediately discarded.
 152               This is similar to a usual cut-off mechanism often used in
 153               parallel programs, where parallelism is only created if the
 154               input data is lage enough. With this option, the choice is
 155               hidden in the RTS and only the threshold value has to be
 156               provided as a parameter to the runtime system.
 157         \item Priority Sparking: This mechanism keeps priorities for sparks
 158               and chooses the spark with the highest priority when turning
 159               a spark into a thread. After that the priority information is
 160               discarded. The overhead of this mechanism comes from
 161               maintaining a sorted spark queue.
 162         \item Priority Scheduling: This mechanism keeps the granularity
 163               information for threads, to. Thus, on each reschedule the
 164               largest thread is chosen. This mechanism has a higher
 165               overhead, as the thread queue is sorted, too.
 166        \end{itemize}
 167 \end{itemize}
 168
 169 \begin{code}
 170 #if defined(GRAN)
 171
 172 /* Do we need to reschedule following a fetch? */
 173 rtsBool NeedToReSchedule = rtsFalse;
 174 TIME TimeOfNextEvent, EndOfTimeSlice;   /* checked from the threaded world! */
 175 /* I_ avoidedCS=0; */ /* Unused!! ToDo: Remake libraries and nuke this var */
 176
 177 /* For internal use (event statistics) only */
 178 char *event_names[] =
 179     { "STARTTHREAD", "CONTINUETHREAD", "RESUMETHREAD",
 180       "MOVESPARK", "MOVETHREAD", "FINDWORK",
 181       "FETCHNODE", "FETCHREPLY",
 182       "GLOBALBLOCK", "UNBLOCKTHREAD"
 183     };
 184
 185 # if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
 186 I_ noOfEvents = 0;
 187 I_ event_counts[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 };
 188
 189 I_ fetch_misses = 0;
 190 I_ tot_low_pri_sparks = 0;
 191
 192 I_ rs_sp_count=0, rs_t_count=0, ntimes_total=0, fl_total=0, no_of_steals=0;
 193
 194 /* Variables for gathering packet and queue statistics */
 195 I_ tot_packets = 0, tot_packet_size = 0, tot_cuts = 0, tot_thunks = 0;
 196 I_ tot_sq_len = 0, tot_sq_probes = 0,  tot_sparks = 0, withered_sparks = 0;
 197 I_ tot_add_threads = 0, tot_tq_len = 0, non_end_add_threads = 0;
 198 #  endif
 199
 200 #  if defined(GRAN_COUNT)
 201 /* Count the number of updates that are done. Mainly for testing, but
 202    could be useful for other purposes, too. */
 203 I_ nUPDs = 0, nUPDs_old = 0, nUPDs_new = 0, nUPDs_BQ = 0, nPAPs = 0,
 204    BQ_lens = 0;
 205 #  endif
 206
 207 /* Prototypes */
 208 I_ HandleFetchRequest(P_, PROC, P_);
 209 /* void HandleFetchRequest(P_, PROC, P_);  changed for GUMMFeching */
 210 static I_ blockFetch(P_ tso, PROC proc, P_ bh);
 211
 212 #endif  /* GRAN */
 213 \end{code}
 214
 215 %****************************************************************
 216 %*                                                              *
 217 \subsection[global-address-op]{Global Address Operations}
 218 %*                                                              *
 219 %****************************************************************
 220
 221 These functions perform operations on the global-address (ga) part
 222 of a closure. The ga is the only new field (1 word) in a closure introduced
 223 by GrAnSim. It serves as a bitmask, indicating on which processor
 224 the closure is residing. Since threads are described by Thread State
 225 Object (TSO), which is nothing but another kind of closure, this
 226 scheme allows gives placement information about threads.
 227
 228 A ga is just a bitmask, so the operations on them are mainly bitmask
 229 manipulating functions. Note, that there are important macros like PROCS,
 230 IS_LOCAL_TO etc. They are defined in @GrAnSim.lh@.
 231
 232 NOTE: In GrAnSim-light we don't maintain placement information. This
 233 allows to simulate an arbitrary number  of processors. The price we have
 234 to be is the lack of costing any communication properly. In short,
 235 GrAnSim-light is meant to reveal the maximal parallelism in a program.
 236 From an implementation point of view the important thing is:
 237 {\em GrAnSim-light does not maintain global-addresses}.
 238
 239 \begin{code}
 240 #if defined(GRAN)
 241
 242 /* ga_to_proc returns the first processor marked in the bitmask ga.
 243    Normally only one bit in ga should be set. But for PLCs all bits
 244    are set. That shouldn't hurt since we only need IS_LOCAL_TO for PLCs */
 245
 246 PROC
 247 ga_to_proc(W_ ga)
 248 {
 249     PROC i;
 250     for (i = 0; i < MAX_PROC && !IS_LOCAL_TO(ga, i); i++);
 251     return (i);
 252 }
 253
 254 /* NB: This takes a *node* rather than just a ga as input */
 255 PROC
 256 where_is(P_ node)
 257 { return (ga_to_proc(PROCS(node))); }   /* Access the GA field of the node */
 258
 259 rtsBool
 260 any_idle() {
 261  I_ i;
 262  rtsBool any_idle;
 263  for(i=0, any_idle=rtsFalse;
 264      !any_idle && i<RTSflags.GranFlags.proc;
 265      any_idle = any_idle || IS_IDLE(i), i++)
 266  {} ;
 267 }
 268
 269 int
 270 idlers() {
 271  I_ i, j;
 272  for(i=0, j=0;
 273      i<RTSflags.GranFlags.proc;
 274      j += IS_IDLE(i)?1:0, i++)
 275  {} ;
 276  return j;
 277 }
 278 #endif  /* GRAN */
 279 \end{code}
 280
 281 %****************************************************************
 282 %*                                                              *
 283 \subsection[event-queue]{The Global Event Queue}
 284 %*                                                              *
 285 %****************************************************************
 286
 287 The following routines implement an ADT of an event-queue (FIFO).
 288 ToDo: Put that in an own file(?)
 289
 290 \begin{code}
 291 #if defined(GRAN)
 292
 293 /* Pointer to the global event queue; events are currently malloc'ed */
 294 eventq EventHd = NULL;
 295
 296 eventq
 297 get_next_event()
 298 {
 299   static eventq entry = NULL;
 300
 301   if(EventHd == NULL)
 302     {
 303       fprintf(stderr,"No next event\n");
 304       EXIT(EXIT_FAILURE);
 305     }
 306
 307   if(entry != NULL)
 308     free((char *)entry);
 309
 310 #  if defined(GRAN_CHECK) && defined(GRAN)
 311   if (RTSflags.GranFlags.debug & 0x20) {     /* count events */
 312     noOfEvents++;
 313     event_counts[EVENT_TYPE(EventHd)]++;
 314   }
 315 #  endif
 316
 317   entry = EventHd;
 318   EventHd = EVENT_NEXT(EventHd);
 319   return(entry);
 320 }
 321
 322 /* When getting the time of the next event we ignore CONTINUETHREAD events:
 323    we don't want to be interrupted before the end of the current time slice
 324    unless there is something important to handle.
 325 */
 326 TIME
 327 get_time_of_next_event()
 328 {
 329   eventq event = EventHd;
 330
 331   while (event != NULL && EVENT_TYPE(event)==CONTINUETHREAD) {
 332     event = EVENT_NEXT(event);
 333   }
 334   if(event == NULL)
 335       return ((TIME) 0);
 336   else
 337       return (EVENT_TIME(event));
 338 }
 339
 340 /* ToDo: replace malloc/free with a free list */
 341
 342 static
 343 insert_event(newentry)
 344 eventq newentry;
 345 {
 346   EVTTYPE evttype = EVENT_TYPE(newentry);
 347   eventq event, *prev;
 348
 349   /* if(evttype >= CONTINUETHREAD1) evttype = CONTINUETHREAD; */
 350
 351   /* Search the queue and insert at the right point:
 352      FINDWORK before everything, CONTINUETHREAD after everything.
 353
 354      This ensures that we find any available work after all threads have
 355      executed the current cycle.  This level of detail would normally be
 356      irrelevant, but matters for ridiculously low latencies...
 357   */
 358
 359   /* Changed the ordering: Now FINDWORK comes after everything but
 360      CONTINUETHREAD. This makes sure that a MOVESPARK comes before a
 361      FINDWORK. This is important when a GranSimSparkAt happens and
 362      DoAlwaysCreateThreads is turned on. Also important if a GC occurs
 363      when trying to build a new thread (see much_spark)  -- HWL 02/96  */
 364
 365   if(EventHd == NULL)
 366     EventHd = newentry;
 367   else {
 368     for (event = EventHd, prev=&EventHd;
 369          event != NULL;
 370          prev = &(EVENT_NEXT(event)), event = EVENT_NEXT(event)) {
 371       switch (evttype) {
 372         case FINDWORK: if ( EVENT_TIME(event) < EVENT_TIME(newentry) ||
 373                             ( (EVENT_TIME(event) ==  EVENT_TIME(newentry)) &&
 374                               (EVENT_TYPE(event) != CONTINUETHREAD) ) )
 375                          continue;
 376                        else
 377                          break;
 378         case CONTINUETHREAD: if ( EVENT_TIME(event) <= EVENT_TIME(newentry) )
 379                                continue;
 380                              else
 381                                break;
 382         default: if ( EVENT_TIME(event) < EVENT_TIME(newentry) ||
 383                       ((EVENT_TIME(event) == EVENT_TIME(newentry)) &&
 384                        (EVENT_TYPE(event) == EVENT_TYPE(newentry))) )
 385                    continue;
 386                  else
 387                    break;
 388        }
 389        /* Insert newentry here (i.e. before event) */
 390        *prev = newentry;
 391        EVENT_NEXT(newentry) = event;
 392        break;
 393     }
 394     if (event == NULL)
 395       *prev = newentry;
 396   }
 397 }
 398
 399 void
 400 new_event(proc,creator,time,evttype,tso,node,spark)
 401 PROC proc, creator;
 402 TIME time;
 403 EVTTYPE evttype;
 404 P_ tso, node;
 405 sparkq spark;
 406 {
 407   eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "new_event");
 408
 409   EVENT_PROC(newentry) = proc;
 410   EVENT_CREATOR(newentry) = creator;
 411   EVENT_TIME(newentry) = time;
 412   EVENT_TYPE(newentry) = evttype;
 413   EVENT_TSO(newentry) =  tso;
 414   EVENT_NODE(newentry) =  node;
 415   EVENT_SPARK(newentry) =  spark;
 416   EVENT_GC_INFO(newentry) =  0;
 417   EVENT_NEXT(newentry) = NULL;
 418
 419   insert_event(newentry);
 420 }
 421
 422 void
 423 prepend_event(eventq event)       /* put event at beginning of EventQueue */
 424 {                                 /* only used for GC! */
 425  EVENT_NEXT(event) = EventHd;
 426  EventHd = event;
 427 }
 428
 429 eventq
 430 grab_event()             /* undo prepend_event i.e. get the event */
 431 {                        /* at the head of EventQ but don't free anything */
 432  eventq event = EventHd;
 433
 434  if(EventHd == NULL) {
 435    fprintf(stderr,"No next event (in grab_event)\n");
 436    EXIT(EXIT_FAILURE);
 437  }
 438
 439  EventHd = EVENT_NEXT(EventHd);
 440  return (event);
 441 }
 442
 443 void
 444 print_event(event)
 445 eventq event;
 446 {
 447
 448   char str_tso[16], str_node[16];
 449
 450   sprintf(str_tso,((EVENT_TSO(event)==Prelude_Z91Z93_closure) ? "______" : "%#6lx"),
 451                   EVENT_TSO(event));
 452   sprintf(str_node,((EVENT_NODE(event)==Prelude_Z91Z93_closure) ? "______" : "%#6lx"),
 453                     EVENT_NODE(event));
 454
 455   if (event==NULL)
 456     fprintf(stderr,"Evt: NIL\n");
 457   else
 458     fprintf(stderr,"Evt: %s (%u), PE %u [%u], Time %lu, TSO %s (%x), node %s\n",
 459               event_names[EVENT_TYPE(event)],EVENT_TYPE(event),
 460               EVENT_PROC(event), EVENT_CREATOR(event), EVENT_TIME(event),
 461               str_tso, TSO_ID(EVENT_TSO(event)), str_node
 462               /*, EVENT_SPARK(event), EVENT_NEXT(event)*/ );
 463
 464 }
 465
 466 void
 467 print_eventq(hd)
 468 eventq hd;
 469 {
 470   eventq x;
 471
 472   fprintf(stderr,"Event Queue with root at %x:\n",hd);
 473   for (x=hd; x!=NULL; x=EVENT_NEXT(x)) {
 474     print_event(x);
 475   }
 476 }
 477
 478 void
 479 print_spark(spark)
 480   sparkq spark;
 481 {
 482   char str[16];
 483
 484   sprintf(str,((SPARK_NODE(spark)==Prelude_Z91Z93_closure) ? "______" : "%#6lx"),
 485               (W_) SPARK_NODE(spark));
 486
 487   if (spark==NULL)
 488     fprintf(stderr,"Spark: NIL\n");
 489   else
 490     fprintf(stderr,"Spark: Node %8s, Name %#6lx, Exported %5s, Prev %#6x, Next %#6x\n",
 491             str, SPARK_NAME(spark),
 492             ((SPARK_EXPORTED(spark))?"True":"False"),
 493             SPARK_PREV(spark), SPARK_NEXT(spark) );
 494 }
 495
 496 void
 497 print_sparkq(hd)
 498 sparkq hd;
 499 {
 500   sparkq x;
 501
 502   fprintf(stderr,"Spark Queue with root at %x:\n",hd);
 503   for (x=hd; x!=NULL; x=SPARK_NEXT(x)) {
 504     print_spark(x);
 505   }
 506 }
 507
 508
 509 #endif  /* GRAN */
 510 \end{code}
 511
 512 %****************************************************************************
 513 %
 514 \subsection[entry-points]{Routines directly called from Haskell world}
 515 %
 516 %****************************************************************************
 517
 518 The @GranSim...@ routines in here are directly called via macros from the
 519 threaded world.
 520
 521 First some auxiliary routines.
 522
 523 \begin{code}
 524 #if defined(GRAN)
 525 /* Take the current thread off the thread queue and thereby activate the */
 526 /* next thread. It's assumed that the next ReSchedule after this uses */
 527 /* NEW_THREAD as param. */
 528 /* This fct is called from GranSimBlock and GranSimFetch */
 529
 530 void
 531 ActivateNextThread (PROC proc)
 532 {
 533   ASSERT(RunnableThreadsHd[proc]!=Prelude_Z91Z93_closure);
 534
 535   RunnableThreadsHd[proc] = TSO_LINK(RunnableThreadsHd[proc]);
 536   if(RunnableThreadsHd[proc]==Prelude_Z91Z93_closure) {
 537     MAKE_IDLE(proc);
 538     RunnableThreadsTl[proc] = Prelude_Z91Z93_closure;
 539   } else {
 540     CurrentTime[proc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
 541     if (RTSflags.GranFlags.granSimStats &&
 542         (!RTSflags.GranFlags.Light || (RTSflags.GranFlags.debug & 0x20000)))
 543       DumpRawGranEvent(proc,0,GR_SCHEDULE,RunnableThreadsHd[proc],
 544                        Prelude_Z91Z93_closure,0);
 545   }
 546 }
 547 \end{code}
 548
 549 Now the main stg-called routines:
 550
 551 \begin{code}
 552 /* ------------------------------------------------------------------------ */
 553 /* The following GranSim... fcts are stg-called from the threaded world.    */
 554 /* ------------------------------------------------------------------------ */
 555
 556 /* Called from HEAP_CHK  -- NB: node and liveness are junk here now.
 557    They are left temporarily to avoid complete recompilation.
 558    KH
 559 */
 560 void
 561 GranSimAllocate(n,node,liveness)
 562 I_ n;
 563 P_ node;
 564 W_ liveness;
 565 {
 566   TSO_ALLOCS(CurrentTSO) += n;
 567   ++TSO_BASICBLOCKS(CurrentTSO);
 568
 569   if (RTSflags.GranFlags.granSimStats_Heap) {
 570       DumpRawGranEvent(CurrentProc,0,GR_ALLOC,CurrentTSO,
 571                        Prelude_Z91Z93_closure,n);
 572   }
 573
 574   TSO_EXECTIME(CurrentTSO) += RTSflags.GranFlags.gran_heapalloc_cost;
 575   CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_heapalloc_cost;
 576 }
 577
 578 /*
 579   Subtract the values added above, if a heap check fails and
 580   so has to be redone.
 581 */
 582 void
 583 GranSimUnallocate(n,node,liveness)
 584 W_ n;
 585 P_ node;
 586 W_ liveness;
 587 {
 588   TSO_ALLOCS(CurrentTSO) -= n;
 589   --TSO_BASICBLOCKS(CurrentTSO);
 590
 591   TSO_EXECTIME(CurrentTSO) -= RTSflags.GranFlags.gran_heapalloc_cost;
 592   CurrentTime[CurrentProc] -= RTSflags.GranFlags.gran_heapalloc_cost;
 593 }
 594
 595 /* NB: We now inline this code via GRAN_EXEC rather than calling this fct */
 596 void
 597 GranSimExec(ariths,branches,loads,stores,floats)
 598 W_ ariths,branches,loads,stores,floats;
 599 {
 600   W_ cost = RTSflags.GranFlags.gran_arith_cost*ariths +
 601             RTSflags.GranFlags.gran_branch_cost*branches +
 602             RTSflags.GranFlags.gran_load_cost * loads +
 603             RTSflags.GranFlags.gran_store_cost*stores +
 604             RTSflags.GranFlags.gran_float_cost*floats;
 605
 606   TSO_EXECTIME(CurrentTSO) += cost;
 607   CurrentTime[CurrentProc] += cost;
 608 }
 609
 610
 611 /*
 612    Fetch the node if it isn't local
 613    -- result indicates whether fetch has been done.
 614
 615    This is GRIP-style single item fetching.
 616 */
 617
 618 /* This function in Threads.lc is only needed for SimplifiedFetch */
 619 FetchNode PROTO((P_ node,PROC CurrentProc));
 620
 621 I_
 622 GranSimFetch(node /* , liveness_mask */ )
 623 P_ node;
 624 /* I_ liveness_mask; */
 625 {
 626   if (RTSflags.GranFlags.Light) {
 627      /* Always reschedule in GrAnSim-Light to prevent one TSO from
 628         running off too far
 629      new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
 630               CONTINUETHREAD,CurrentTSO,node,NULL);
 631      */
 632      NeedToReSchedule = rtsFalse;
 633      return(0);
 634   }
 635
 636   /* Note: once a node has been fetched, this test will be passed */
 637   if(!IS_LOCAL_TO(PROCS(node),CurrentProc))
 638     {
 639       /* Add mpacktime to the remote PE for the reply */
 640         {
 641           PROC p = where_is(node);
 642           TIME fetchtime;
 643
 644 #  ifdef GRAN_CHECK
 645           if ( ( RTSflags.GranFlags.debug & 0x40 ) &&
 646                p == CurrentProc )
 647             fprintf(stderr,"GranSimFetch: Trying to fetch from own processor%u\n", p);
 648 #  endif  /* GRAN_CHECK */
 649
 650           CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
 651           /* NB: Fetch is counted on arrival (FETCHREPLY) */
 652
 653           if (RTSflags.GranFlags.SimplifiedFetch)
 654             {
 655               FetchNode(node,CurrentProc);
 656               CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime+
 657                                           RTSflags.GranFlags.gran_fetchtime+
 658                                           RTSflags.GranFlags.gran_munpacktime;
 659               return(1);
 660             }
 661
 662           fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
 663                       RTSflags.GranFlags.gran_latency;
 664
 665           new_event(p,CurrentProc,fetchtime,FETCHNODE,CurrentTSO,node,NULL);
 666           if (!RTSflags.GranFlags.DoReScheduleOnFetch)
 667             MAKE_FETCHING(CurrentProc);
 668           ++OutstandingFetches[CurrentProc];
 669
 670           if (fetchtime<TimeOfNextEvent)
 671             TimeOfNextEvent = fetchtime;
 672
 673           /* About to block */
 674           TSO_BLOCKEDAT(CurrentTSO) = CurrentTime[CurrentProc];
 675
 676           if (RTSflags.GranFlags.DoReScheduleOnFetch)
 677             {
 678               /* Remove CurrentTSO from the queue
 679                  -- assumes head of queue == CurrentTSO */
 680               if(!RTSflags.GranFlags.DoFairSchedule)
 681                 {
 682                   if(RTSflags.GranFlags.granSimStats)
 683                     DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,
 684                                      node,0);
 685
 686                   ActivateNextThread(CurrentProc);
 687
 688 #  if defined(GRAN_CHECK)
 689                   if (RTSflags.GranFlags.debug & 0x10) {
 690                     if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
 691                       fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
 692                               CurrentTSO,CurrentTime[CurrentProc]);
 693                       EXIT(EXIT_FAILURE);
 694                     } else {
 695                       TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
 696                     }
 697                   }
 698 #  endif
 699                   TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
 700                   /* CurrentTSO = Prelude_Z91Z93_closure; */
 701
 702                   /* ThreadQueueHd is now the next TSO to schedule or NULL */
 703                   /* CurrentTSO is pointed to by the FETCHNODE event */
 704                 }
 705               else  /* fair scheduling currently not supported -- HWL */
 706                 {
 707                   fprintf(stderr,"Reschedule-on-fetch is not yet compatible with fair scheduling\n");
 708                   EXIT(EXIT_FAILURE);
 709                 }
 710             }
 711           else                 /* !RTSflags.GranFlags.DoReScheduleOnFetch */
 712             {
 713               /* Note: CurrentProc is still busy as it's blocked on fetch */
 714               if(RTSflags.GranFlags.granSimStats)
 715                 DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,node,0);
 716
 717 #  if defined(GRAN_CHECK)
 718               if (RTSflags.GranFlags.debug & 0x04)
 719                 BlockedOnFetch[CurrentProc] = CurrentTSO; /*- rtsTrue; -*/
 720               if (RTSflags.GranFlags.debug & 0x10) {
 721                 if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
 722                   fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
 723                           CurrentTSO,CurrentTime[CurrentProc]);
 724                   EXIT(EXIT_FAILURE);
 725                 } else {
 726                   TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
 727                 }
 728                 CurrentTSO = Prelude_Z91Z93_closure;
 729               }
 730 #  endif
 731             }
 732           CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
 733
 734           /* Rescheduling is necessary */
 735           NeedToReSchedule = rtsTrue;
 736
 737           return(1);
 738         }
 739     }
 740   return(0);
 741 }
 742
 743 void
 744 GranSimSpark(local,node)
 745 W_ local;
 746 P_ node;
 747 {
 748   /* ++SparksAvail;  Nope; do that in add_to_spark_queue */
 749   if(RTSflags.GranFlags.granSimStats_Sparks)
 750     DumpRawGranEvent(CurrentProc,(PROC)0,SP_SPARK,Prelude_Z91Z93_closure,node,
 751                        spark_queue_len(CurrentProc,ADVISORY_POOL)-1);
 752
 753   /* Force the PE to take notice of the spark */
 754   if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
 755     new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
 756              FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
 757     if (CurrentTime[CurrentProc]<TimeOfNextEvent)
 758       TimeOfNextEvent = CurrentTime[CurrentProc];
 759   }
 760
 761   if(local)
 762     ++TSO_LOCALSPARKS(CurrentTSO);
 763   else
 764     ++TSO_GLOBALSPARKS(CurrentTSO);
 765 }
 766
 767 void
 768 GranSimSparkAt(spark,where,identifier)
 769 sparkq spark;
 770 P_  where;        /* This should be a node; alternatively could be a GA */
 771 I_ identifier;
 772 {
 773   PROC p = where_is(where);
 774   GranSimSparkAtAbs(spark,p,identifier);
 775 }
 776
 777 void
 778 GranSimSparkAtAbs(spark,proc,identifier)
 779 sparkq spark;
 780 PROC proc;
 781 I_ identifier;
 782 {
 783   TIME exporttime;
 784
 785   if ( spark == (sparkq)NULL)    /* Note: Granularity control might have */
 786     return;                      /* turned a spark into a NULL. */
 787
 788   /* ++SparksAvail; Nope; do that in add_to_spark_queue */
 789   if(RTSflags.GranFlags.granSimStats_Sparks)
 790     DumpRawGranEvent(proc,0,SP_SPARKAT,Prelude_Z91Z93_closure,SPARK_NODE(spark),
 791                      spark_queue_len(proc,ADVISORY_POOL));
 792
 793   if (proc!=CurrentProc) {
 794     CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
 795     exporttime = (CurrentTime[proc] > CurrentTime[CurrentProc]?
 796                   CurrentTime[proc]: CurrentTime[CurrentProc])
 797                  + RTSflags.GranFlags.gran_latency;
 798   } else {
 799     exporttime = CurrentTime[CurrentProc];
 800   }
 801
 802   if ( RTSflags.GranFlags.Light )
 803     /* Need CurrentTSO in event field to associate costs with creating
 804        spark even in a GrAnSim Light setup */
 805     new_event(proc,CurrentProc,exporttime,
 806              MOVESPARK,CurrentTSO,Prelude_Z91Z93_closure,spark);
 807   else
 808     new_event(proc,CurrentProc,exporttime,
 809              MOVESPARK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,spark);
 810   /* Bit of a hack to treat placed sparks the same as stolen sparks */
 811   ++OutstandingFishes[proc];
 812
 813   /* Force the PE to take notice of the spark (FINDWORK is put after a
 814      MOVESPARK into the sparkq!) */
 815   if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
 816     new_event(CurrentProc,CurrentProc,exporttime+1,
 817               FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
 818   }
 819
 820   if (exporttime<TimeOfNextEvent)
 821     TimeOfNextEvent = exporttime;
 822
 823   if (proc!=CurrentProc) {
 824     CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
 825     ++TSO_GLOBALSPARKS(CurrentTSO);
 826   } else {
 827     ++TSO_LOCALSPARKS(CurrentTSO);
 828   }
 829 }
 830
 831 /* This function handles local and global blocking */
 832 /* It's called either from threaded code (RBH_entry, BH_entry etc) or */
 833 /* from blockFetch when trying to fetch an BH or RBH */
 834
 835 void
 836 GranSimBlock(P_ tso, PROC proc, P_ node)
 837 {
 838   PROC node_proc = where_is(node);
 839
 840   ASSERT(tso==RunnableThreadsHd[proc]);
 841
 842   if(RTSflags.GranFlags.granSimStats)
 843     DumpRawGranEvent(proc,node_proc,GR_BLOCK,tso,node,0);
 844
 845   ++TSO_BLOCKCOUNT(tso);
 846   /* Distinction  between local and global block is made in blockFetch */
 847   TSO_BLOCKEDAT(tso) = CurrentTime[proc];
 848
 849   CurrentTime[proc] += RTSflags.GranFlags.gran_threadqueuetime;
 850   ActivateNextThread(proc);
 851   TSO_LINK(tso) = Prelude_Z91Z93_closure;  /* not really necessary; only for testing */
 852 }
 853
 854 #endif  /* GRAN */
 855
 856 \end{code}
 857
 858 %****************************************************************************
 859 %
 860 \subsection[GrAnSim-profile]{Writing profiling info for GrAnSim}
 861 %
 862 %****************************************************************************
 863
 864 Event dumping routines.
 865
 866 \begin{code}
 867
 868 /*
 869  * If you're not using GNUC and you're on a 32-bit machine, you're
 870  * probably out of luck here.  However, since CONCURRENT currently
 871  * requires GNUC, I'm not too worried about it.  --JSM
 872  */
 873
 874 #if !defined(GRAN)
 875
 876 static ullong startTime = 0;
 877
 878 ullong
 879 msTime(STG_NO_ARGS)
 880 {
 881 # ifdef HAVE_GETCLOCK
 882     struct timespec tv;
 883
 884     if (getclock(TIMEOFDAY, &tv) != 0) {
 885         fflush(stdout);
 886         fprintf(stderr, "Clock failed\n");
 887         EXIT(EXIT_FAILURE);
 888     }
 889     return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime;
 890 # else
 891 # ifdef HAVE_GETTIMEOFDAY
 892     struct timeval tv;
 893
 894     if (gettimeofday(&tv, NULL) != 0) {
 895         fflush(stdout);
 896         fprintf(stderr, "Clock failed\n");
 897         EXIT(EXIT_FAILURE);
 898     }
 899     return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
 900 # else
 901     time_t t;
 902     if ((t = time(NULL)) == (time_t) -1) {
 903         fflush(stdout);
 904         fprintf(stderr, "Clock failed\n");
 905         EXIT(EXIT_FAILURE);
 906     }
 907     return t * LL(1000);
 908 # endif
 909 # endif
 910 }
 911
 912 #endif /* !GRAN */
 913
 914 #if defined(GRAN) || defined(PAR)
 915
 916 void
 917 DumpGranEvent(name, tso)
 918 enum gran_event_types name;
 919 P_ tso;
 920 {
 921     DumpRawGranEvent(CURRENT_PROC, (PROC)0, name, tso, Prelude_Z91Z93_closure, 0);
 922 }
 923
 924 void
 925 DumpRawGranEvent(proc, p, name, tso, node, len)
 926 PROC proc, p;         /* proc ... where it happens; p ... where node lives */
 927 enum gran_event_types name;
 928 P_ tso, node;
 929 I_ len;
 930 {
 931   W_ id;
 932   char time_string[500], node_str[16]; /*ToDo: kill magic constants */
 933   ullong_format_string(TIME_ON_PROC(proc), time_string, rtsFalse/*no commas!*/);
 934 #if defined(GRAN)
 935   if (RTSflags.GranFlags.granSimStats_suppressed)
 936     return;
 937 #endif
 938
 939   id = tso == NULL ? -1 : TSO_ID(tso);
 940   if (node==Prelude_Z91Z93_closure)
 941       strcpy(node_str,"________");  /* "Prelude_Z91Z93_closure"); */
 942   else
 943       sprintf(node_str,"0x%-6lx",node);
 944
 945   if (name > GR_EVENT_MAX)
 946         name = GR_EVENT_MAX;
 947
 948   if(GRANSIMSTATS_BINARY)
 949     /* ToDo: fix code for writing binary GrAnSim statistics */
 950     switch (name) {
 951       case GR_START:
 952       case GR_STARTQ:
 953                       grputw(name);
 954                       grputw(proc);
 955                       abort();        /* die please: a single word */
 956                                       /* doesn't represent long long times */
 957                       grputw(TIME_ON_PROC(proc));
 958                       grputw((W_)node);
 959                       break;
 960       case GR_FETCH:
 961       case GR_REPLY:
 962       case GR_BLOCK:
 963                       grputw(name);
 964                       grputw(proc);
 965                       abort();        /* die please: a single word */
 966                                       /* doesn't represent long long times */
 967                       grputw(TIME_ON_PROC(proc));  /* this line is bound to */
 968                       grputw(id);                  /*   do the wrong thing */
 969                       break;
 970       default:
 971                       grputw(name);
 972                       grputw(proc);
 973                       abort();        /* die please: a single word */
 974                                       /* doesn't represent long long times */
 975                       grputw(TIME_ON_PROC(proc));
 976                       grputw((W_)node);
 977     }
 978   else
 979     switch (name) {
 980      case GR_START:
 981      case GR_STARTQ:
 982         /* fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n", */
 983         /* using spark queue length as optional argument ^^^^^^^^^ */
 984         fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[SN %u]\n",
 985         /* using spark name as optional argument     ^^^^^^ */
 986                 proc,time_string,gran_event_names[name],
 987                 id,node_str,(len & NEW_SPARKNAME_MASK));
 988         break;
 989      case GR_FETCH:
 990      case GR_REPLY:
 991      case GR_BLOCK:
 992      case GR_STOLEN:
 993      case GR_STOLENQ:
 994         fprintf(gr_file, "PE %2u [%s]: %-9s\t%lx \t%s\t(from %2u)\n",
 995                 proc, time_string, gran_event_names[name],
 996                 id,node_str,p);
 997         break;
 998      case GR_RESUME:
 999      case GR_RESUMEQ:
1000      case GR_SCHEDULE:
1001      case GR_DESCHEDULE:
1002         fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx \n",
1003                 proc,time_string,gran_event_names[name],id);
1004         break;
1005      case GR_STEALING:
1006         fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t        \t(by %2u)\n",
1007                 proc,time_string,gran_event_names[name],id,p);
1008         break;
1009      case GR_ALLOC:
1010         fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t        \tallocating %u words\n",
1011                 proc,time_string,gran_event_names[name],id,len);
1012         break;
1013      default:
1014         fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n",
1015                 proc,time_string,gran_event_names[name],id,node_str,len);
1016     }
1017 }
1018
1019
1020 #if defined(GRAN)
1021 /* Only needed for special dynamic spark labelling support */
1022 void
1023 DumpStartEventAt(time, proc, p, name, tso, node, len)
1024 TIME time;
1025 PROC proc, p;         /* proc ... where it happens; p ... where node lives */
1026 enum gran_event_types name;
1027 P_ tso, node;
1028 I_ len;
1029 {
1030   W_ id;
1031   char time_string[500], node_str[16]; /*ToDo: kill magic constants */
1032   ullong_format_string(time, time_string, rtsFalse/*no commas!*/);
1033                     /* ^^^^ only important change to DumpRawGranEvent */
1034   if (RTSflags.GranFlags.granSimStats_suppressed)
1035     return;
1036
1037   id = tso == NULL ? -1 : TSO_ID(tso);
1038   if (node==Nil_closure)
1039       strcpy(node_str,"________");  /* "Nil_closure"); */
1040   else
1041       sprintf(node_str,"0x%-6lx",node);
1042
1043   if (name > GR_EVENT_MAX)
1044         name = GR_EVENT_MAX;
1045
1046   if(GRANSIMSTATS_BINARY)
1047     /* ToDo: fix code for writing binary GrAnSim statistics */
1048     switch (name) {
1049       case GR_START:
1050       case GR_STARTQ:
1051                       grputw(name);
1052                       grputw(proc);
1053                       abort();        /* die please: a single word */
1054                                       /* doesn't represent long long times */
1055                       grputw(TIME_ON_PROC(proc));
1056                       grputw((W_)node);
1057                       break;
1058      default:
1059         fprintf(stderr,"Error in DumpStartEventAt: event %s is not a START event\n",
1060                 gran_event_names[name]);
1061     }
1062   else
1063     switch (name) {
1064      case GR_START:
1065      case GR_STARTQ:
1066         /* fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n", */
1067         /* using spark queue length as optional argument ^^^^^^^^^ */
1068         fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[SN %u]\n",
1069         /* using spark name as optional argument     ^^^^^^ */
1070                 proc,time_string,gran_event_names[name],
1071                 id,node_str,(len & NEW_SPARKNAME_MASK));
1072         break;
1073      default:
1074         fprintf(stderr,"Error in DumpStartEventAt: event %s is not a START event\n",
1075                 gran_event_names[name]);
1076     }
1077 }
1078 #endif  /* GRAN  */
1079
1080 void
1081 DumpGranInfo(proc, tso, mandatory_thread)
1082 PROC proc;
1083 P_ tso;
1084 rtsBool mandatory_thread;
1085 {
1086     char time_string[500]; /* ToDo: kill magic constant */
1087     ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
1088
1089 #if defined(GRAN)
1090     if (RTSflags.GranFlags.granSimStats_suppressed)
1091       return;
1092 #endif
1093
1094     if (GRANSIMSTATS_BINARY) {
1095         grputw(GR_END);
1096         grputw(proc);
1097         abort(); /* die please: a single word doesn't represent long long times */
1098         grputw(CURRENT_TIME); /* this line is bound to fail */
1099         grputw(TSO_ID(tso));
1100 #ifdef PAR
1101         grputw(0);
1102         grputw(0);
1103         grputw(0);
1104         grputw(0);
1105         grputw(0);
1106         grputw(0);
1107         grputw(0);
1108         grputw(0);
1109         grputw(0);
1110         grputw(0);
1111         grputw(0);
1112         grputw(0);
1113 #else
1114         grputw(TSO_SPARKNAME(tso));
1115         grputw(TSO_STARTEDAT(tso));
1116         grputw(TSO_EXPORTED(tso));
1117         grputw(TSO_BASICBLOCKS(tso));
1118         grputw(TSO_ALLOCS(tso));
1119         grputw(TSO_EXECTIME(tso));
1120         grputw(TSO_BLOCKTIME(tso));
1121         grputw(TSO_BLOCKCOUNT(tso));
1122         grputw(TSO_FETCHTIME(tso));
1123         grputw(TSO_FETCHCOUNT(tso));
1124         grputw(TSO_LOCALSPARKS(tso));
1125         grputw(TSO_GLOBALSPARKS(tso));
1126 #endif
1127         grputw(mandatory_thread);
1128     } else {
1129
1130         /*
1131          * NB: DumpGranEvent cannot be used because PE may be wrong
1132          * (as well as the extra info)
1133          */
1134         fprintf(gr_file, "PE %2u [%s]: END %lx, SN %lu, ST %lu, EXP %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu), LS %lu, GS %lu, MY %c\n"
1135           ,proc
1136           ,time_string
1137           ,TSO_ID(tso)
1138           ,TSO_SPARKNAME(tso)
1139           ,TSO_STARTEDAT(tso)
1140           ,TSO_EXPORTED(tso) ? 'T' : 'F'
1141           ,TSO_BASICBLOCKS(tso)
1142           ,TSO_ALLOCS(tso)
1143           ,TSO_EXECTIME(tso)
1144           ,TSO_BLOCKTIME(tso)
1145           ,TSO_BLOCKCOUNT(tso)
1146           ,TSO_FETCHTIME(tso)
1147           ,TSO_FETCHCOUNT(tso)
1148           ,TSO_LOCALSPARKS(tso)
1149           ,TSO_GLOBALSPARKS(tso)
1150           ,mandatory_thread ? 'T' : 'F'
1151           );
1152     }
1153 }
1154
1155 void
1156 DumpTSO(tso)
1157 P_ tso;
1158 {
1159   fprintf(stderr,"TSO 0x%lx, NAME 0x%lx, ID %lu, LINK 0x%lx, TYPE %s\n"
1160           ,tso
1161           ,TSO_NAME(tso)
1162           ,TSO_ID(tso)
1163           ,TSO_LINK(tso)
1164           ,TSO_TYPE(tso)==T_MAIN?"MAIN":
1165            TSO_TYPE(tso)==T_FAIL?"FAIL":
1166            TSO_TYPE(tso)==T_REQUIRED?"REQUIRED":
1167            TSO_TYPE(tso)==T_ADVISORY?"ADVISORY":
1168            "???"
1169           );
1170
1171   fprintf(stderr,"PC (0x%lx,0x%lx), ARG (0x%lx), SWITCH %lx0x\n"
1172           ,TSO_PC1(tso)
1173           ,TSO_PC2(tso)
1174           ,TSO_ARG1(tso)
1175           /* ,TSO_ARG2(tso) */
1176           ,TSO_SWITCH(tso)
1177           );
1178
1179   fprintf(gr_file,"TSO %lx: SN %lu, ST %lu, GBL %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu) LS %lu, GS %lu\n"
1180           ,TSO_ID(tso)
1181           ,TSO_SPARKNAME(tso)
1182           ,TSO_STARTEDAT(tso)
1183           ,TSO_EXPORTED(tso)?'T':'F'
1184           ,TSO_BASICBLOCKS(tso)
1185           ,TSO_ALLOCS(tso)
1186           ,TSO_EXECTIME(tso)
1187           ,TSO_BLOCKTIME(tso)
1188           ,TSO_BLOCKCOUNT(tso)
1189           ,TSO_FETCHTIME(tso)
1190           ,TSO_FETCHCOUNT(tso)
1191           ,TSO_LOCALSPARKS(tso)
1192           ,TSO_GLOBALSPARKS(tso)
1193           );
1194 }
1195
1196 /*
1197    Output a terminate event and an 8-byte time.
1198 */
1199
1200 void
1201 grterminate(v)
1202 TIME v;
1203 {
1204 #if defined(GRAN)
1205     if (RTSflags.GranFlags.granSimStats_suppressed)
1206       return;
1207 #endif
1208
1209     DumpGranEvent(GR_TERMINATE, Prelude_Z91Z93_closure);
1210
1211     if (sizeof(TIME) == 4) {
1212         putc('\0', gr_file);
1213         putc('\0', gr_file);
1214         putc('\0', gr_file);
1215         putc('\0', gr_file);
1216     } else {
1217         putc(v >> 56l, gr_file);
1218         putc((v >> 48l) & 0xffl, gr_file);
1219         putc((v >> 40l) & 0xffl, gr_file);
1220         putc((v >> 32l) & 0xffl, gr_file);
1221     }
1222     putc((v >> 24l) & 0xffl, gr_file);
1223     putc((v >> 16l) & 0xffl, gr_file);
1224     putc((v >> 8l) & 0xffl, gr_file);
1225     putc(v & 0xffl, gr_file);
1226 }
1227
1228 /*
1229    Length-coded output: first 3 bits contain length coding
1230
1231      00x        1 byte
1232      01x        2 bytes
1233      10x        4 bytes
1234      110        8 bytes
1235      111        5 or 9 bytes
1236 */
1237
1238 void
1239 grputw(v)
1240 TIME v;
1241 {
1242 #if defined(GRAN)
1243     if (RTSflags.GranFlags.granSimStats_suppressed)
1244       return;
1245 #endif
1246
1247     if (v <= 0x3fl) {                           /* length v = 1 byte */
1248         fputc(v & 0x3f, gr_file);
1249     } else if (v <= 0x3fffl) {                  /* length v = 2 byte */
1250         fputc((v >> 8l) | 0x40l, gr_file);
1251         fputc(v & 0xffl, gr_file);
1252     } else if (v <= 0x3fffffffl) {              /* length v = 4 byte */
1253         fputc((v >> 24l) | 0x80l, gr_file);
1254         fputc((v >> 16l) & 0xffl, gr_file);
1255         fputc((v >> 8l) & 0xffl, gr_file);
1256         fputc(v & 0xffl, gr_file);
1257     } else if (sizeof(TIME) == 4) {
1258         fputc(0x70, gr_file);
1259         fputc((v >> 24l) & 0xffl, gr_file);
1260         fputc((v >> 16l) & 0xffl, gr_file);
1261         fputc((v >> 8l) & 0xffl, gr_file);
1262         fputc(v & 0xffl, gr_file);
1263     } else {
1264         if (v <= 0x3fffffffffffffl)
1265             putc((v >> 56l) | 0x60l, gr_file);
1266         else {
1267             putc(0x70, gr_file);
1268             putc((v >> 56l) & 0xffl, gr_file);
1269         }
1270
1271         putc((v >> 48l) & 0xffl, gr_file);
1272         putc((v >> 40l) & 0xffl, gr_file);
1273         putc((v >> 32l) & 0xffl, gr_file);
1274         putc((v >> 24l) & 0xffl, gr_file);
1275         putc((v >> 16l) & 0xffl, gr_file);
1276         putc((v >> 8l) & 0xffl, gr_file);
1277         putc(v & 0xffl, gr_file);
1278     }
1279 }
1280
1281 #endif /* GRAN || PAR */
1282 \end{code}
1283
1284 %****************************************************************************
1285 %
1286 \subsection[gr-simulation]{Granularity Simulation}
1287 %
1288 %****************************************************************************
1289
1290 General routines for GranSim. Mainly, startup and shutdown routines, called
1291 from @main.lc@.
1292
1293 \begin{code}
1294 #if defined(GRAN)
1295 FILE *gr_file = NULL;
1296 char gr_filename[STATS_FILENAME_MAXLEN];
1297 /* I_ do_gr_sim = 0; */ /* In GrAnSim setup always do simulation */
1298
1299 int
1300 init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv)
1301 char *prog_argv[], *rts_argv[];
1302 int prog_argc, rts_argc;
1303 {
1304     I_ i;
1305
1306     char *extension = RTSflags.GranFlags.granSimStats_Binary ? "gb" : "gr";
1307
1308     if (RTSflags.GranFlags.granSimStats_suppressed)
1309         return;
1310
1311     sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0], extension);
1312
1313     if ((gr_file = fopen(gr_filename, "w")) == NULL) {
1314         fprintf(stderr, "Can't open granularity simulation report file %s\n", gr_filename);
1315         EXIT(EXIT_FAILURE);
1316     }
1317 #  if 0  /* that's obsolete now, I think -- HWL */
1318         if (RTSflags.GranFlags.DoReScheduleOnFetch)
1319             setbuf(gr_file, NULL);
1320 #  endif
1321
1322         fputs("Granularity Simulation for ", gr_file);
1323         for (i = 0; i < prog_argc; ++i) {
1324             fputs(prog_argv[i], gr_file);
1325             fputc(' ', gr_file);
1326         }
1327
1328         if (rts_argc > 0) {
1329             fputs("+RTS ", gr_file);
1330
1331             for (i = 0; i < rts_argc; ++i) {
1332                 fputs(rts_argv[i], gr_file);
1333                 fputc(' ', gr_file);
1334             }
1335         }
1336
1337         fputs("\nStart time: ", gr_file);
1338         fputs(time_str(), gr_file); /* defined in main.lc */
1339         fputc('\n', gr_file);
1340
1341         fputs("\n\n--------------------\n\n", gr_file);
1342
1343         fputs("General Parameters:\n\n", gr_file);
1344
1345         if (RTSflags.GranFlags.Light)
1346           fprintf(gr_file, "GrAnSim-Light\nPEs infinite, %s Scheduler, %sMigrate Threads %s, %s\n",
1347                 RTSflags.GranFlags.DoFairSchedule?"Fair":"Unfair",
1348                 RTSflags.GranFlags.DoThreadMigration?"":"Don't ",
1349                 RTSflags.GranFlags.DoThreadMigration && RTSflags.GranFlags.DoStealThreadsFirst?" Before Sparks":"",
1350                 RTSflags.GranFlags.SimplifiedFetch ? "Simplified Fetch" :
1351                 RTSflags.GranFlags.DoReScheduleOnFetch ? "Reschedule on Fetch" :
1352                 "Block on Fetch");
1353         else
1354           fprintf(gr_file, "PEs %u, %s Scheduler, %sMigrate Threads %s, %s\n",
1355                 RTSflags.GranFlags.proc,RTSflags.GranFlags.DoFairSchedule?"Fair":"Unfair",
1356                 RTSflags.GranFlags.DoThreadMigration?"":"Don't ",
1357                 RTSflags.GranFlags.DoThreadMigration && RTSflags.GranFlags.DoStealThreadsFirst?" Before Sparks":"",
1358                 RTSflags.GranFlags.SimplifiedFetch ? "Simplified Fetch" :
1359                 RTSflags.GranFlags.DoReScheduleOnFetch ? "Reschedule on Fetch" :
1360                 "Block on Fetch");
1361
1362         if (RTSflags.GranFlags.DoGUMMFetching)
1363           if (RTSflags.GranFlags.ThunksToPack)
1364             fprintf(gr_file, "Bulk Fetching: Fetch %d Thunks in Each Packet (Packet Size = %d closures)\n",
1365                     RTSflags.GranFlags.ThunksToPack,
1366                     RTSflags.GranFlags.packBufferSize);
1367           else
1368             fprintf(gr_file, "Bulk Fetching: Fetch as many closures as possible (Packet Size = %d closures)\n",
1369                     RTSflags.GranFlags.packBufferSize);
1370         else
1371           fprintf(gr_file, "Incremental Fetching: Fetch Exactly One Closure in Each Packet\n");
1372
1373         fprintf(gr_file, "Fetch Strategy(%u):If outstanding fetches %s\n",
1374                 RTSflags.GranFlags.FetchStrategy,
1375                 RTSflags.GranFlags.FetchStrategy==0 ?
1376                   " block (block-on-fetch)":
1377                 RTSflags.GranFlags.FetchStrategy==1 ?
1378                   "only run runnable threads":
1379                 RTSflags.GranFlags.FetchStrategy==2 ?
1380                   "create threads only from local sparks":
1381                 RTSflags.GranFlags.FetchStrategy==3 ?
1382                   "create threads from local or global sparks":
1383                 RTSflags.GranFlags.FetchStrategy==4 ?
1384                   "create sparks and steal threads if necessary":
1385                   "unknown");
1386
1387         if (RTSflags.GranFlags.DoPrioritySparking)
1388           fprintf(gr_file, "Priority Sparking (i.e. keep sparks ordered by priority)\n");
1389
1390         if (RTSflags.GranFlags.DoPriorityScheduling)
1391           fprintf(gr_file, "Priority Scheduling (i.e. keep threads ordered by priority)\n");
1392
1393         fprintf(gr_file, "Thread Creation Time %lu, Thread Queue Time %lu\n",
1394                 RTSflags.GranFlags.gran_threadcreatetime,
1395                 RTSflags.GranFlags.gran_threadqueuetime);
1396         fprintf(gr_file, "Thread DeSchedule Time %lu, Thread Schedule Time %lu\n",
1397                 RTSflags.GranFlags.gran_threaddescheduletime,
1398                 RTSflags.GranFlags.gran_threadscheduletime);
1399         fprintf(gr_file, "Thread Context-Switch Time %lu\n",
1400                 RTSflags.GranFlags.gran_threadcontextswitchtime);
1401         fputs("\n\n--------------------\n\n", gr_file);
1402
1403         fputs("Communication Metrics:\n\n", gr_file);
1404         fprintf(gr_file,
1405           "Latency %lu (1st) %lu (rest), Fetch %lu, Notify %lu (Global) %lu (Local)\n",
1406                 RTSflags.GranFlags.gran_latency,
1407                 RTSflags.GranFlags.gran_additional_latency,
1408                 RTSflags.GranFlags.gran_fetchtime,
1409                 RTSflags.GranFlags.gran_gunblocktime,
1410                 RTSflags.GranFlags.gran_lunblocktime);
1411         fprintf(gr_file,
1412           "Message Creation %lu (+ %lu after send), Message Read %lu\n",
1413                 RTSflags.GranFlags.gran_mpacktime,
1414                 RTSflags.GranFlags.gran_mtidytime,
1415                 RTSflags.GranFlags.gran_munpacktime);
1416         fputs("\n\n--------------------\n\n", gr_file);
1417
1418         fputs("Instruction Metrics:\n\n", gr_file);
1419         fprintf(gr_file, "Arith %lu, Branch %lu, Load %lu, Store %lu, Float %lu, Alloc %lu\n",
1420                 RTSflags.GranFlags.gran_arith_cost,
1421                 RTSflags.GranFlags.gran_branch_cost,
1422                 RTSflags.GranFlags.gran_load_cost,
1423                 RTSflags.GranFlags.gran_store_cost,
1424                 RTSflags.GranFlags.gran_float_cost,
1425                 RTSflags.GranFlags.gran_heapalloc_cost);
1426         fputs("\n\n++++++++++++++++++++\n\n", gr_file);
1427
1428     if (RTSflags.GranFlags.granSimStats_Binary)
1429         grputw(sizeof(TIME));
1430
1431     return (0);
1432 }
1433
1434 void
1435 end_gr_simulation(STG_NO_ARGS)
1436 {
1437    char time_string[500]; /* ToDo: kill magic constant */
1438    ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
1439
1440    if (RTSflags.GranFlags.granSimStats_suppressed)
1441      return;
1442
1443 #if defined(GRAN_CHECK) && defined(GRAN)
1444    /* Print event stats */
1445    if (RTSflags.GranFlags.debug & 0x20) {
1446      int i;
1447
1448      fprintf(stderr,"Event statistics (number of events: %d):\n",
1449              noOfEvents);
1450      for (i=0; i<=MAX_EVENT; i++) {
1451        fprintf(stderr,"  %s (%d): \t%ld \t%f%%\t%f%%\n",
1452                event_names[i],i,event_counts[i],
1453                (float)(100*event_counts[i])/(float)(noOfEvents),
1454                (i==CONTINUETHREAD ? 0.0 :
1455                    (float)(100*(event_counts[i])/(float)(noOfEvents-event_counts[CONTINUETHREAD])) ));
1456      }
1457      fprintf(stderr,"Randomized steals: %u sparks, %u threads \n \t(Sparks: #%u (avg ntimes=%f; avg fl=%f) \n",
1458                      rs_sp_count, rs_t_count, no_of_steals,
1459                      (float)ntimes_total/(float)STG_MAX(no_of_steals,1),
1460                      (float)fl_total/(float)STG_MAX(no_of_steals,1));
1461      fprintf(stderr,"Moved sparks: %d  Withered sparks: %d (%.2f %%)\n",
1462               tot_sparks,withered_sparks,
1463              ( tot_sparks == 0 ? 0 :
1464                   (float)(100*withered_sparks)/(float)(tot_sparks)) );
1465      /* Print statistics about priority sparking */
1466      if (RTSflags.GranFlags.DoPrioritySparking) {
1467         fprintf(stderr,"About Priority Sparking:\n");
1468         fprintf(stderr,"  Total no. NewThreads: %d   Avg. spark queue len: %.2f \n", tot_sq_probes, (float)tot_sq_len/(float)tot_sq_probes);
1469      }
1470      /* Print statistics about priority sparking */
1471      if (RTSflags.GranFlags.DoPriorityScheduling) {
1472         fprintf(stderr,"About Priority Scheduling:\n");
1473         fprintf(stderr,"  Total no. of StartThreads: %d (non-end: %d) Avg. thread queue len: %.2f\n",
1474                 tot_add_threads, non_end_add_threads,
1475                 (float)tot_tq_len/(float)tot_add_threads);
1476      }
1477      /* Print packet statistics if GUMM fetching is turned on */
1478      if (RTSflags.GranFlags.DoGUMMFetching) {
1479         fprintf(stderr,"Packet statistcs:\n");
1480         fprintf(stderr,"  Total no. of packets: %d   Avg. packet size: %.2f \n", tot_packets, (float)tot_packet_size/(float)tot_packets);
1481         fprintf(stderr,"  Total no. of thunks: %d   Avg. thunks/packet: %.2f \n", tot_thunks, (float)tot_thunks/(float)tot_packets);
1482         fprintf(stderr,"  Total no. of cuts: %d   Avg. cuts/packet: %.2f\n", tot_cuts, (float)tot_cuts/(float)tot_packets);
1483         /*
1484         if (closure_queue_overflows>0)
1485           fprintf(stderr,"  Number of closure queue overflows: %u\n",
1486                   closure_queue_overflows);
1487         */
1488      }
1489    }
1490
1491    if (RTSflags.GranFlags.PrintFetchMisses)
1492      fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);
1493
1494 # if defined(GRAN_COUNT)
1495     fprintf(stderr,"Update count statistics:\n");
1496     fprintf(stderr,"  Total number of updates: %u\n",nUPDs);
1497     fprintf(stderr,"  Needed to awaken BQ: %u with avg BQ len of: %f\n",
1498             nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
1499     fprintf(stderr,"  Number of PAPs: %u\n",nPAPs);
1500 # endif
1501
1502 #endif /* GRAN_CHECK */
1503
1504         fprintf(stderr, "Simulation finished after @ %s @ cycles. Look at %s for details.\n",
1505           time_string,gr_filename);
1506         if (RTSflags.GranFlags.granSimStats)
1507             fclose(gr_file);
1508 }
1509 #elif defined(PAR)
1510 FILE *gr_file = NULL;
1511 char gr_filename[STATS_FILENAME_MAXLEN];
1512
1513 /* I_ do_sp_profile = 0; */
1514
1515 void
1516 init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv)
1517   char *prog_argv[], *rts_argv[];
1518   int prog_argc, rts_argc;
1519 {
1520     int i;
1521
1522     char *extension = RTSflags.ParFlags.granSimStats_Binary ? "gb" : "gr";
1523
1524     sprintf(gr_filename, GR_FILENAME_FMT_GUM, prog_argv[0], thisPE, extension);
1525
1526     if ((gr_file = fopen(gr_filename, "w")) == NULL) {
1527         fprintf(stderr, "Can't open activity report file %s\n", gr_filename);
1528         EXIT(EXIT_FAILURE);
1529     }
1530
1531     for (i = 0; i < prog_argc; ++i) {
1532         fputs(prog_argv[i], gr_file);
1533         fputc(' ', gr_file);
1534     }
1535
1536     if (rts_argc > 0) {
1537         fputs("+RTS ", gr_file);
1538
1539         for (i = 0; i < rts_argc; ++i) {
1540             fputs(rts_argv[i], gr_file);
1541             fputc(' ', gr_file);
1542         }
1543     }
1544     fputc('\n', gr_file);
1545
1546     fputs("Start-Time: ", gr_file);
1547     fputs(time_str(), gr_file); /* defined in main.lc */
1548     fputc('\n', gr_file);
1549
1550     startTime = CURRENT_TIME;
1551
1552     if (startTime > LL(1000000000)) {
1553         /* This shouldn't overflow twice */
1554         fprintf(gr_file, "PE %2u [%lu%lu]: TIME\n", thisPE,
1555             (TIME) (startTime / LL(1000000000)),
1556             (TIME) (startTime % LL(1000000000)));
1557     } else {
1558         fprintf(gr_file, "PE %2u [%lu]: TIME\n", thisPE, (TIME) startTime);
1559     }
1560
1561     if (RTSflags.ParFlags.granSimStats_Binary)
1562         grputw(sizeof(TIME));
1563 }
1564 #endif /* PAR */
1565
1566 #endif   /* GRAN || PAR */
1567 \end{code}
1568
1569