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         INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
 670     }
 671     FUNEND;
 672 }
 673
 674 STGFUN(_PRIn_I_MuTuple)
 675 {
 676     W_ ptrs;
 677     BitWord pos;
 678
 679     FUNBEGIN;
 680     ptrs = MUTUPLE_CLOSURE_NoPTRS(MStack);
 681     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 682
 683     if (++pos < ptrs) {
 684         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 685         CONTINUE_MARKING_NODE("MUT",pos);
 686         MOVE_TO_NEXT_PTR(MUTUPLE_CLOSURE_PTR,pos);
 687     } else {
 688         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 689         POP_MSTACK("MUT ",MUTUPLE_CLOSURE_PTR,ptrs);
 690       }
 691     FUNEND;
 692 }
 693
 694 #endif /* GCap || GCgn */
 695 \end{code}
 696
 697 There are no pointers in a \tr{DATA} closure, so just mark the
 698 closure and return.
 699
 700 \begin{code}
 701 STGFUN(_PRStart_Data)
 702 {
 703     FUNBEGIN;
 704     if (IS_MARK_BIT_SET(Mark)) {
 705         DEBUG_PR_MARKED;
 706     } else
 707     INIT_MARK_NODE("DATA", 0);
 708     JUMP_MARK_RETURN;
 709     FUNEND;
 710 }
 711 \end{code}
 712
 713 %****************************************************************************
 714 %
 715 \subsubsection[mark-specials]{Special cases}
 716 %
 717 %****************************************************************************
 718
 719 Black hole closures simply mark themselves and return.
 720
 721 \begin{code}
 722 STGFUN(_PRStart_BH)
 723 {
 724     FUNBEGIN;
 725     if (IS_MARK_BIT_SET(Mark)) {
 726         DEBUG_PR_MARKED;
 727     } else
 728     INIT_MARK_NODE("BH  ", 0);
 729     JUMP_MARK_RETURN;
 730     FUNEND;
 731 }
 732 \end{code}
 733
 734 Marking a Static Closure -- Just return as if Marked
 735
 736 \begin{code}
 737 STGFUN(_PRStart_Static)
 738 {
 739     FUNBEGIN;
 740     DEBUG_PR_STAT;
 741     JUMP_MARK_RETURN;
 742     FUNEND;
 743 }
 744 \end{code}
 745
 746 Marking an Indirection -- Set Mark to ind addr and mark this.
 747 Updating of reference when we return will short indirection.
 748
 749 \begin{code}
 750 STGFUN(_PRStart_Ind)
 751 {
 752     FUNBEGIN;
 753     DEBUG_PR_IND;
 754     GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
 755
 756     Mark = (P_) IND_CLOSURE_PTR(Mark);
 757     JUMP_MARK;
 758     FUNEND;
 759 }
 760 \end{code}
 761
 762 ``Permanent indirection''---used in profiling.  Works basically
 763 like @_PRStart_1@ (one pointer).
 764 \begin{code}
 765 #if defined(PROFILING) || defined(TICKY_TICKY)
 766
 767 STGFUN(_PRStart_PI)
 768 {
 769     FUNBEGIN;
 770
 771     if (IS_MARK_BIT_SET(Mark)) {
 772         DEBUG_PR_MARKED;
 773         JUMP_MARK_RETURN;
 774     } else {
 775         INIT_MARK_NODE("PI  ",1);
 776         /* the "1" above is dodgy (i.e. wrong), but it is never
 777            used except in debugging info.  ToDo??? WDP 95/07
 778         */
 779         INIT_MSTACK(PERM_IND_CLOSURE_PTR);
 780     }
 781     FUNEND;
 782 }
 783
 784 STGFUN(_PRIn_PI)
 785 {
 786     FUNBEGIN;
 787     POP_MSTACK("PI  ",PERM_IND_CLOSURE_PTR,1);
 788     /* the "1" above is dodgy (i.e. wrong), but it is never
 789        used except in debugging info.  ToDo??? WDP 95/07
 790     */
 791     FUNEND;
 792 }
 793
 794 #endif /* PROFILING or TICKY */
 795 \end{code}
 796
 797 Marking a ``selector closure'': This is a size-2 SPEC thunk that
 798 selects word $n$; if the thunk's pointee is evaluated, then we short
 799 out the selection, {\em just like an indirection}.  If it is still
 800 unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}.
 801
 802 {\em Should we select ``on the way down'' (in \tr{_PRStart_Selector})
 803 or ``on the way back up'' (\tr{_PRIn_Selector})?}  Answer: probably on
 804 the way down.  Downside: we are flummoxed by indirections, so we'll
 805 have to wait until the {\em next} major GC to do the selections (after
 806 the indirections are shorted out in this GC).  But the downside of
 807 doing selections on the way back up is that we are then in a world of
 808 reversed pointers, and selecting a reversed pointer---we've see this
 809 on selectors for very recursive structures---is a total disaster.
 810 (WDP 94/12)
 811
 812 \begin{code}
 813 #if defined(DEBUG)
 814 #define IF_GC_DEBUG(x) x
 815 #else
 816 #define IF_GC_DEBUG(x) /*nothing*/
 817 #endif
 818
 819 #if !defined(CONCURRENT)
 820 # define NOT_BLACKHOLING (! RTSflags.GcFlags.lazyBlackHoling)
 821 #else
 822 # define NOT_BLACKHOLING 0
 823 #endif
 824
 825 /* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
 826
 827 #define MARK_SELECTOR(n)                                                \
 828 STGFUN(CAT2(_PRStartSelector_,n))                                       \
 829 {                                                                       \
 830     P_ maybe_con;                                                       \
 831     FUNBEGIN;                                                           \
 832                                                                         \
 833     /* must be a SPEC 2 1 closure */                                    \
 834     ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);                             \
 835     ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);                           \
 836     ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */            \
 837                                                                         \
 838     if (IS_MARK_BIT_SET(Mark)) { /* already marked */                   \
 839         DEBUG_PR_MARKED;                                                \
 840         JUMP_MARK_RETURN;                                               \
 841     }                                                                   \
 842                                                                         \
 843     maybe_con = (P_) *(Mark + _FHS);                                    \
 844                                                                         \
 845     IF_GC_DEBUG(                                                        \
 846     if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING)  {                                                \
 847         fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, info 0x%lx", \
 848                 (n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)),   \
 849                 INFO_NoPTRS(INFO_PTR(Mark)),                            \
 850                 maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/       \
 851                 INFO_PTR(maybe_con));                                   \
 852         fprintf(stderr, ", tag %ld, size %ld, ptrs %ld",                \
 853             INFO_TAG(INFO_PTR(maybe_con)),                              \
 854             INFO_SIZE(INFO_PTR(maybe_con)),                             \
 855             INFO_NoPTRS(INFO_PTR(maybe_con)));                          \
 856         if (INFO_TAG(INFO_PTR(maybe_con)) >=0) {                        \
 857             fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]);         \
 858         }                                                               \
 859         fprintf(stderr, "\n");                                          \
 860     } )                                                                 \
 861                                                                         \
 862     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
 863      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */    \
 864      || INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */             \
 865      || NOT_BLACKHOLING  /* see "price of laziness" paper */            \
 866      || (! RTSflags.GcFlags.doSelectorsAtGC ))                          \
 867         /* see below for OLD test we used here (WDP 95/04) */           \
 868         /* ToDo: decide WHNFness another way? */                        \
 869         JMP_(_PRStart_1);                                               \
 870                                                                         \
 871     /* some things should be true about the pointee */                  \
 872     ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0);                         \
 873     /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
 874                                                                         \
 875     /* OK, it is evaluated: behave just like an indirection */          \
 876     GC_SEL_MAJOR(); /* ticky-ticky */                                   \
 877                                                                         \
 878     Mark = (P_) (maybe_con[_FHS + (n)]);                                \
 879     /* Mark now has the result of the selection */                      \
 880     JUMP_MARK;                                                          \
 881                                                                         \
 882     FUNEND;                                                             \
 883 }
 884
 885 #if 0
 886 /* OLD test:
 887    the IS_STATIC test was to protect the IS_MARK_BIT_SET check;
 888    but the IS_MARK_BIT_SET test was only there to avoid
 889    mangled pointers, but we cannot have mangled pointers anymore
 890    (after RTBLs came our way).
 891    SUMMARY: we toss both of the "guard" tests.
 892  */
 893     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */
 894      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */
 895      || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
 896 #endif /* 0 */
 897
 898 MARK_SELECTOR(0)
 899 MARK_SELECTOR(1)
 900 MARK_SELECTOR(2)
 901 MARK_SELECTOR(3)
 902 MARK_SELECTOR(4)
 903 MARK_SELECTOR(5)
 904 MARK_SELECTOR(6)
 905 MARK_SELECTOR(7)
 906 MARK_SELECTOR(8)
 907 MARK_SELECTOR(9)
 908 MARK_SELECTOR(10)
 909 MARK_SELECTOR(11)
 910 MARK_SELECTOR(12)
 911
 912 #undef IF_GC_DEBUG /* get rid of it */
 913 \end{code}
 914
 915 Marking a Constant Closure -- Set Mark to corresponding static
 916 closure.  Updating of reference will redirect reference to the static
 917 closure.
 918
 919 \begin{code}
 920 STGFUN(_PRStart_Const)
 921 {
 922     FUNBEGIN;
 923     DEBUG_PR_CONST;
 924
 925 #ifndef TICKY_TICKY
 926     /* normal stuff */
 927     Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 928
 929 #else /* TICKY */
 930     if (IS_MARK_BIT_SET(Mark)) {
 931         DEBUG_PR_MARKED;
 932     } else {
 933         if (!AllFlags.doUpdEntryCounts) {
 934
 935             GC_COMMON_CONST(); /* ticky */
 936
 937             Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 938
 939         } else { /* no commoning */
 940             INIT_MARK_NODE("CONST ",0);
 941         }
 942     }
 943 #endif /* TICKY */
 944
 945     JUMP_MARK_RETURN;
 946     FUNEND;
 947 }
 948 \end{code}
 949
 950 Marking a CharLike Closure -- Set Mark to corresponding static
 951 closure.  Updating of reference will redirect reference to the static
 952 closure.
 953
 954 \begin{code}
 955 STGFUN(_PRStart_CharLike)
 956 {
 957 #ifdef TICKY_TICKY
 958     I_ val;
 959 #endif
 960
 961     FUNBEGIN;
 962
 963     DEBUG_PR_CHARLIKE;
 964
 965 #ifndef TICKY_TICKY
 966     /* normal stuff */
 967
 968     Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
 969
 970 #else /* TICKY */
 971
 972     if (IS_MARK_BIT_SET(Mark)) {
 973         DEBUG_PR_MARKED;
 974     } else {
 975         val = CHARLIKE_VALUE(Mark);
 976
 977         if (!AllFlags.doUpdEntryCounts) {
 978             GC_COMMON_CHARLIKE(); /* ticky */
 979
 980             INFO_PTR(Mark) = (W_) Ind_info;
 981             IND_CLOSURE_PTR(Mark) = (W_) CHARLIKE_CLOSURE(val);
 982             Mark = (P_) IND_CLOSURE_PTR(Mark);
 983
 984         } else { /* no commoning */
 985             INIT_MARK_NODE("CHAR ",0);
 986         }
 987     }
 988 #endif /* TICKY */
 989
 990     JUMP_MARK_RETURN;
 991     FUNEND;
 992 }
 993 \end{code}
 994
 995 Marking an IntLike Closure -- Set Mark to corresponding static closure
 996 if in range.  Updating of reference to this will redirect reference to
 997 the static closure.
 998
 999 \begin{code}
