ghc/runtime/storage/SMmark.lhc

   1 %****************************************************************************
   2 %
   3 \section[SMmark.lhc]{Pointer-Reversing Mark code}
   4 %
   5 % (c) P. Sansom, K. Hammond, OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE
   6 %     Project, Glasgow University, January 26th 1993.
   7 %
   8 %****************************************************************************
   9
  10 This module contains the specialised and generic code to perform
  11 pointer reversal marking.  These routines are placed in the info
  12 tables of the appropriate closures.
  13
  14 Some of the dirt is hidden in macros defined in SMmarkDefs.lh.
  15
  16 %****************************************************************************
  17 %
  18 \subsection[mark-overview]{Overview of Marking}
  19 %
  20 %****************************************************************************
  21
  22 This module uses a pointer-reversal algorithm to mark a closure.
  23 To mark a closure, first set a bit indicating that the closure
  24 has been marked, then mark each pointer in the closure.  The mark
  25 bit is used to determine whether a node has already been
  26 marked before we mark it.  Because we set the bit before marking
  27 the children of a node, this avoids cycles.
  28
  29 Given a closure containing a number of pointers, $n$, $n > 0$ the mark
  30 code for that closure can be divided into three parts:
  31 \begin{enumerate}
  32 \item
  33 The mark (or ``start'') code for the closure.  Called when an attempt is made
  34 to mark the closure, it initialises the mark position in the
  35 closure, then jumps to the mark code for the first pointer.
  36 \item
  37 The return (or ``in'') code for the closure.  Called when a closure is
  38 returned to after a child is marked, it increments the mark position
  39 and jumps to the mark entry for the next pointer
  40 \item
  41 The last (or ``in-last'') code for the closure.  Called when all children
  42 have been marked, it just returns to its parent through the appropriate
  43 return code.
  44 \end{enumerate}
  45
  46 For non-\tr{SPEC} closures, the return and last codes are merged in most
  47 cases, so the return code checks explicitly whether all pointers have
  48 been marked, and returns if so.
  49
  50 %****************************************************************************
  51 %
  52 \subsubsection[mark-registers]{Registers used when marking}
  53 %
  54 %****************************************************************************
  55
  56 Two registers are used:
  57 \begin{description}
  58 \item[Mark]
  59 Points to the closure being marked.
  60 \item[MStack]
  61 Points to the closure on the top of the marking stack.
  62 The first closure on the stack contains the continuation to
  63 enter when marking is complete.
  64 \end{description}
  65
  66 The following registers are used by Pointer Reversal Marking:
  67
  68 \begin{description}
  69 \item[@MStack@]
  70 The top of the mark stack.
  71 \item[@Mark@]
  72 The node being processed.
  73 \item[@BitArray@]
  74 The bit array (what's that? KH) to mark.
  75 \item[@HeapBase@]
  76 The base of the heap (to calculate bit to mark).
  77 \item[@HeapLim@]
  78 The limit of the heap.  For generational garbage collection,
  79 only closures whose address is $<$ @HeapLim@ will be marked
  80 \end{description}
  81
  82 To answer KH's question, the @BitArray@ is used to store marks.  This
  83 avoids the need to include space for a mark bit in the closure itself.
  84 The array consists of one bit per word of heap memory that is handled
  85 by the compacting collector or the old generation in the generational
  86 collector. [ADR]
  87
  88 %****************************************************************************
  89 %
  90 \subsubsection[mark-conventions]{Calling and Return Conventions}
  91 %
  92 %****************************************************************************
  93
  94 When a child closure is returned from, the registers have the following
  95 values.
  96
  97 \begin{description}
  98 \item[@Mark@]
  99 points to the closure just marked (this may be updated with a new
 100 address to short-circuit indirections).
 101 \item[MStack]
 102 points to the closure whose return code has been entered
 103 (this closure is now at the top of the pointer-reversal marking stack).
 104 \end{description}
 105
 106 The macros @JUMP_MARK@ and @JUMP_MARK_RETURN@ jump to the start code
 107 pointed to by the @Mark@ register, or the return code pointed to by
 108 the @MStack@ register respectively.
 109
 110
 111 %%%%  GOT THIS FAR -- KH %%%%
 112
 113 Marking A Closure:
 114   @_PRStart_N@
 115
 116   Retrieved using PRMARK_CODE(infoptr)
 117
 118 Uses pointer reversal marking to mark a closure which contains N ptrs.
 119 If the closure has 0 pointers it sets it to a marked state and returns
 120 to the closure on top of the PR mark stack (_PRStart_0).
 121
 122 If Not (@_PRStart_N@  ($N > 0$))
 123    sets to a state of marking the first pointer
 124    pushes this closure on the PR marking stack (in the first ptr location)
 125    marks the first child -- enters its marking code
 126
 127 A closure that is already marked just indicates this by returning to the
 128 closure on the top of the PR mark stack.
 129
 130   Calling Conventions:
 131     Mark   -- points to the closure to mark
 132     MStack -- points to the closure on the top of the PR marking stack
 133               If the stack is empty it points to a closure which contains
 134               the continuation to enter when marking is complete.
 135
 136   User Invokation:
 137     Have root to mark
 138     MStack set to a closure containing the continuation to be called when
 139       the root has been marked.
 140     Mark pointing to the closure
 141
 142   Entering MStack Continuation:
 143     Mark points to new value of the closure (indirection short circut)
 144     *** Update root being marked with this value.
 145
 146
 147 Returning To A Closure Being Marked:
 148   _PRIn_I
 149   _PRInLast_N
 150
 151   Retrieved using PRRETURN_CODE(infoptr)
 152
 153 Starts marking the next pointer (_PRIn_I).
 154   updates the current poointer being marked with new Mark
 155   sets state to next pointer
 156   marks the next child
 157 If not, (_PRInLast_N), it returns to the closure on the top of the PR
 158 marking stack.
 159
 160   Calling Conventions:
 161     Mark   -- points to the closure just marked (may be updated with new
 162               address to short indirections)
 163     MStack -- points to it -- the closure on the top of the PR marking stack
 164
 165
 166
 167 The following registers are used by Pointer Reversal Marking:
 168
 169 MStack   -- The MarkStack register
 170 Mark     -- Points to the Node being processed
 171 BitArray -- The bit array to mark
 172 HeapBase -- The base of the heap (to calculate bit to mark)
 173 HeapLim  -- The limit of the heap
 174          -- For gen gc: only closures < HeapLim will be marked
 175          --             OldRoots pointing  < HeapLim
 176
 177 \input{SMmarkDefs.lh}
 178
 179 %****************************************************************************
 180 %
 181 \subsection[mark-code]{The actual Marking Code}
 182 %
 183 %****************************************************************************
 184
 185 This code is only used if @_INFO_MARKING@ is defined.
 186
 187 \begin{code}
 188 #if defined(_INFO_MARKING)
 189 \end{code}
 190
 191 First the necessary forward declarations.
 192
 193 \begin{code}
 194 /* #define MARK_REG_MAP -- Must be done on command line for threaded code */
 195 #include "SMinternal.h"
 196 #include "SMmarkDefs.h"
 197
 198 #if defined(GRAN)
 199 extern P_ ret_MRoot, ret_Mark;
 200 #endif
 201 \end{code}
 202
 203 Define appropriate variables as potential register variables.
 204 Assume GC code saves and restores any global registers used.
 205
 206 \begin{code}
 207 RegisterTable MarkRegTable;
 208 \end{code}
 209
 210 @_startMarkWorld@ restores registers if necessary, then marks the
 211 root pointed to by @Mark@.
 212
 213 \begin{code}
 214 STGFUN(_startMarkWorld)
 215 {
 216     FUNBEGIN;
 217 #if defined(__STG_GCC_REGS__) && defined(__GNUC__)
 218     /* If using registers load from _SAVE (see SMmarking.lc) */
 219
 220     /* I deeply suspect this should be RESTORE_REGS(...) [WDP 95/02] */
 221 #ifdef REG_MarkBase
 222     MarkBaseReg = &MarkRegTable;
 223 #endif
 224     Mark = SAVE_Mark;
 225     MRoot = SAVE_MRoot;
 226     MStack = SAVE_MStack;
 227     BitArray = SAVE_BitArray;
 228     HeapBase = SAVE_HeapBase;
 229     HeapLim  = SAVE_HeapLim;
 230 #endif
 231
 232     JUMP_MARK;
 233     FUNEND;
 234 }
 235 \end{code}
 236
 237 This is the pointer reversal start code for \tr{SPEC} closures with 0
 238 pointers.
 239
 240 \begin{code}
 241 STGFUN(_PRStart_0)
 242 {
 243     FUNBEGIN;
 244     if (IS_MARK_BIT_SET(Mark)) {
 245         DEBUG_PR_MARKED;
 246     } else
 247     INIT_MARK_NODE("SPEC",0);
 248
 249     JUMP_MARK_RETURN;
 250     FUNEND;
 251 }
 252 \end{code}
 253
 254
 255 This macro defines the format of the pointer reversal start code for a
 256 number of pointers \tr{ptrs}, $>$ 0.
 257
 258 \begin{code}
 259
 260 #define SPEC_PRStart_N_CODE(ptrs)               \
 261 STGFUN(CAT2(_PRStart_,ptrs))                    \
 262 {                                               \
 263     FUNBEGIN;                                   \
 264     if (IS_MARK_BIT_SET(Mark)) {                \
 265         DEBUG_PR_MARKED;                        \
 266         JUMP_MARK_RETURN;                       \
 267     } else {                                    \
 268         INIT_MARK_NODE("SPEC",ptrs);            \
 269         INIT_MSTACK(SPEC_CLOSURE_PTR);          \
 270     }                                           \
 271     FUNEND;                                     \
 272 }
 273
 274 \end{code}
 275
 276 The definitions of the start code for \tr{SPEC} closures with 1-12
 277 pointers.
 278
 279 \begin{code}
 280 SPEC_PRStart_N_CODE(1)
 281 SPEC_PRStart_N_CODE(2)
 282 SPEC_PRStart_N_CODE(3)
 283 SPEC_PRStart_N_CODE(4)
 284 SPEC_PRStart_N_CODE(5)
 285 SPEC_PRStart_N_CODE(6)
 286 SPEC_PRStart_N_CODE(7)
 287 SPEC_PRStart_N_CODE(8)
 288 SPEC_PRStart_N_CODE(9)
 289 SPEC_PRStart_N_CODE(10)
 290 SPEC_PRStart_N_CODE(11)
 291 SPEC_PRStart_N_CODE(12)
 292
 293 \end{code}
 294
 295 Start code for revertible black holes with underlying @SPEC@ types.
 296
 297 \begin{code}
 298
 299 #if defined(PAR) || defined(GRAN)
 300 #define SPEC_RBH_PRStart_N_CODE(ptrs)           \
 301 STGFUN(CAT2(_PRStart_RBH_,ptrs))                \
 302 {                                               \
 303     FUNBEGIN;                                   \
 304     if (IS_MARK_BIT_SET(Mark)) {                \
 305         DEBUG_PR_MARKED;                        \
 306         JUMP_MARK_RETURN;                       \
 307     } else {                                    \
 308         INIT_MARK_NODE("SRBH",ptrs-1);          \
 309     INIT_MSTACK(SPEC_RBH_CLOSURE_PTR);          \
 310     }                                           \
 311     FUNEND;                                     \
 312 }
 313
 314 SPEC_RBH_PRStart_N_CODE(2)
 315 SPEC_RBH_PRStart_N_CODE(3)
 316 SPEC_RBH_PRStart_N_CODE(4)
 317 SPEC_RBH_PRStart_N_CODE(5)
 318 SPEC_RBH_PRStart_N_CODE(6)
 319 SPEC_RBH_PRStart_N_CODE(7)
 320 SPEC_RBH_PRStart_N_CODE(8)
 321 SPEC_RBH_PRStart_N_CODE(9)
 322 SPEC_RBH_PRStart_N_CODE(10)
 323 SPEC_RBH_PRStart_N_CODE(11)
 324 SPEC_RBH_PRStart_N_CODE(12)
 325
 326 #endif
 327
 328 \end{code}
 329
 330 @SPEC_PRIn_N_CODE@ has two different meanings, depending on the world
 331 in which we use it:
 332 \begin{itemize}
 333 \item
 334 In the commoned-info-table world, it
 335 defines the ``in'' code for a particular number
 336 of pointers, and subsumes the functionality of @SPEC_PRInLast_N_NODE@ below.
 337 \item
 338 Otherwise, it defines the ``in'' code for a particular pointer in a
 339 \tr{SPEC} closure.
 340 \end{itemize}
 341
 342 \begin{code}
 343
 344 #define SPEC_PRIn_N_CODE(ptrs)                          \
 345 STGFUN(CAT2(_PRIn_,ptrs))                               \
 346 {                                               \
 347     BitWord mbw;                                        \
 348     FUNBEGIN;                                   \
 349     GET_MARKED_PTRS(mbw,MStack,ptrs);                   \
 350     if (++mbw < ptrs) {                                 \
 351         SET_MARKED_PTRS(MStack,ptrs,mbw);               \
 352         CONTINUE_MARKING_NODE("SPEC",mbw);              \
 353         MOVE_TO_NEXT_PTR(SPEC_CLOSURE_PTR,mbw);         \
 354     } else {                                            \
 355         SET_MARKED_PTRS(MStack,ptrs,0L);                \
 356         POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,ptrs);       \
 357     }                                                   \
 358     FUNEND;                                     \
 359 }
 360
 361 \end{code}
 362
 363 Now @SPEC_PRIn_N_CODE@ is used to define the individual entries for \tr{SPEC} closures
 364 with 1-12 pointers.
 365
 366 \begin{code}
 367 STGFUN(_PRIn_0)
 368 {
 369     FUNBEGIN;
 370     fprintf(stderr,"Called _PRIn_0\nShould never occur!\n");
 371     abort();
 372     FUNEND;
 373 }
 374 STGFUN(_PRIn_1)
 375 {
 376     FUNBEGIN;
 377     POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,1);
 378     FUNEND;
 379 }
 380 SPEC_PRIn_N_CODE(2)
 381 SPEC_PRIn_N_CODE(3)
 382 SPEC_PRIn_N_CODE(4)
 383 SPEC_PRIn_N_CODE(5)
 384 SPEC_PRIn_N_CODE(6)
 385 SPEC_PRIn_N_CODE(7)
 386 SPEC_PRIn_N_CODE(8)
 387 SPEC_PRIn_N_CODE(9)
 388 SPEC_PRIn_N_CODE(10)
 389 SPEC_PRIn_N_CODE(11)
 390 SPEC_PRIn_N_CODE(12)
 391 \end{code}
 392
 393 In code for revertible black holes with underlying @SPEC@ types.
 394
 395 \begin{code}
 396 #if defined(PAR) || defined(GRAN)
 397 #define SPEC_RBH_PRIn_N_CODE(ptrs)                      \
 398 STGFUN(CAT2(_PRIn_RBH_,ptrs))                           \
 399 {                                                       \
 400     BitWord mbw;                                        \
 401     FUNBEGIN;                                           \
 402     GET_MARKED_PTRS(mbw,MStack,ptrs-1);                 \
 403     if (++mbw < ptrs-1) {                               \
 404         SET_MARKED_PTRS(MStack,ptrs-1,mbw);             \
 405         CONTINUE_MARKING_NODE("SRBH",mbw);              \
 406         MOVE_TO_NEXT_PTR(SPEC_RBH_CLOSURE_PTR,mbw);     \
 407     } else {                                            \
 408         SET_MARKED_PTRS(MStack,ptrs-1,0L);              \
 409         POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,ptrs-1); \
 410     }                                                   \
 411     FUNEND;                                             \
 412 }
 413
 414 STGFUN(_PRIn_RBH_2)
 415 {
 416     FUNBEGIN;
 417     POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,1);
 418     FUNEND;
 419 }
 420
 421 SPEC_RBH_PRIn_N_CODE(3)
 422 SPEC_RBH_PRIn_N_CODE(4)
 423 SPEC_RBH_PRIn_N_CODE(5)
 424 SPEC_RBH_PRIn_N_CODE(6)
 425 SPEC_RBH_PRIn_N_CODE(7)
 426 SPEC_RBH_PRIn_N_CODE(8)
 427 SPEC_RBH_PRIn_N_CODE(9)
 428 SPEC_RBH_PRIn_N_CODE(10)
 429 SPEC_RBH_PRIn_N_CODE(11)
 430 SPEC_RBH_PRIn_N_CODE(12)
 431 #endif
 432
 433 \end{code}
 434
 435 Foreign Objs are in the non-parallel world only.
 436
 437 \begin{code}
 438
 439 #ifndef PAR
 440
 441 STGFUN(_PRStart_ForeignObj)
 442 {
 443     FUNBEGIN;
 444     if (IS_MARK_BIT_SET(Mark)) {
 445         DEBUG_PR_MARKED;
 446     } else
 447     INIT_MARK_NODE("ForeignObj ",0);
 448     JUMP_MARK_RETURN;
 449     FUNEND;
 450 }
 451 #endif /* !PAR */
 452 \end{code}
 453
 454 This defines the start code for generic (\tr{GEN}) closures.
 455
 456 \begin{code}
 457 STGFUN(_PRStart_N)
 458 {
 459     W_ ptrs;
 460
 461     FUNBEGIN;
 462
 463     if (IS_MARK_BIT_SET(Mark)) {
 464         DEBUG_PR_MARKED;
 465         JUMP_MARK_RETURN;
 466     }
 467     ptrs = GEN_CLOSURE_NoPTRS(Mark);
 468     INIT_MARK_NODE("GEN ",ptrs);
 469     if (ptrs == 0) {
 470         JUMP_MARK_RETURN;
 471     } else {
 472         INIT_MSTACK(GEN_CLOSURE_PTR);
 473     }
 474     FUNEND;
 475 }
 476 \end{code}
 477
 478 Now the ``in'' code for \tr{GEN} closures.
 479
 480 \begin{code}
 481 STGFUN(_PRIn_I)
 482 {
 483     W_ ptrs;
 484     BitWord pos;
 485
 486     FUNBEGIN;
 487
 488     ptrs = GEN_CLOSURE_NoPTRS(MStack);
 489     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 490
 491     if (++pos < ptrs) {
 492         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 493         CONTINUE_MARKING_NODE("GEN",pos);
 494         MOVE_TO_NEXT_PTR(GEN_CLOSURE_PTR,pos);
 495     } else {
 496         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 497         POP_MSTACK("GEN ",GEN_CLOSURE_PTR,ptrs);
 498     }
 499     FUNEND;
 500 }
 501 \end{code}
 502
 503 And the start/in code for a revertible black hole with an underlying @GEN@ closure.
 504
 505 \begin{code}
 506
 507 #if defined(PAR) || defined(GRAN)
 508
 509 STGFUN(_PRStart_RBH_N)
 510 {
 511     W_ ptrs;
 512
 513     FUNBEGIN;
 514
 515     if (IS_MARK_BIT_SET(Mark)) {
 516         DEBUG_PR_MARKED;
 517         JUMP_MARK_RETURN;
 518     }
 519
 520     /*
 521      * Get pointer count from original closure and adjust for one pointer
 522      * in the first two words of the RBH.
 523      */
 524     ptrs = GEN_RBH_CLOSURE_NoPTRS(Mark);
 525     if (ptrs < 2)
 526         ptrs = 1;
 527     else
 528         ptrs--;
 529
 530     INIT_MARK_NODE("GRBH", ptrs);
 531     INIT_MSTACK(GEN_RBH_CLOSURE_PTR);
 532     FUNEND;
 533 }
 534
 535 STGFUN(_PRIn_RBH_I)
 536 {
 537     W_ ptrs;
 538     BitWord pos;
 539
 540     FUNBEGIN;
 541
 542     /*
 543      * Get pointer count from original closure and adjust for one pointer
 544      * in the first two words of the RBH.
 545      */
 546     ptrs = GEN_RBH_CLOSURE_NoPTRS(MStack);
 547     if (ptrs < 2)
 548         ptrs = 1;
 549     else
 550         ptrs--;
 551
 552     GET_GEN_MARKED_PTRS(pos, MStack, ptrs);
 553
 554     if (++pos < ptrs) {
 555         SET_GEN_MARKED_PTRS(MStack, ptrs, pos);
 556         CONTINUE_MARKING_NODE("GRBH", pos);
 557         MOVE_TO_NEXT_PTR(GEN_RBH_CLOSURE_PTR, pos);
 558     } else {
 559         SET_GEN_MARKED_PTRS(MStack, ptrs, 0L);
 560         POP_MSTACK("GRBH", GEN_RBH_CLOSURE_PTR, ptrs);
 561     }
 562     FUNEND;
 563 }
 564
 565 #endif
 566
 567 \end{code}
 568
 569 Start code for dynamic (\tr{DYN}) closures.  There is no \tr{DYN}
 570 closure with 0 pointers -- \tr{DATA} is used instead.
 571
 572 \begin{code}
 573 STGFUN(_PRStart_Dyn)
 574 {
 575     FUNBEGIN;
 576     if (IS_MARK_BIT_SET(Mark)) {
 577         DEBUG_PR_MARKED;
 578         JUMP_MARK_RETURN;
 579     } else {
 580     INIT_MARK_NODE("DYN ", DYN_CLOSURE_NoPTRS(Mark));
 581         INIT_MSTACK(DYN_CLOSURE_PTR);
 582     }
 583     FUNEND;
 584 }
 585 \end{code}
 586
 587 and the corresponding ``in'' code.
 588
 589 \begin{code}
 590 STGFUN(_PRIn_I_Dyn)
 591 {
 592     W_ ptrs;
 593     BitWord pos;
 594
 595     FUNBEGIN;
 596     ptrs = DYN_CLOSURE_NoPTRS(MStack);
 597     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 598
 599     if (++pos < ptrs) {
 600         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 601         CONTINUE_MARKING_NODE("DYN",pos);
 602         MOVE_TO_NEXT_PTR(DYN_CLOSURE_PTR,pos);
 603     } else {
 604         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 605         POP_MSTACK("DYN ",DYN_CLOSURE_PTR,ptrs);
 606       }
 607     FUNEND;
 608 }
 609 \end{code}
 610
 611
 612 The start code for \tr{TUPLE} (all-pointer) objects.  There can be no
 613 such object without any pointers, so we don't check for this case.
 614
 615 \begin{code}
 616 STGFUN(_PRStart_Tuple)
 617 {
 618     FUNBEGIN;
 619     if (IS_MARK_BIT_SET(Mark)) {
 620         DEBUG_PR_MARKED;
 621         JUMP_MARK_RETURN;
 622     } else {
 623     INIT_MARK_NODE("TUPL", TUPLE_CLOSURE_NoPTRS(Mark));
 624         INIT_MSTACK(TUPLE_CLOSURE_PTR);
 625     }
 626     FUNEND;
 627 }
 628 \end{code}
 629
 630 Now the ``in'' case.
 631
 632 \begin{code}
 633 STGFUN(_PRIn_I_Tuple)
 634 {
 635     W_ ptrs;
 636     BitWord pos;
 637
 638     FUNBEGIN;
 639     ptrs = TUPLE_CLOSURE_NoPTRS(MStack);
 640     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 641
 642     if (++pos < ptrs) {
 643         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 644         CONTINUE_MARKING_NODE("TUPL",pos);
 645         MOVE_TO_NEXT_PTR(TUPLE_CLOSURE_PTR,pos);
 646     } else {
 647         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 648         POP_MSTACK("TUPL",TUPLE_CLOSURE_PTR,ptrs);
 649       }
 650     FUNEND;
 651 }
 652 \end{code}
 653
 654
 655 \begin{code}
 656 /*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
 657 /*             Only if special GC treatment required           */
 658
 659 #ifdef GC_MUT_REQUIRED
 660
 661 STGFUN(_PRStart_MuTuple)
 662 {
 663     FUNBEGIN;
 664     if (IS_MARK_BIT_SET(Mark)) {
 665         DEBUG_PR_MARKED;
 666         JUMP_MARK_RETURN;
 667     } else {
 668         INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark));
 669         if (MUTUPLE_CLOSURE_NoPTRS(Mark) > 0) {
 670             INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
 671         } else {
 672             JUMP_MARK;
 673         }
 674     }
 675     FUNEND;
 676 }
 677
 678 STGFUN(_PRIn_I_MuTuple)
 679 {
 680     W_ ptrs;
 681     BitWord pos;
 682
 683     FUNBEGIN;
 684     ptrs = MUTUPLE_CLOSURE_NoPTRS(MStack);
 685     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 686
 687     if (++pos < ptrs) {
 688         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 689         CONTINUE_MARKING_NODE("MUT",pos);
 690         MOVE_TO_NEXT_PTR(MUTUPLE_CLOSURE_PTR,pos);
 691     } else {
 692         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 693         POP_MSTACK("MUT ",MUTUPLE_CLOSURE_PTR,ptrs);
 694       }
 695     FUNEND;
 696 }
 697
 698 #endif /* GCap || GCgn */
 699 \end{code}
 700
 701 There are no pointers in a \tr{DATA} closure, so just mark the
 702 closure and return.
 703
 704 \begin{code}
 705 STGFUN(_PRStart_Data)
 706 {
 707     FUNBEGIN;
 708     if (IS_MARK_BIT_SET(Mark)) {
 709         DEBUG_PR_MARKED;
 710     } else
 711     INIT_MARK_NODE("DATA", 0);
 712     JUMP_MARK_RETURN;
 713     FUNEND;
 714 }
 715 \end{code}
 716
 717 %****************************************************************************
 718 %
 719 \subsubsection[mark-specials]{Special cases}
 720 %
 721 %****************************************************************************
 722
 723 Black hole closures simply mark themselves and return.
 724
 725 \begin{code}
 726 STGFUN(_PRStart_BH)
 727 {
 728     FUNBEGIN;
 729     if (IS_MARK_BIT_SET(Mark)) {
 730         DEBUG_PR_MARKED;
 731     } else
 732     INIT_MARK_NODE("BH  ", 0);
 733     JUMP_MARK_RETURN;
 734     FUNEND;
 735 }
 736 \end{code}
 737
 738 Marking a Static Closure -- Just return as if Marked
 739
 740 \begin{code}
 741 STGFUN(_PRStart_Static)
 742 {
 743     FUNBEGIN;
 744     DEBUG_PR_STAT;
 745     JUMP_MARK_RETURN;
 746     FUNEND;
 747 }
 748 \end{code}
 749
 750 Marking an Indirection -- Set Mark to ind addr and mark this.
 751 Updating of reference when we return will short indirection.
 752
 753 \begin{code}
 754 STGFUN(_PRStart_Ind)
 755 {
 756     FUNBEGIN;
 757     DEBUG_PR_IND;
 758     GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
 759
 760     Mark = (P_) IND_CLOSURE_PTR(Mark);
 761     JUMP_MARK;
 762     FUNEND;
 763 }
 764 \end{code}
 765
 766 ``Permanent indirection''---used in profiling.  Works basically
 767 like @_PRStart_1@ (one pointer).
 768 \begin{code}
 769 #if defined(PROFILING) || defined(TICKY_TICKY)
 770
 771 STGFUN(_PRStart_PI)
 772 {
 773     FUNBEGIN;
 774
 775     if (IS_MARK_BIT_SET(Mark)) {
 776         DEBUG_PR_MARKED;
 777         JUMP_MARK_RETURN;
 778     } else {
 779         INIT_MARK_NODE("PI  ",1);
 780         /* the "1" above is dodgy (i.e. wrong), but it is never
 781            used except in debugging info.  ToDo??? WDP 95/07
 782         */
 783         INIT_MSTACK(PERM_IND_CLOSURE_PTR);
 784     }
 785     FUNEND;
 786 }
 787
 788 STGFUN(_PRIn_PI)
 789 {
 790     FUNBEGIN;
 791     POP_MSTACK("PI  ",PERM_IND_CLOSURE_PTR,1);
 792     /* the "1" above is dodgy (i.e. wrong), but it is never
 793        used except in debugging info.  ToDo??? WDP 95/07
 794     */
 795     FUNEND;
 796 }
 797
 798 #endif /* PROFILING or TICKY */
 799 \end{code}
 800
 801 Marking a ``selector closure'': This is a size-2 SPEC thunk that
 802 selects word $n$; if the thunk's pointee is evaluated, then we short
 803 out the selection, {\em just like an indirection}.  If it is still
 804 unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}.
 805
 806 {\em Should we select ``on the way down'' (in \tr{_PRStart_Selector})
 807 or ``on the way back up'' (\tr{_PRIn_Selector})?}  Answer: probably on
 808 the way down.  Downside: we are flummoxed by indirections, so we'll
 809 have to wait until the {\em next} major GC to do the selections (after
 810 the indirections are shorted out in this GC).  But the downside of
 811 doing selections on the way back up is that we are then in a world of
 812 reversed pointers, and selecting a reversed pointer---we've see this
 813 on selectors for very recursive structures---is a total disaster.
 814 (WDP 94/12)
 815
 816 \begin{code}
 817 #if defined(DEBUG)
 818 #define IF_GC_DEBUG(x) x
 819 #else
 820 #define IF_GC_DEBUG(x) /*nothing*/
 821 #endif
 822
 823 #if !defined(CONCURRENT)
 824 # define NOT_BLACKHOLING (! RTSflags.GcFlags.lazyBlackHoling)
 825 #else
 826 # define NOT_BLACKHOLING 0
 827 #endif
 828
 829 /* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
 830
 831 #define MARK_SELECTOR(n)                                                \
 832 STGFUN(CAT2(_PRStartSelector_,n))                                       \
 833 {                                                                       \
 834     P_ maybe_con;                                                       \
 835     FUNBEGIN;                                                           \
 836                                                                         \
 837     /* must be a SPEC 2 1 closure */                                    \
 838     ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);                             \
 839     ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);                           \
 840     ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */            \
 841                                                                         \
 842     if (IS_MARK_BIT_SET(Mark)) { /* already marked */                   \
 843         DEBUG_PR_MARKED;                                                \
 844         JUMP_MARK_RETURN;                                               \
 845     }                                                                   \
 846                                                                         \
 847     maybe_con = (P_) *(Mark + _FHS);                                    \
 848                                                                         \
 849     IF_GC_DEBUG(                                                        \
 850     if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING)  {                                                \
 851         fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, info 0x%lx", \
 852                 (n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)),   \
 853                 INFO_NoPTRS(INFO_PTR(Mark)),                            \
 854                 maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/       \
 855                 INFO_PTR(maybe_con));                                   \
 856         fprintf(stderr, ", tag %ld, size %ld, ptrs %ld",                \
 857             INFO_TAG(INFO_PTR(maybe_con)),                              \
 858             INFO_SIZE(INFO_PTR(maybe_con)),                             \
 859             INFO_NoPTRS(INFO_PTR(maybe_con)));                          \
 860         if (INFO_TAG(INFO_PTR(maybe_con)) >=0) {                        \
 861             fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]);         \
 862         }                                                               \
 863         fprintf(stderr, "\n");                                          \
 864     } )                                                                 \
 865                                                                         \
 866     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
 867      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */    \
 868      || INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */             \
 869      || NOT_BLACKHOLING  /* see "price of laziness" paper */            \
 870      || (! RTSflags.GcFlags.doSelectorsAtGC ))                          \
 871         /* see below for OLD test we used here (WDP 95/04) */           \
 872         /* ToDo: decide WHNFness another way? */                        \
 873         JMP_(_PRStart_1);                                               \
 874                                                                         \
 875     /* some things should be true about the pointee */                  \
 876     ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0);                         \
 877     /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
 878                                                                         \
 879     /* OK, it is evaluated: behave just like an indirection */          \
 880     GC_SEL_MAJOR(); /* ticky-ticky */                                   \
 881                                                                         \
 882     Mark = (P_) (maybe_con[_FHS + (n)]);                                \
 883     /* Mark now has the result of the selection */                      \
 884     JUMP_MARK;                                                          \
 885                                                                         \
 886     FUNEND;                                                             \
 887 }
 888
 889 #if 0
 890 /* OLD test:
 891    the IS_STATIC test was to protect the IS_MARK_BIT_SET check;
 892    but the IS_MARK_BIT_SET test was only there to avoid
 893    mangled pointers, but we cannot have mangled pointers anymore
 894    (after RTBLs came our way).
 895    SUMMARY: we toss both of the "guard" tests.
 896  */
 897     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */
 898      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */
 899      || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
 900 #endif /* 0 */
 901
 902 MARK_SELECTOR(0)
 903 MARK_SELECTOR(1)
 904 MARK_SELECTOR(2)
 905 MARK_SELECTOR(3)
 906 MARK_SELECTOR(4)
 907 MARK_SELECTOR(5)
 908 MARK_SELECTOR(6)
 909 MARK_SELECTOR(7)
 910 MARK_SELECTOR(8)
 911 MARK_SELECTOR(9)
 912 MARK_SELECTOR(10)
 913 MARK_SELECTOR(11)
 914 MARK_SELECTOR(12)
 915
 916 #undef IF_GC_DEBUG /* get rid of it */
 917 \end{code}
 918
 919 Marking a Constant Closure -- Set Mark to corresponding static
 920 closure.  Updating of reference will redirect reference to the static
 921 closure.
 922
 923 \begin{code}
 924 STGFUN(_PRStart_Const)
 925 {
 926     FUNBEGIN;
 927     DEBUG_PR_CONST;
 928
 929 #ifndef TICKY_TICKY
 930     /* normal stuff */
 931     Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 932
 933 #else /* TICKY */
 934     if (IS_MARK_BIT_SET(Mark)) {
 935         DEBUG_PR_MARKED;
 936     } else {
 937         if (!AllFlags.doUpdEntryCounts) {
 938
 939             GC_COMMON_CONST(); /* ticky */
 940
 941             Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 942
 943         } else { /* no commoning */
 944             INIT_MARK_NODE("CONST ",0);
 945         }
 946     }
 947 #endif /* TICKY */
 948
 949     JUMP_MARK_RETURN;
 950     FUNEND;
 951 }
 952 \end{code}
 953
 954 Marking a CharLike Closure -- Set Mark to corresponding static
 955 closure.  Updating of reference will redirect reference to the static
 956 closure.
 957
 958 \begin{code}
 959 STGFUN(_PRStart_CharLike)
 960 {
 961 #ifdef TICKY_TICKY
 962     I_ val;
 963 #endif
 964
 965     FUNBEGIN;
 966
 967     DEBUG_PR_CHARLIKE;
 968
 969 #ifndef TICKY_TICKY
 970     /* normal stuff */
 971
 972     Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
 973
 974 #else /* TICKY */
 975
 976     if (IS_MARK_BIT_SET(Mark)) {
 977         DEBUG_PR_MARKED;
 978     } else {
 979         val = CHARLIKE_VALUE(Mark);
 980
 981         if (!AllFlags.doUpdEntryCounts) {
 982             GC_COMMON_CHARLIKE(); /* ticky */
 983
 984             INFO_PTR(Mark) = (W_) Ind_info;
 985             IND_CLOSURE_PTR(Mark) = (W_) CHARLIKE_CLOSURE(val);
 986             Mark = (P_) IND_CLOSURE_PTR(Mark);
 987
 988         } else { /* no commoning */
 989             INIT_MARK_NODE("CHAR ",0);
 990         }
 991     }
 992 #endif /* TICKY */
 993
 994     JUMP_MARK_RETURN;
 995     FUNEND;
 996 }
 997 \end{code}
 998
 999 Marking an IntLike Closure -- Set Mark to corresponding static closure