1000 STGFUN(_PRStart_IntLike)
1001 {
1002     I_ val;
1003
1004     FUNBEGIN;
1005     if (IS_MARK_BIT_SET(Mark)) {
1006         DEBUG_PR_MARKED;
1007     } else {
1008         val = INTLIKE_VALUE(Mark);
1009
1010         if (val >= MIN_INTLIKE
1011          && val <= MAX_INTLIKE
1012 #ifdef TICKY_TICKY
1013          && !AllFlags.doUpdEntryCounts
1014 #endif
1015            ) {
1016             DEBUG_PR_INTLIKE_TO_STATIC;
1017             GC_COMMON_INTLIKE(); /* ticky */
1018
1019             INFO_PTR(Mark) = (W_) Ind_info;
1020             IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
1021             Mark = (P_) IND_CLOSURE_PTR(Mark);
1022
1023         } else {        /* out of range of static closures */
1024             DEBUG_PR_INTLIKE_IN_HEAP;
1025 #ifdef TICKY_TICKY
1026             if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
1027 #endif
1028             INIT_MARK_NODE("INT ",0);
1029         }
1030     }
1031     JUMP_MARK_RETURN;
1032     FUNEND;
1033 }
1034 \end{code}
1035
1036 Special error routine, used for closures which should never call their
1037 ``in'' code.
1038
1039 \begin{code}
1040 STGFUN(_PRIn_Error)
1041 {
1042     FUNBEGIN;
1043     fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n");
1044     abort();
1045     FUNEND;
1046 }
1047 \end{code}
1048
1049 %****************************************************************************
1050 %
1051 \subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)}
1052 %
1053 %****************************************************************************
1054
1055 \begin{code}
1056 #ifdef PAR
1057 \end{code}
1058
1059 FetchMe's present a unique problem during global GC.  Since the IMU short-circuits
1060 indirections during its evacuation, it may return a PLC as the new global address
1061 for a @FetchMe@ node.  This has the effect of turning the @FetchMe@ into an
1062 indirection during local garbage collection.  Of course, we'd like to short-circuit
1063 this indirection immediately.
1064
1065 \begin{code}
1066 STGFUN(_PRStart_FetchMe)
1067 {
1068     FUNBEGIN;
1069     if (IS_MARK_BIT_SET(Mark)) {
1070         DEBUG_PR_MARKED;
1071     } else
1072         INIT_MARK_NODE("FME ", 0);
1073
1074     JUMP_MARK_RETURN;
1075     FUNEND;
1076 }
1077
1078 STGFUN(_PRStart_BF)
1079 {
1080     FUNBEGIN;
1081     if (IS_MARK_BIT_SET(Mark)) {
1082         DEBUG_PR_MARKED;
1083         JUMP_MARK_RETURN;
1084     } else {
1085         INIT_MARK_NODE("BF  ", BF_CLOSURE_NoPTRS(dummy));
1086         INIT_MSTACK(BF_CLOSURE_PTR);
1087     }
1088     FUNEND;
1089 }
1090
1091 STGFUN(_PRIn_BF)
1092 {
1093     BitWord mbw;
1094
1095     FUNBEGIN;
1096     GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy));
1097     if (++mbw < BF_CLOSURE_NoPTRS(dummy)) {
1098         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw);
1099         CONTINUE_MARKING_NODE("BF  ", mbw);
1100         MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw);
1101     } else {
1102         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L);
1103         POP_MSTACK("BF  ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy));
1104     }
1105     FUNEND;
1106 }
1107
1108 #endif /* PAR */
1109 \end{code}
1110
1111 %****************************************************************************
1112 %
1113 \subsubsection[mark-tso]{Marking Thread State Objects (threaded only)}
1114 %
1115 %****************************************************************************
1116
1117 First mark the link, then mark all live registers (StkO plus the VanillaRegs
1118 indicated by Liveness).
1119
1120 CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
1121
1122 \begin{code}
1123
1124 #ifdef CONCURRENT
1125
1126 STGFUN(_PRStart_BQ)
1127 {
1128     FUNBEGIN;
1129     if (IS_MARK_BIT_SET(Mark)) {
1130         DEBUG_PR_MARKED;
1131         JUMP_MARK_RETURN;
1132     } else {
1133     INIT_MARK_NODE("BQ  ", BQ_CLOSURE_NoPTRS(Mark));
1134         INIT_MSTACK(BQ_CLOSURE_PTR);
1135     }
1136     FUNEND;
1137 }
1138
1139 STGFUN(_PRIn_BQ)
1140 {
1141     FUNBEGIN;
1142     POP_MSTACK("BQ  ",BQ_CLOSURE_PTR,1);
1143     FUNEND;
1144 }
1145
1146 STGFUN(_PRStart_TSO)
1147 {
1148     P_ temp;
1149     FUNBEGIN;
1150     if (IS_MARK_BIT_SET(Mark)) {
1151         DEBUG_PR_MARKED;
1152         JUMP_MARK_RETURN;
1153     } else {
1154     INIT_MARK_NODE("TSO ", 0);
1155     temp = TSO_LINK(Mark);
1156     TSO_LINK(Mark) = MStack;
1157     MStack = Mark;
1158     Mark = temp;
1159     JUMP_MARK;
1160     }
1161     FUNEND;
1162 }
1163 \end{code}
1164
1165 When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to
1166 the vanilla registers r[pos-2].
1167
1168 \begin{code}
1169 STGFUN(_PRIn_TSO)
1170 {
1171     W_ liveness;
1172     BitWord oldpos, newpos;
1173     STGRegisterTable *r;
1174     P_ temp, mstack;
1175
1176     FUNBEGIN;
1177     GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS);
1178     r = TSO_INTERNAL_PTR(MStack);
1179
1180     switch(oldpos) {
1181     case 0:
1182         /* Just did the link; now do the StkO */
1183         SET_MARKED_PTRS(MStack,TSO_PTRS,1L);
1184         temp = r->rStkO;
1185         r->rStkO = TSO_LINK(MStack);
1186         TSO_LINK(MStack) = Mark;
1187         Mark = temp;
1188         DEBUG_PRIN("TSO ", 1);
1189         JUMP_MARK;
1190         break;
1191     case 1:
1192         /* Just did the StkO; just update it, saving the old mstack */
1193         mstack = r->rStkO;
1194         r->rStkO = Mark;
1195         break;
1196     default:
1197         /* update the register we just did; save the old mstack */
1198         mstack = r->rR[oldpos - 2].p;
1199         r->rR[oldpos - 2] = Mark;
1200         break;
1201     }
1202
1203     /* liveness of the remaining registers */
1204     liveness = r->rLiveness >> (oldpos - 1);
1205
1206     if (liveness == 0) {
1207         /* Restore MStack and return */
1208         SET_MARKED_PTRS(MStack,TSO_PTRS,0L);
1209         DEBUG_PRLAST("TSO ", oldpos);
1210         Mark = MStack;
1211         MStack = mstack;
1212         JUMP_MARK_RETURN;
1213     }
1214
1215     /* More to do in this TSO */
1216
1217     /* Shift past non-ptr registers */
1218     for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) {
1219         newpos++;
1220     }
1221
1222     /* Mark the next one */
1223     SET_MARKED_PTRS(MStack,TSO_PTRS,newpos);
1224     Mark = r->rR[newpos - 2].p;
1225     r->rR[newpos - 2].p = mstack;
1226     DEBUG_PRIN("TSO ", oldpos);
1227     JUMP_MARK;
1228
1229     FUNEND;
1230 }
1231
1232 \end{code}
1233
1234 %****************************************************************************
1235 %
1236 \subsubsection[mark-stko]{Marking Stack Objects (threaded only)}
1237 %
1238 %****************************************************************************
1239
1240 First mark the A stack, then mark all updatees in the B stack.
1241
1242 \begin{code}
1243
1244 STGFUN(_PRStart_StkO)
1245 {
1246     P_ temp;
1247     I_ size;
1248     I_ cts_size;
1249
1250     FUNBEGIN;
1251
1252     /* ToDo: ASSERT(sanityChk_StkO(Mark)); ??? */
1253
1254     if (IS_MARK_BIT_SET(Mark)) {
1255         DEBUG_PR_MARKED;
1256         JUMP_MARK_RETURN;
1257     } else {
1258     INIT_MARK_NODE("STKO", 0);
1259     size = STKO_CLOSURE_SIZE(Mark);
1260     cts_size = STKO_CLOSURE_CTS_SIZE(Mark);
1261     SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1));
1262     temp = STKO_LINK(Mark);
1263     STKO_LINK(Mark) = MStack;
1264     MStack = Mark;
1265     Mark = temp;
1266     JUMP_MARK;
1267     }
1268     FUNEND;
1269 }
1270 \end{code}
1271
1272 Now the ``in'' code for \tr{STKO} closures.  First the A stack is flushed,
1273 then we chain down the update frames in the B stack, marking the update
1274 nodes.  When all have been marked we pop the stack and return.
1275
1276 \begin{code}
1277 STGFUN(_PRIn_StkO)
1278 {
1279     BitWord oldpos, newpos;
1280     P_ mstack;
1281     I_ size;
1282
1283     FUNBEGIN;
1284
1285     size = STKO_CLOSURE_SIZE(MStack);
1286     GET_GEN_MARKED_PTRS(oldpos, MStack, size);
1287
1288     if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) {
1289         /* Update the link, saving the old mstack */
1290         mstack = STKO_LINK(MStack);
1291         STKO_LINK(MStack) = Mark;
1292     } else {
1293         /* Update the pointer, saving the old mstack */
1294         mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos);
1295         STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark;
1296     }
1297
1298     /* Calculate the next position to mark */
1299     if (oldpos > STKO_SpA_OFFSET(MStack)) {
1300         /* Just walk backwards down the A stack */
1301         newpos = oldpos - 1;
1302         SET_GEN_MARKED_PTRS(MStack,size,newpos);
1303         Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos);
1304         STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack;
1305         DEBUG_PRIN("STKA", oldpos);
1306         JUMP_MARK;
1307     } else if (oldpos <= STKO_SuB_OFFSET(MStack)) {
1308         /* We're looking at an updatee in the B stack; find the next SuB up the chain */
1309         P_ subptr;
1310
1311         subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE)));
1312         newpos = STKO_CLOSURE_OFFSET(MStack,subptr);
1313     } else {
1314         /* Just fell off the end of the A stack; grab the first SuB */
1315         newpos = STKO_SuB_OFFSET(MStack);
1316     }
1317
1318     if (newpos == 0) {  /* Grrr...  newpos is 1-based */
1319         /* Restore MStack and return */
1320         SET_GEN_MARKED_PTRS(MStack,size,0L);
1321         DEBUG_PRLAST("STKO", oldpos);
1322         Mark = MStack;
1323         MStack = mstack;
1324         JUMP_MARK_RETURN;
1325     }
1326
1327     /* newpos is actually the SuB; we want the corresponding updatee */
1328     SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE));
1329     Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE));
1330     STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack;
1331     DEBUG_PRIN("STKB", oldpos);
1332     JUMP_MARK;
1333
1334     FUNEND;
1335 }
1336 #endif  /* CONCURRENT */
1337 \end{code}
1338
1339 %****************************************************************************
1340 %
1341 \subsubsection[mark-caf]{Marking CAFs}
1342 %
1343 %****************************************************************************
1344
1345 A CAF is shorted out as if it were an indirection.
1346 The CAF reference is explicitly updated by the garbage collector.
1347
1348 \begin{code}
1349 STGFUN(_PRStart_Caf)
1350 {
1351     FUNBEGIN;
1352     DEBUG_PR_CAF;
1353     GC_SHORT_CAF(); /* ticky */
1354
1355     Mark = (P_) IND_CLOSURE_PTR(Mark);
1356     JUMP_MARK;
1357     FUNEND;
1358 }
1359 \end{code}
1360
1361 %****************************************************************************
1362 %
1363 \subsection[mark-root]{Root Marking Code}
1364 %
1365 %****************************************************************************
1366
1367 Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file.
1368
1369 These are routines placed in closures at the bottom of the marking stack
1370
1371 \begin{code}
1372 STGFUN(_Dummy_PRReturn_entry)
1373 {
1374     FUNBEGIN;
1375     fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
1376     abort();
1377     FUNEND;
1378 }
1379
1380 /* various ways to call _Dummy_PRReturn_entry: */
1381
1382 INTFUN(_PRMarking_MarkNextRoot_entry)   { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1383 #ifdef CONCURRENT
1384 INTFUN(_PRMarking_MarkNextSpark_entry)  { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1385 #endif
1386 #ifdef PAR
1387 INTFUN(_PRMarking_MarkNextGA_entry)     { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1388 #endif
1389 #  if 1 /* !defined(CONCURRENT) */ /* HWL */
1390 INTFUN(_PRMarking_MarkNextAStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1391 INTFUN(_PRMarking_MarkNextBStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1392 #  endif
1393 INTFUN(_PRMarking_MarkNextCAF_entry)    { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1394
1395 #if defined(GRAN)
1396 INTFUN(_PRMarking_MarkNextEvent_entry)  { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1397 INTFUN(_PRMarking_MarkNextClosureInFetchBuffer_entry)   { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1398 #endif
1399
1400 /* end of various ways to call _Dummy_PRReturn_entry */
1401
1402 EXTFUN(_PRMarking_MarkNextRoot);
1403 EXTFUN(_PRMarking_MarkNextCAF);
1404
1405 #ifdef CONCURRENT
1406 EXTFUN(_PRMarking_MarkNextSpark);
1407 #endif
1408
1409 #ifdef PAR
1410 EXTFUN(_PRMarking_MarkNextGA);
1411 #else
1412 #  if 1 /* !defined(CONCURRENT) */  /* HWL */
1413 EXTFUN(_PRMarking_MarkNextAStack);
1414 EXTFUN(_PRMarking_MarkNextBStack);
1415 #  endif
1416 #endif /* not parallel */
1417
1418 CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
1419     /* just one, shared */
1420
1421 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
1422                        _PRMarking_MarkNextRoot_info,
1423                        _PRMarking_MarkNextRoot,
1424                        _PRMarking_MarkNextRoot_entry);
1425
1426 #ifdef CONCURRENT
1427 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
1428                        _PRMarking_MarkNextSpark_info,
1429                        _PRMarking_MarkNextSpark,
1430                        _PRMarking_MarkNextSpark_entry);
1431 #endif
1432
1433 #if defined(GRAN)
1434 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextEvent_closure,
1435                        _PRMarking_MarkNextEvent_info,
1436                        _PRMarking_MarkNextEvent,
1437                        _PRMarking_MarkNextEvent_entry);
1438 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextClosureInFetchBuffer_closure,
1439                        _PRMarking_MarkNextClosureInFetchBuffer_info,
1440                        _PRMarking_MarkNextClosureInFetchBuffer,
1441                        _PRMarking_MarkNextClosureInFetchBuffer_entry);
1442 #endif
1443
1444 #ifdef PAR
1445 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
1446                        _PRMarking_MarkNextGA_info,
1447                        _PRMarking_MarkNextGA,
1448                        _PRMarking_MarkNextGA_entry);
1449 #else
1450 #  if 1 /* !defined(CONCURRENT) */ /* HWL */
1451 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
1452                        _PRMarking_MarkNextAStack_info,
1453                        _PRMarking_MarkNextAStack,
1454                        _PRMarking_MarkNextAStack_entry);
1455
1456 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
1457                        _PRMarking_MarkNextBStack_info,
1458                        _PRMarking_MarkNextBStack,
1459                        _PRMarking_MarkNextBStack_entry);
1460 #  endif
1461 #endif /* PAR */
1462
1463 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
1464                        _PRMarking_MarkNextCAF_info,
1465                        _PRMarking_MarkNextCAF,
1466                        _PRMarking_MarkNextCAF_entry);
1467
1468 extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */
1469
1470 STGFUN(_PRMarking_MarkNextRoot)
1471 {
1472     FUNBEGIN;
1473     /* Update root -- may have short circuited Ind */
1474     *MRoot = (W_) Mark;
1475
1476     /* Is the next off the end */
1477     if (++MRoot >= sm_roots_end)
1478         RESUME_(miniInterpretEnd);
1479
1480     Mark = (P_) *MRoot;
1481     JUMP_MARK;
1482     FUNEND;
1483 }
1484
1485 #if defined(CONCURRENT)
1486 # if !defined(GRAN)
1487 extern P_ sm_roots_end; /* PendingSparksTl[pool] */
1488
1489 STGFUN(_PRMarking_MarkNextSpark)
1490 {
1491     FUNBEGIN;
1492     /* Update root -- may have short circuited Ind */
1493     *MRoot = (W_) Mark;
1494
1495     /* Is the next off the end */
1496     if (++MRoot >= sm_roots_end)
1497         RESUME_(miniInterpretEnd);
1498
1499     Mark = (P_) *MRoot;
1500     JUMP_MARK;
1501     FUNEND;
1502 }
1503 #else  /* GRAN */
1504 STGFUN(_PRMarking_MarkNextSpark)
1505 {
1506     /* This is more similar to MarkNextGA than to the MarkNextSpark in
1507        concurrent-but-not-gran land
1508        NB: MRoot is a spark (with an embedded pointer to a closure) */
1509     FUNBEGIN;
1510     /* Update root -- may have short circuited Ind */
1511     SPARK_NODE( ((sparkq) MRoot) ) = Mark;
1512     MRoot = (P_) SPARK_NEXT( ((sparkq) MRoot) );
1513
1514     /* Is the next off the end */
1515     if (MRoot == NULL)
1516         RESUME_(miniInterpretEnd);
1517
1518     Mark = (P_) SPARK_NODE( ((sparkq) MRoot) );
1519     JUMP_MARK;
1520     FUNEND;
1521 }
1522 #endif /* GRAN */
1523 #endif /* CONCURRENT */
1524 \end{code}
1525
1526 Note: Events are GranSim-only.
1527 Marking events is similar to marking GALA entries in parallel-land.
1528 The major difference is that depending on the type of the event we have
1529 to mark different field of the event (possibly several fields).
1530 Even worse, in the case of bulk fetching
1531 (@RTSflags.GranFlags.DoGUMMFetching@) we find a buffer of pointers to
1532 closures we have to mark (similar to sparks in concurrent-but-not-gransim
1533 setup).
1534
1535 \begin{code}
1536 #if defined(GRAN)
1537 STGFUN(_PRMarking_MarkNextEvent)
1538 {
1539   rtsBool found = rtsFalse;
1540
1541   FUNBEGIN;
1542
1543   /* First update the right component of the old event */
1544   switch (EVENT_TYPE( ((eventq) MRoot) )) {
1545     case CONTINUETHREAD:
1546     case STARTTHREAD:
1547     case RESUMETHREAD:
1548     case MOVETHREAD:
1549        EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1550        break;
1551     case MOVESPARK:
1552        SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) )) = (P_) Mark;
1553        break;
1554     case FETCHNODE:
1555        switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
1556         case 0:
1557           EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1558           EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
1559           Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
1560           JUMP_MARK;
1561           break;
1562         case 1:
1563           EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
1564           EVENT_GC_INFO( ((eventq) MRoot) ) = 0;             /* reset flag */
1565           break;
1566         default:
1567           fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
1568                           ((eventq) MRoot) );
1569           EXIT(EXIT_FAILURE);
1570        }
1571        break;
1572     case FETCHREPLY:
1573        switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
1574         case 0:
1575           EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1576           EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
1577           /* In the case of packet fetching, EVENT_NODE(event) points to */
1578           /* the packet (currently, malloced). The packet is just a list of */
1579           /* closure addresses, with the length of the list at index 1 (the */
1580           /* structure of the packet is defined in Pack.lc). */
1581           if ( RTSflags.GranFlags.DoGUMMFetching ) {
1582             P_ buffer = (P_) EVENT_NODE( ((eventq) MRoot) );
1583             int size = (int) buffer[PACK_SIZE_LOCN];
1584
1585             /* was: for (i = PACK_HDR_SIZE; i <= size-1; i++) ... */
1586             sm_roots_end = buffer + PACK_HDR_SIZE + size;
1587             MRoot = (P_) buffer + PACK_HDR_SIZE;
1588             ret_MRoot = MRoot;
1589             Mark = (P_) *MRoot;
1590             ret_Mark = Mark;
1591             MStack = (P_) _PRMarking_MarkNextClosureInFetchBuffer_closure;
1592             JUMP_MARK;
1593           } else {
1594             Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
1595             JUMP_MARK;
1596           }
1597           break;
1598         case 1:
1599           if ( RTSflags.GranFlags.DoGUMMFetching ) {
1600             /* no update necessary; fetch buffers are malloced */
1601           } else {
1602             EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
1603           }
1604           EVENT_GC_INFO( ((eventq) MRoot) ) = 0;             /* reset flag */
1605           break;
1606         default:
1607           fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHREPLY event @ %#x\n",
1608                           ((eventq) MRoot) );
1609           EXIT(EXIT_FAILURE);
1610        }
1611        break;
1612
1613     case GLOBALBLOCK:
1614        switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
1615         case 0:
1616           EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1617           EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
1618           Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
1619           JUMP_MARK;
1620           break;
1621           break;
1622         case 1:
1623           EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
1624           EVENT_GC_INFO( ((eventq) MRoot) ) = 0;             /* reset flag */
1625           break;
1626         default:
1627           fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of GLOBALBLOCK event @ %#x\n",
1628                           ((eventq) MRoot) );
1629           EXIT(EXIT_FAILURE);
1630        }
1631        break;
1632     case UNBLOCKTHREAD:
1633        EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
1634        break;
1635     case FINDWORK:
1636        break;
1637     default:
1638        fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
1639                        ((eventq) MRoot) );
1640        EXIT(EXIT_FAILURE);
1641   }
1642
1643   do {
1644       MRoot = (P_) EVENT_NEXT( ((eventq) MRoot) );
1645       /* Is the next off the end */
1646       if (MRoot == NULL)
1647             RESUME_(miniInterpretEnd);
1648
1649       switch (EVENT_TYPE( ((eventq) MRoot) )) {
1650         case CONTINUETHREAD:
1651         case STARTTHREAD:
1652         case RESUMETHREAD:
1653         case MOVETHREAD:
1654            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1655            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1656            found = rtsTrue;
1657            break;
1658         case MOVESPARK:
1659            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1660            Mark = (P_) SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) ));
1661            found = rtsTrue;
1662            break;
1663         case FETCHNODE:
1664            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1665            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1666            found = rtsTrue;
1667            break;
1668         case FETCHREPLY:
1669            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1670            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1671            found = rtsTrue;
1672            break;
1673          case GLOBALBLOCK:
1674            EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
1675            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1676            found = rtsTrue;
1677            break;
1678         case UNBLOCKTHREAD:
1679            Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
1680            found = rtsTrue;
1681            break;
1682         case FINDWORK:
1683            found = rtsFalse;
1684            break;
1685         default:
1686            fprintf(stderr,"Unknown event type %d (event @ %#x) in SMmarking_NextEvent\n",
1687                           EVENT_TYPE( ((eventq) MRoot) ), MRoot);
1688            EXIT(EXIT_FAILURE);
1689         }
1690     } while (!found && MRoot!=NULL);
1691
1692     JUMP_MARK;
1693
1694     FUNEND;
1695 }
1696
1697 STGFUN(_PRMarking_MarkNextClosureInFetchBuffer)
1698 {
1699     FUNBEGIN;
1700     /* Update root -- may have short circuited Ind */
1701     *MRoot = Mark;
1702
1703     /* Is the next off the end */
1704     if (++MRoot >= sm_roots_end) {
1705       /* We know that marking a fetch buffer is only called from within
1706          marking a FETCHREPLY event; we have saved the important
1707          registers before that  */
1708       MRoot = ret_MRoot;
1709       Mark = ret_Mark;
1710       MStack = (P_) _PRMarking_MarkNextEvent_closure;
1711       JUMP_MARK;
1712     }
1713
1714     Mark = *MRoot;
1715     JUMP_MARK;
1716     FUNEND;
1717 }
1718 #endif
1719
1720 #ifdef PAR
1721 STGFUN(_PRMarking_MarkNextGA)
1722 {
1723     FUNBEGIN;
1724     /* Update root -- may have short circuited Ind */
1725     ((GALA *)MRoot)->la = Mark;
1726
1727     do {
1728         MRoot = (P_) ((GALA *) MRoot)->next;
1729     } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT);
1730
1731     /* Is the next off the end */
1732     if (MRoot == NULL)
1733         RESUME_(miniInterpretEnd);
1734
1735     Mark = ((GALA *)MRoot)->la;
1736     JUMP_MARK;
1737     FUNEND;
1738 }
1739
1740 #else
1741 STGFUN(_PRMarking_MarkNextAStack)
1742 {
1743     FUNBEGIN;
1744     /* Update root -- may have short circuited Ind */
1745     *MRoot = (W_) Mark;
1746
1747     /* Is the next off the end */
1748     if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0)
1749         RESUME_(miniInterpretEnd);
1750
1751     Mark = (P_) *MRoot;
1752     JUMP_MARK;
1753     FUNEND;
1754 }
1755
1756
1757 STGFUN(_PRMarking_MarkNextBStack)
1758 {
1759     FUNBEGIN;
1760     /* Update root -- may have short circuited Ind */
1761     PUSH_UPDATEE(MRoot, Mark);
1762
1763     MRoot = GRAB_SuB(MRoot);
1764
1765     /* Is the next off the end */
1766     if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0)
1767         RESUME_(miniInterpretEnd);
1768
1769     Mark = GRAB_UPDATEE(MRoot);
1770     JUMP_MARK;
1771     FUNEND;
1772 }
1773 #endif  /* PAR */
1774 \end{code}
1775
1776 Mark the next CAF in the CAF list.
1777
1778 \begin{code}
1779 STGFUN(_PRMarking_MarkNextCAF)
1780 {
1781     FUNBEGIN;
1782
1783     /* Update root -- may have short circuited Ind */
1784     IND_CLOSURE_PTR(MRoot) = (W_) Mark;
1785
1786     MRoot = (P_) IND_CLOSURE_LINK(MRoot);
1787
1788     /* Is the next CAF the end of the list */
1789     if (MRoot == 0)
1790         RESUME_(miniInterpretEnd);
1791
1792     GC_SHORT_CAF(); /* ticky (ToDo: wrong?) */
1793
1794     Mark = (P_) IND_CLOSURE_PTR(MRoot);
1795     JUMP_MARK;
1796     FUNEND;
1797 }
1798 \end{code}
1799
1800 Multi-slurp protection.
1801
1802 \begin{code}
1803 #endif /* _INFO_MARKING */
1804 \end{code}