1000 if in range.  Updating of reference to this will redirect reference to
1001 the static closure.
1002
1003 \begin{code}
1004 STGFUN(_PRStart_IntLike)
1005 {
1006     I_ val;
1007
1008     FUNBEGIN;
1009     if (IS_MARK_BIT_SET(Mark)) {
1010         DEBUG_PR_MARKED;
1011     } else {
1012         val = INTLIKE_VALUE(Mark);
1013
1014         if (val >= MIN_INTLIKE
1015          && val <= MAX_INTLIKE
1016 #ifdef TICKY_TICKY
1017          && !AllFlags.doUpdEntryCounts
1018 #endif
1019            ) {
1020             DEBUG_PR_INTLIKE_TO_STATIC;
1021             GC_COMMON_INTLIKE(); /* ticky */
1022
1023             INFO_PTR(Mark) = (W_) Ind_info;
1024             IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
1025             Mark = (P_) IND_CLOSURE_PTR(Mark);
1026
1027         } else {        /* out of range of static closures */
1028             DEBUG_PR_INTLIKE_IN_HEAP;
1029 #ifdef TICKY_TICKY
1030             if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
1031 #endif
1032             INIT_MARK_NODE("INT ",0);
1033         }
1034     }
1035     JUMP_MARK_RETURN;
1036     FUNEND;
1037 }
1038 \end{code}
1039
1040 Special error routine, used for closures which should never call their
1041 ``in'' code.
1042
1043 \begin{code}
1044 STGFUN(_PRIn_Error)
1045 {
1046     FUNBEGIN;
1047     fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n");
1048     abort();
1049     FUNEND;
1050 }
1051 \end{code}
1052
1053 %****************************************************************************
1054 %
1055 \subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)}
1056 %
1057 %****************************************************************************
1058
1059 \begin{code}
1060 #ifdef PAR
1061 \end{code}
1062
1063 FetchMe's present a unique problem during global GC.  Since the IMU short-circuits
1064 indirections during its evacuation, it may return a PLC as the new global address
1065 for a @FetchMe@ node.  This has the effect of turning the @FetchMe@ into an
1066 indirection during local garbage collection.  Of course, we'd like to short-circuit
1067 this indirection immediately.
1068
1069 \begin{code}
1070 STGFUN(_PRStart_FetchMe)
1071 {
1072     FUNBEGIN;
1073     if (IS_MARK_BIT_SET(Mark)) {
1074         DEBUG_PR_MARKED;
1075     } else
1076         INIT_MARK_NODE("FME ", 0);
1077
1078     JUMP_MARK_RETURN;
1079     FUNEND;
1080 }
1081
1082 STGFUN(_PRStart_BF)
1083 {
1084     FUNBEGIN;
1085     if (IS_MARK_BIT_SET(Mark)) {
1086         DEBUG_PR_MARKED;
1087         JUMP_MARK_RETURN;
1088     } else {
1089         INIT_MARK_NODE("BF  ", BF_CLOSURE_NoPTRS(dummy));
1090         INIT_MSTACK(BF_CLOSURE_PTR);
1091     }
1092     FUNEND;
1093 }
1094
1095 STGFUN(_PRIn_BF)
1096 {
1097     BitWord mbw;
1098
1099     FUNBEGIN;
1100     GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy));
1101     if (++mbw < BF_CLOSURE_NoPTRS(dummy)) {
1102         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw);
1103         CONTINUE_MARKING_NODE("BF  ", mbw);
1104         MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw);
1105     } else {
1106         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L);
1107         POP_MSTACK("BF  ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy));
1108     }
1109     FUNEND;
1110 }
1111
1112 #endif /* PAR */
1113 \end{code}
1114
1115 %****************************************************************************
1116 %
1117 \subsubsection[mark-tso]{Marking Thread State Objects (threaded only)}
1118 %
1119 %****************************************************************************
1120
1121 First mark the link, then mark all live registers (StkO plus the VanillaRegs
1122 indicated by Liveness).
1123
1124 CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
1125
1126 \begin{code}
1127
1128 #ifdef CONCURRENT
1129
1130 STGFUN(_PRStart_BQ)
1131 {
1132     FUNBEGIN;
1133     if (IS_MARK_BIT_SET(Mark)) {
1134         DEBUG_PR_MARKED;
1135         JUMP_MARK_RETURN;
1136     } else {
1137     INIT_MARK_NODE("BQ  ", BQ_CLOSURE_NoPTRS(Mark));
1138         INIT_MSTACK(BQ_CLOSURE_PTR);
1139     }
1140     FUNEND;
1141 }
1142
1143 STGFUN(_PRIn_BQ)
1144 {
1145     FUNBEGIN;
1146     POP_MSTACK("BQ  ",BQ_CLOSURE_PTR,1);
1147     FUNEND;
1148 }
1149
1150 STGFUN(_PRStart_TSO)
1151 {
1152     P_ temp;
1153     FUNBEGIN;
1154     if (IS_MARK_BIT_SET(Mark)) {
1155         DEBUG_PR_MARKED;
1156         JUMP_MARK_RETURN;
1157     } else {
1158     INIT_MARK_NODE("TSO ", 0);
1159     temp = TSO_LINK(Mark);
1160     TSO_LINK(Mark) = MStack;
1161     MStack = Mark;
1162     Mark = temp;
1163     JUMP_MARK;
1164     }
1165     FUNEND;
1166 }
1167 \end{code}
1168
1169 When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to
1170 the vanilla registers r[pos-2].
1171
1172 \begin{code}
1173 STGFUN(_PRIn_TSO)
1174 {
1175     W_ liveness;
1176     BitWord oldpos, newpos;
1177     STGRegisterTable *r;
1178     P_ temp, mstack;
1179
1180     FUNBEGIN;
1181     GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS);
1182     r = TSO_INTERNAL_PTR(MStack);
1183
1184     switch(oldpos) {
1185     case 0:
1186         /* Just did the link; now do the StkO */
1187         SET_MARKED_PTRS(MStack,TSO_PTRS,1L);
1188         temp = r->rStkO;
1189         r->rStkO = TSO_LINK(MStack);
1190         TSO_LINK(MStack) = Mark;
1191         Mark = temp;
1192         DEBUG_PRIN("TSO ", 1);
1193         JUMP_MARK;
1194         break;
1195     case 1:
1196         /* Just did the StkO; just update it, saving the old mstack */
1197         mstack = r->rStkO;
1198         r->rStkO = Mark;
1199         break;
1200     default:
1201         /* update the register we just did; save the old mstack */
1202         mstack = r->rR[oldpos - 2].p;
1203         r->rR[oldpos - 2] = Mark;
1204         break;
1205     }
1206
1207     /* liveness of the remaining registers */
1208     liveness = r->rLiveness >> (oldpos - 1);
1209
1210     if (liveness == 0) {
1211         /* Restore MStack and return */
1212         SET_MARKED_PTRS(MStack,TSO_PTRS,0L);
1213         DEBUG_PRLAST("TSO ", oldpos);
1214         Mark = MStack;
1215         MStack = mstack;
1216         JUMP_MARK_RETURN;
1217     }
1218
1219     /* More to do in this TSO */
1220
1221     /* Shift past non-ptr registers */
1222     for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) {
1223         newpos++;
1224     }
1225
1226     /* Mark the next one */
1227     SET_MARKED_PTRS(MStack,TSO_PTRS,newpos);
1228     Mark = r->rR[newpos - 2].p;
1229     r->rR[newpos - 2].p = mstack;
1230     DEBUG_PRIN("TSO ", oldpos);
1231     JUMP_MARK;
1232
1233     FUNEND;
1234 }
1235
1236 \end{code}
1237
1238 %****************************************************************************
1239 %
1240 \subsubsection[mark-stko]{Marking Stack Objects (threaded only)}
1241 %
1242 %****************************************************************************
1243
1244 First mark the A stack, then mark all updatees in the B stack.
1245
1246 \begin{code}
1247
1248 STGFUN(_PRStart_StkO)
1249 {
1250     P_ temp;
1251     I_ size;
1252     I_ cts_size;
1253
1254     FUNBEGIN;
1255
1256     /* ToDo: ASSERT(sanityChk_StkO(Mark)); ??? */
1257
1258     if (IS_MARK_BIT_SET(Mark)) {
1259         DEBUG_PR_MARKED;
1260         JUMP_MARK_RETURN;
1261     } else {
1262     INIT_MARK_NODE("STKO", 0);
1263     size = STKO_CLOSURE_SIZE(Mark);
1264     cts_size = STKO_CLOSURE_CTS_SIZE(Mark);
1265     SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1));
1266     temp = STKO_LINK(Mark);
1267     STKO_LINK(Mark) = MStack;
1268     MStack = Mark;
1269     Mark = temp;
1270     JUMP_MARK;
1271     }
1272     FUNEND;
1273 }
1274 \end{code}
1275
1276 Now the ``in'' code for \tr{STKO} closures.  First the A stack is flushed,
1277 then we chain down the update frames in the B stack, marking the update
1278 nodes.  When all have been marked we pop the stack and return.
1279
1280 \begin{code}
1281 STGFUN(_PRIn_StkO)
1282 {
1283     BitWord oldpos, newpos;
1284     P_ mstack;
1285     I_ size;
1286
1287     FUNBEGIN;
1288
1289     size = STKO_CLOSURE_SIZE(MStack);
1290     GET_GEN_MARKED_PTRS(oldpos, MStack, size);
1291
1292     if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) {
1293         /* Update the link, saving the old mstack */
1294         mstack = STKO_LINK(MStack);
1295         STKO_LINK(MStack) = Mark;
1296     } else {
1297         /* Update the pointer, saving the old mstack */
1298         mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos);
1299         STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark;
1300     }
1301
1302     /* Calculate the next position to mark */
1303     if (oldpos > STKO_SpA_OFFSET(MStack)) {
1304         /* Just walk backwards down the A stack */
1305         newpos = oldpos - 1;
1306         SET_GEN_MARKED_PTRS(MStack,size,newpos);
1307         Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos);
1308         STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack;
1309         DEBUG_PRIN("STKA", oldpos);
1310         JUMP_MARK;
1311     } else if (oldpos <= STKO_SuB_OFFSET(MStack)) {
1312         /* We're looking at an updatee in the B stack; find the next SuB up the chain */
1313         P_ subptr;
1314
1315         subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE)));
1316         newpos = STKO_CLOSURE_OFFSET(MStack,subptr);
1317     } else {
1318         /* Just fell off the end of the A stack; grab the first SuB */
1319         newpos = STKO_SuB_OFFSET(MStack);
1320     }
1321
1322     if (newpos == 0) {  /* Grrr...  newpos is 1-based */
1323         /* Restore MStack and return */
1324         SET_GEN_MARKED_PTRS(MStack,size,0L);
1325         DEBUG_PRLAST("STKO", oldpos);
1326         Mark = MStack;
1327         MStack = mstack;
1328         JUMP_MARK_RETURN;
1329     }
1330
1331     /* newpos is actually the SuB; we want the corresponding updatee */
1332     SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE));
1333     Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE));
1334     STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack;
1335     DEBUG_PRIN("STKB", oldpos);
1336     JUMP_MARK;
1337
1338     FUNEND;
1339 }
1340 #endif  /* CONCURRENT */
1341 \end{code}
1342
1343 %****************************************************************************
1344 %
1345 \subsubsection[mark-caf]{Marking CAFs}
1346 %
1347 %****************************************************************************
1348
1349 A CAF is shorted out as if it were an indirection.
1350 The CAF reference is explicitly updated by the garbage collector.
1351
1352 \begin{code}
1353 STGFUN(_PRStart_Caf)
1354 {
1355     FUNBEGIN;
1356     DEBUG_PR_CAF;
1357     GC_SHORT_CAF(); /* ticky */
1358
1359     Mark = (P_) IND_CLOSURE_PTR(Mark);
1360     JUMP_MARK;
1361     FUNEND;
1362 }
1363 \end{code}
1364
1365 %****************************************************************************
1366 %
1367 \subsection[mark-root]{Root Marking Code}
1368 %
1369 %****************************************************************************
1370
1371 Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file.
1372
1373 These are routines placed in closures at the bottom of the marking stack
1374
1375 \begin{code}
1376 STGFUN(_Dummy_PRReturn_entry)
1377 {
1378     FUNBEGIN;
1379     fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
1380     abort();
1381     FUNEND;
1382 }
1383
1384 /* various ways to call _Dummy_PRReturn_entry: */
1385
1386 INTFUN(_PRMarking_MarkNextRoot_entry)   { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1387 #ifdef CONCURRENT
1388 INTFUN(_PRMarking_MarkNextSpark_entry)  { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1389 #endif
1390 #ifdef PAR
1391 INTFUN(_PRMarking_MarkNextGA_entry)     { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1392 #endif
1393 #  if 1 /* !defined(CONCURRENT) */ /* HWL */
1394 INTFUN(_PRMarking_MarkNextAStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1395 INTFUN(_PRMarking_MarkNextBStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1396 #  endif
1397 INTFUN(_PRMarking_MarkNextCAF_entry)    { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1398
1399 #if defined(GRAN)
1400 INTFUN(_PRMarking_MarkNextEvent_entry)  { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1401 INTFUN(_PRMarking_MarkNextClosureInFetchBuffer_entry)   { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1402 #endif
1403
1404 /* end of various ways to call _Dummy_PRReturn_entry */
1405
1406 EXTFUN(_PRMarking_MarkNextRoot);
1407 EXTFUN(_PRMarking_MarkNextCAF);
1408
1409 #ifdef CONCURRENT
1410 EXTFUN(_PRMarking_MarkNextSpark);
1411 #endif
1412
1413 #ifdef PAR
1414 EXTFUN(_PRMarking_MarkNextGA);
1415 #else
1416 #  if 1 /* !defined(CONCURRENT) */  /* HWL */
1417 EXTFUN(_PRMarking_MarkNextAStack);
1418 EXTFUN(_PRMarking_MarkNextBStack);
1419 #  endif
1420 #endif /* not parallel */
1421
1422 CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
1423     /* just one, shared */
1424
1425 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
1426                        _PRMarking_MarkNextRoot_info,
1427                        _PRMarking_MarkNextRoot,
1428                        _PRMarking_MarkNextRoot_entry);
1429
1430 #ifdef CONCURRENT
1431 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
1432                        _PRMarking_MarkNextSpark_info,
1433                        _PRMarking_MarkNextSpark,
1434                        _PRMarking_MarkNextSpark_entry);
1435 #endif
1436
1437 #if defined(GRAN)
1438 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextEvent_closure,
1439                        _PRMarking_MarkNextEvent_info,
1440                        _PRMarking_MarkNextEvent,
1441                        _PRMarking_MarkNextEvent_entry);
1442 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextClosureInFetchBuffer_closure,
1443                        _PRMarking_MarkNextClosureInFetchBuffer_info,
1444                        _PRMarking_MarkNextClosureInFetchBuffer,
1445                        _PRMarking_MarkNextClosureInFetchBuffer_entry);
1446 #endif
1447
1448 #ifdef PAR
1449 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
1450                        _PRMarking_MarkNextGA_info,
1451                        _PRMarking_MarkNextGA,
1452                        _PRMarking_MarkNextGA_entry);
1453 #else
1454 #  if 1 /* !defined(CONCURRENT) */ /* HWL */
1455 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
1456                        _PRMarking_MarkNextAStack_info,
1457                        _PRMarking_MarkNextAStack,
1458                        _PRMarking_MarkNextAStack_entry);
1459
1460 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
1461                        _PRMarking_MarkNextBStack_info,
1462                        _PRMarking_MarkNextBStack,
1463                        _PRMarking_MarkNextBStack_entry);
1464 #  endif
1465 #endif /* PAR */
1466
1467 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
1468                        _PRMarking_MarkNextCAF_info,
1469                        _PRMarking_MarkNextCAF,
1470                        _PRMarking_MarkNextCAF_entry);
1471
1472 extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */
1473
1474 STGFUN(_PRMarking_MarkNextRoot)
1475 {
1476     FUNBEGIN;
1477     /* Update root -- may have short circuited Ind */
1478     *MRoot = (W_) Mark;
1479
1480     /* Is the next off the end */
1481     if (++MRoot >= sm_roots_end)
1482         RESUME_(miniInterpretEnd);
1483
1484     Mark = (P_) *MRoot;
1485     JUMP_MARK;
1486     FUNEND;
1487 }
1488
1489 #if defined(CONCURRENT)
1490 # if !defined(GRAN)
1491 extern P_ sm_roots_end; /* PendingSparksTl[pool] */
1492
1493 STGFUN(_PRMarking_MarkNextSpark)
1494 {
1495     FUNBEGIN;
1496     /* Update root -- may have short circuited Ind */
1497     *MRoot = (W_) Mark;
1498
1499     /* Is the next off the end */
1500     if (++MRoot >= sm_roots_end)
1501         RESUME_(miniInterpretEnd);
1502
1503     Mark = (P_) *MRoot;
1504     JUMP_MARK;
1505     FUNEND;
1506 }
1507 #else  /* GRAN */
1508 STGFUN(_PRMarking_MarkNextSpark)
1509 {
1510     /* This is more similar to MarkNextGA than to the MarkNextSpark in
1511        concurrent-but-not-gran land
1512        NB: MRoot is a spark (with an embedded pointer to a closure) */
1513     FUNBEGIN;
1514     /* Update root -- may have short circuited Ind */
1515     SPARK_NODE( ((sparkq) MRoot) ) = Mark;
1516     MRoot = (P_) SPARK_NEXT( ((sparkq) MRoot) );
1517
1518     /* Is the next off the end */
1519     if (MRoot == NULL)
1520         RESUME_(miniInterpretEnd);
1521
1522     Mark = (P_) SPARK_NODE( ((sparkq) MRoot) );
1523     JUMP_MARK;
1524     FUNEND;
1525 }
1526 #endif /* GRAN */
1527 #endif /* CONCURRENT */
1528 \end{code}
1529
1530 Note: Events are GranSim-only.
1531 Marking events is similar to marking GALA entries in parallel-land.
1532 The major difference is that depending on the type of the event we have
1533 to mark different field of the event (possibly several fields).
1534 Even worse, in the case of bulk fetching
1535 (@RTSflags.GranFlags.DoGUMMFetching@) we find a buffer of pointers to
1536 closures we have to mark (similar to sparks in concurrent-but-not-gransim
1537 setup).
1538
1539 \begin{code}
1540 #if defined(GRAN)
1541 STGFUN(_PRMarking_MarkNextEvent)
1542 {
1543   rtsBool found = rtsFalse;
1544
1545   FUNBEGIN;
1546
1547   /* First update the right component of the old event */
1548   switch (EVENT_TYPE( ((eventq) MRoot) )) {
1549     case CONTINUETHREAD:
1550     case STARTTHREAD:
1551     case RESUMETHREAD:
1552     case MOVETHREAD:
1553        EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1554        break;
1555     case MOVESPARK:
1556        SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) )) = (P_) Mark;
1557        break;
1558     case FETCHNODE:
1559        switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
1560         case 0:
1561           EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1562           EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
1563           Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
1564           JUMP_MARK;
1565           break;
1566         case 1:
1567           EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
1568           EVENT_GC_INFO( ((eventq) MRoot) ) = 0;             /* reset flag */
1569           break;
1570         default:
1571           fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
1572                           ((eventq) MRoot) );
1573           EXIT(EXIT_FAILURE);
1574        }
1575        break;
1576     case FETCHREPLY:
1577        switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
1578         case 0:
1579           EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1580           EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
1581           /* In the case of packet fetching, EVENT_NODE(event) points to */
1582           /* the packet (currently, malloced). The packet is just a list of */
1583           /* closure addresses, with the length of the list at index 1 (the */
1584           /* structure of the packet is defined in Pack.lc). */
1585           if ( RTSflags.GranFlags.DoGUMMFetching ) {
1586             P_ buffer = (P_) EVENT_NODE( ((eventq) MRoot) );
1587             int size = (int) buffer[PACK_SIZE_LOCN];
1588
1589             /* was: for (i = PACK_HDR_SIZE; i <= size-1; i++) ... */
1590             sm_roots_end = buffer + PACK_HDR_SIZE + size;
1591             MRoot = (P_) buffer + PACK_HDR_SIZE;
1592             ret_MRoot = MRoot;
1593             Mark = (P_) *MRoot;
1594             ret_Mark = Mark;
1595             MStack = (P_) _PRMarking_MarkNextClosureInFetchBuffer_closure;
1596             JUMP_MARK;
1597           } else {
1598             Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
1599             JUMP_MARK;
1600           }
1601           break;
1602         case 1:
1603           if ( RTSflags.GranFlags.DoGUMMFetching ) {
1604             /* no update necessary; fetch buffers are malloced */
1605           } else {
1606             EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
1607           }
1608           EVENT_GC_INFO( ((eventq) MRoot) ) = 0;             /* reset flag */
1609           break;
1610         default:
1611           fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHREPLY event @ %#x\n",
1612                           ((eventq) MRoot) );
1613           EXIT(EXIT_FAILURE);
1614        }
1615        break;
1616
1617     case GLOBALBLOCK:
1618        switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
1619         case 0:
1620           EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1621           EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
1622           Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
1623           JUMP_MARK;
1624           break;
1625           break;
1626         case 1:
1627           EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
1628           EVENT_GC_INFO( ((eventq) MRoot) ) = 0;             /* reset flag */
1629           break;
1630         default:
1631           fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of GLOBALBLOCK event @ %#x\n",
1632                           ((eventq) MRoot) );
1633           EXIT(EXIT_FAILURE);
1634        }
1635        break;
1636     case UNBLOCKTHREAD:
1637        EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1638        break;
1639     case FINDWORK:
1640        break;
1641     default:
1642        fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
1643                        ((eventq) MRoot) );
1644        EXIT(EXIT_FAILURE);
1645   }
1646
1647   do {
1648       MRoot = (P_) EVENT_NEXT( ((eventq) MRoot) );
1649       /* Is the next off the end */
1650       if (MRoot == NULL)
1651             RESUME_(miniInterpretEnd);
1652
1653       switch (EVENT_TYPE( ((eventq) MRoot) )) {
1654         case CONTINUETHREAD:
1655         case STARTTHREAD:
1656         case RESUMETHREAD:
1657         case MOVETHREAD:
1658            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1659            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1660            found = rtsTrue;
1661            break;
1662         case MOVESPARK:
1663            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1664            Mark = (P_) SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) ));
1665            found = rtsTrue;
1666            break;
1667         case FETCHNODE:
1668            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1669            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1670            found = rtsTrue;
1671            break;
1672         case FETCHREPLY:
1673            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1674            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1675            found = rtsTrue;
1676            break;
1677          case GLOBALBLOCK:
1678            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1679            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1680            found = rtsTrue;
1681            break;
1682         case UNBLOCKTHREAD:
1683            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1684            found = rtsTrue;
1685            break;
1686         case FINDWORK:
1687            found = rtsFalse;
1688            break;
1689         default:
1690            fprintf(stderr,"Unknown event type %d (event @ %#x) in SMmarking_NextEvent\n",
1691                           EVENT_TYPE( ((eventq) MRoot) ), MRoot);
1692            EXIT(EXIT_FAILURE);
1693         }
1694     } while (!found && MRoot!=NULL);
1695
1696     JUMP_MARK;
1697
1698     FUNEND;
1699 }
1700
1701 STGFUN(_PRMarking_MarkNextClosureInFetchBuffer)
1702 {
1703     FUNBEGIN;
1704     /* Update root -- may have short circuited Ind */
1705     *MRoot = Mark;
1706
1707     /* Is the next off the end */
1708     if (++MRoot >= sm_roots_end) {
1709       /* We know that marking a fetch buffer is only called from within
1710          marking a FETCHREPLY event; we have saved the important
1711          registers before that  */
1712       MRoot = ret_MRoot;
1713       Mark = ret_Mark;
1714       MStack = (P_) _PRMarking_MarkNextEvent_closure;
1715       JUMP_MARK;
1716     }
1717
1718     Mark = *MRoot;
1719     JUMP_MARK;
1720     FUNEND;
1721 }
1722 #endif
1723
1724 #ifdef PAR
1725 STGFUN(_PRMarking_MarkNextGA)
1726 {
1727     FUNBEGIN;
1728     /* Update root -- may have short circuited Ind */
1729     ((GALA *)MRoot)->la = Mark;
1730
1731     do {
1732         MRoot = (P_) ((GALA *) MRoot)->next;
1733     } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT);
1734
1735     /* Is the next off the end */
1736     if (MRoot == NULL)
1737         RESUME_(miniInterpretEnd);
1738
1739     Mark = ((GALA *)MRoot)->la;
1740     JUMP_MARK;
1741     FUNEND;
1742 }
1743
1744 #else
1745 STGFUN(_PRMarking_MarkNextAStack)
1746 {
1747     FUNBEGIN;
1748     /* Update root -- may have short circuited Ind */
1749     *MRoot = (W_) Mark;
1750
1751     /* Is the next off the end */
1752     if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0)
1753         RESUME_(miniInterpretEnd);
1754
1755     Mark = (P_) *MRoot;
1756     JUMP_MARK;
1757     FUNEND;
1758 }
1759
1760
1761 STGFUN(_PRMarking_MarkNextBStack)
1762 {
1763     FUNBEGIN;
1764     /* Update root -- may have short circuited Ind */
1765     PUSH_UPDATEE(MRoot, Mark);
1766
1767     MRoot = GRAB_SuB(MRoot);
1768
1769     /* Is the next off the end */
1770     if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0)
1771         RESUME_(miniInterpretEnd);
1772
1773     Mark = GRAB_UPDATEE(MRoot);
1774     JUMP_MARK;
1775     FUNEND;
1776 }
1777 #endif  /* PAR */
1778 \end{code}
1779
1780 Mark the next CAF in the CAF list.
1781
1782 \begin{code}
1783 STGFUN(_PRMarking_MarkNextCAF)
1784 {
1785     FUNBEGIN;
1786
1787     /* Update root -- may have short circuited Ind */
1788     IND_CLOSURE_PTR(MRoot) = (W_) Mark;
1789
1790     MRoot = (P_) IND_CLOSURE_LINK(MRoot);
1791
1792     /* Is the next CAF the end of the list */
1793     if (MRoot == 0)
1794         RESUME_(miniInterpretEnd);
1795
1796     GC_SHORT_CAF(); /* ticky (ToDo: wrong?) */
1797
1798     Mark = (P_) IND_CLOSURE_PTR(MRoot);
1799     JUMP_MARK;
1800     FUNEND;
1801 }
1802 \end{code}
1803
1804 Multi-slurp protection.
1805
1806 \begin{code}
1807 #endif /* _INFO_MARKING */
1808 \end{code}