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 \end{code}
 198
 199 Define appropriate variables as potential register variables.
 200 Assume GC code saves and restores any global registers used.
 201
 202 \begin{code}
 203 RegisterTable MarkRegTable;
 204 \end{code}
 205
 206 @_startMarkWorld@ restores registers if necessary, then marks the
 207 root pointed to by @Mark@.
 208
 209 \begin{code}
 210 STGFUN(_startMarkWorld)
 211 {
 212     FUNBEGIN;
 213 #if defined(__STG_GCC_REGS__) && defined(__GNUC__)
 214     /* If using registers load from _SAVE (see SMmarking.lc) */
 215
 216     /* I deeply suspect this should be RESTORE_REGS(...) [WDP 95/02] */
 217 #ifdef REG_MarkBase
 218     MarkBaseReg = &MarkRegTable;
 219 #endif
 220     Mark = SAVE_Mark;
 221     MRoot = SAVE_MRoot;
 222     MStack = SAVE_MStack;
 223     BitArray = SAVE_BitArray;
 224     HeapBase = SAVE_HeapBase;
 225     HeapLim  = SAVE_HeapLim;
 226 #endif
 227
 228     JUMP_MARK;
 229     FUNEND;
 230 }
 231 \end{code}
 232
 233 This is the pointer reversal start code for \tr{SPEC} closures with 0
 234 pointers.
 235
 236 \begin{code}
 237 STGFUN(_PRStart_0)
 238 {
 239     FUNBEGIN;
 240     if (IS_MARK_BIT_SET(Mark)) {
 241         DEBUG_PR_MARKED;
 242     } else
 243     INIT_MARK_NODE("SPEC",0);
 244
 245     JUMP_MARK_RETURN;
 246     FUNEND;
 247 }
 248 \end{code}
 249
 250
 251 This macro defines the format of the pointer reversal start code for a
 252 number of pointers \tr{ptrs}, $>$ 0.
 253
 254 \begin{code}
 255
 256 #define SPEC_PRStart_N_CODE(ptrs)               \
 257 STGFUN(CAT2(_PRStart_,ptrs))                    \
 258 {                                               \
 259     FUNBEGIN;                                   \
 260     if (IS_MARK_BIT_SET(Mark)) {                \
 261         DEBUG_PR_MARKED;                        \
 262         JUMP_MARK_RETURN;                       \
 263     } else {                                    \
 264         INIT_MARK_NODE("SPEC",ptrs);            \
 265         INIT_MSTACK(SPEC_CLOSURE_PTR);          \
 266     }                                           \
 267     FUNEND;                                     \
 268 }
 269
 270 \end{code}
 271
 272 The definitions of the start code for \tr{SPEC} closures with 1-12
 273 pointers.
 274
 275 \begin{code}
 276 SPEC_PRStart_N_CODE(1)
 277 SPEC_PRStart_N_CODE(2)
 278 SPEC_PRStart_N_CODE(3)
 279 SPEC_PRStart_N_CODE(4)
 280 SPEC_PRStart_N_CODE(5)
 281 SPEC_PRStart_N_CODE(6)
 282 SPEC_PRStart_N_CODE(7)
 283 SPEC_PRStart_N_CODE(8)
 284 SPEC_PRStart_N_CODE(9)
 285 SPEC_PRStart_N_CODE(10)
 286 SPEC_PRStart_N_CODE(11)
 287 SPEC_PRStart_N_CODE(12)
 288
 289 \end{code}
 290
 291 Start code for revertible black holes with underlying @SPEC@ types.
 292
 293 \begin{code}
 294
 295 #ifdef PAR
 296 #define SPEC_RBH_PRStart_N_CODE(ptrs)           \
 297 STGFUN(CAT2(_PRStart_RBH_,ptrs))                \
 298 {                                               \
 299     FUNBEGIN;                                   \
 300     if (IS_MARK_BIT_SET(Mark)) {                \
 301         DEBUG_PR_MARKED;                        \
 302         JUMP_MARK_RETURN;                       \
 303     } else {                                    \
 304         INIT_MARK_NODE("SRBH",ptrs-1);          \
 305     INIT_MSTACK(SPEC_RBH_CLOSURE_PTR);          \
 306     }                                           \
 307     FUNEND;                                     \
 308 }
 309
 310 SPEC_RBH_PRStart_N_CODE(2)
 311 SPEC_RBH_PRStart_N_CODE(3)
 312 SPEC_RBH_PRStart_N_CODE(4)
 313 SPEC_RBH_PRStart_N_CODE(5)
 314 SPEC_RBH_PRStart_N_CODE(6)
 315 SPEC_RBH_PRStart_N_CODE(7)
 316 SPEC_RBH_PRStart_N_CODE(8)
 317 SPEC_RBH_PRStart_N_CODE(9)
 318 SPEC_RBH_PRStart_N_CODE(10)
 319 SPEC_RBH_PRStart_N_CODE(11)
 320 SPEC_RBH_PRStart_N_CODE(12)
 321
 322 #endif
 323
 324 \end{code}
 325
 326 @SPEC_PRIn_N_CODE@ has two different meanings, depending on the world
 327 in which we use it:
 328 \begin{itemize}
 329 \item
 330 In the commoned-info-table world, it
 331 defines the ``in'' code for a particular number
 332 of pointers, and subsumes the functionality of @SPEC_PRInLast_N_NODE@ below.
 333 \item
 334 Otherwise, it defines the ``in'' code for a particular pointer in a
 335 \tr{SPEC} closure.
 336 \end{itemize}
 337
 338 \begin{code}
 339
 340 #define SPEC_PRIn_N_CODE(ptrs)                          \
 341 STGFUN(CAT2(_PRIn_,ptrs))                               \
 342 {                                               \
 343     BitWord mbw;                                        \
 344     FUNBEGIN;                                   \
 345     GET_MARKED_PTRS(mbw,MStack,ptrs);                   \
 346     if (++mbw < ptrs) {                                 \
 347         SET_MARKED_PTRS(MStack,ptrs,mbw);               \
 348         CONTINUE_MARKING_NODE("SPEC",mbw);              \
 349         MOVE_TO_NEXT_PTR(SPEC_CLOSURE_PTR,mbw);         \
 350     } else {                                            \
 351         SET_MARKED_PTRS(MStack,ptrs,0L);                \
 352         POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,ptrs);       \
 353     }                                                   \
 354     FUNEND;                                     \
 355 }
 356
 357 \end{code}
 358
 359 Now @SPEC_PRIn_N_CODE@ is used to define the individual entries for \tr{SPEC} closures
 360 with 1-12 pointers.
 361
 362 \begin{code}
 363 STGFUN(_PRIn_0)
 364 {
 365     FUNBEGIN;
 366     fprintf(stderr,"Called _PRIn_0\nShould never occur!\n");
 367     abort();
 368     FUNEND;
 369 }
 370 STGFUN(_PRIn_1)
 371 {
 372     FUNBEGIN;
 373     POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,1);
 374     FUNEND;
 375 }
 376 SPEC_PRIn_N_CODE(2)
 377 SPEC_PRIn_N_CODE(3)
 378 SPEC_PRIn_N_CODE(4)
 379 SPEC_PRIn_N_CODE(5)
 380 SPEC_PRIn_N_CODE(6)
 381 SPEC_PRIn_N_CODE(7)
 382 SPEC_PRIn_N_CODE(8)
 383 SPEC_PRIn_N_CODE(9)
 384 SPEC_PRIn_N_CODE(10)
 385 SPEC_PRIn_N_CODE(11)
 386 SPEC_PRIn_N_CODE(12)
 387 \end{code}
 388
 389 In code for revertible black holes with underlying @SPEC@ types.
 390
 391 \begin{code}
 392 #ifdef PAR
 393 #define SPEC_RBH_PRIn_N_CODE(ptrs)                      \
 394 STGFUN(CAT2(_PRIn_RBH_,ptrs))                           \
 395 {                                                       \
 396     BitWord mbw;                                        \
 397     FUNBEGIN;                                           \
 398     GET_MARKED_PTRS(mbw,MStack,ptrs-1);                 \
 399     if (++mbw < ptrs-1) {                               \
 400         SET_MARKED_PTRS(MStack,ptrs-1,mbw);             \
 401         CONTINUE_MARKING_NODE("SRBH",mbw);              \
 402         MOVE_TO_NEXT_PTR(SPEC_RBH_CLOSURE_PTR,mbw);     \
 403     } else {                                            \
 404         SET_MARKED_PTRS(MStack,ptrs-1,0L);              \
 405         POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,ptrs-1); \
 406     }                                                   \
 407     FUNEND;                                             \
 408 }
 409
 410 STGFUN(_PRIn_RBH_2)
 411 {
 412     FUNBEGIN;
 413     POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,1);
 414     FUNEND;
 415 }
 416
 417 SPEC_RBH_PRIn_N_CODE(3)
 418 SPEC_RBH_PRIn_N_CODE(4)
 419 SPEC_RBH_PRIn_N_CODE(5)
 420 SPEC_RBH_PRIn_N_CODE(6)
 421 SPEC_RBH_PRIn_N_CODE(7)
 422 SPEC_RBH_PRIn_N_CODE(8)
 423 SPEC_RBH_PRIn_N_CODE(9)
 424 SPEC_RBH_PRIn_N_CODE(10)
 425 SPEC_RBH_PRIn_N_CODE(11)
 426 SPEC_RBH_PRIn_N_CODE(12)
 427 #endif
 428
 429 \end{code}
 430
 431 Malloc Ptrs are in the sequential world only.
 432
 433 \begin{code}
 434
 435 #ifndef PAR
 436
 437 STGFUN(_PRStart_MallocPtr)
 438 {
 439     FUNBEGIN;
 440     if (IS_MARK_BIT_SET(Mark)) {
 441         DEBUG_PR_MARKED;
 442     } else
 443     INIT_MARK_NODE("MallocPtr ",0);
 444     JUMP_MARK_RETURN;
 445     FUNEND;
 446 }
 447 #endif /* !PAR */
 448 \end{code}
 449
 450 This defines the start code for generic (\tr{GEN}) closures.
 451
 452 \begin{code}
 453 STGFUN(_PRStart_N)
 454 {
 455     W_ ptrs;
 456
 457     FUNBEGIN;
 458
 459     if (IS_MARK_BIT_SET(Mark)) {
 460         DEBUG_PR_MARKED;
 461         JUMP_MARK_RETURN;
 462     }
 463     ptrs = GEN_CLOSURE_NoPTRS(Mark);
 464     INIT_MARK_NODE("GEN ",ptrs);
 465     if (ptrs == 0) {
 466         JUMP_MARK_RETURN;
 467     } else {
 468         INIT_MSTACK(GEN_CLOSURE_PTR);
 469     }
 470     FUNEND;
 471 }
 472 \end{code}
 473
 474 Now the ``in'' code for \tr{GEN} closures.
 475
 476 \begin{code}
 477 STGFUN(_PRIn_I)
 478 {
 479     W_ ptrs;
 480     BitWord pos;
 481
 482     FUNBEGIN;
 483
 484     ptrs = GEN_CLOSURE_NoPTRS(MStack);
 485     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 486
 487     if (++pos < ptrs) {
 488         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 489         CONTINUE_MARKING_NODE("GEN",pos);
 490         MOVE_TO_NEXT_PTR(GEN_CLOSURE_PTR,pos);
 491     } else {
 492         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 493         POP_MSTACK("GEN ",GEN_CLOSURE_PTR,ptrs);
 494     }
 495     FUNEND;
 496 }
 497 \end{code}
 498
 499 And the start/in code for a revertible black hole with an underlying @GEN@ closure.
 500
 501 \begin{code}
 502
 503 #ifdef PAR
 504
 505 STGFUN(_PRStart_RBH_N)
 506 {
 507     W_ ptrs;
 508
 509     FUNBEGIN;
 510
 511     if (IS_MARK_BIT_SET(Mark)) {
 512         DEBUG_PR_MARKED;
 513         JUMP_MARK_RETURN;
 514     }
 515
 516     /*
 517      * Get pointer count from original closure and adjust for one pointer
 518      * in the first two words of the RBH.
 519      */
 520     ptrs = GEN_RBH_CLOSURE_NoPTRS(Mark);
 521     if (ptrs < 2)
 522         ptrs = 1;
 523     else
 524         ptrs--;
 525
 526     INIT_MARK_NODE("GRBH", ptrs);
 527     INIT_MSTACK(GEN_RBH_CLOSURE_PTR);
 528     FUNEND;
 529 }
 530
 531 STGFUN(_PRIn_RBH_I)
 532 {
 533     W_ ptrs;
 534     BitWord pos;
 535
 536     FUNBEGIN;
 537
 538     /*
 539      * Get pointer count from original closure and adjust for one pointer
 540      * in the first two words of the RBH.
 541      */
 542     ptrs = GEN_RBH_CLOSURE_NoPTRS(MStack);
 543     if (ptrs < 2)
 544         ptrs = 1;
 545     else
 546         ptrs--;
 547
 548     GET_GEN_MARKED_PTRS(pos, MStack, ptrs);
 549
 550     if (++pos < ptrs) {
 551         SET_GEN_MARKED_PTRS(MStack, ptrs, pos);
 552         CONTINUE_MARKING_NODE("GRBH", pos);
 553         MOVE_TO_NEXT_PTR(GEN_RBH_CLOSURE_PTR, pos);
 554     } else {
 555         SET_GEN_MARKED_PTRS(MStack, ptrs, 0L);
 556         POP_MSTACK("GRBH", GEN_RBH_CLOSURE_PTR, ptrs);
 557     }
 558     FUNEND;
 559 }
 560
 561 #endif
 562
 563 \end{code}
 564
 565 Start code for dynamic (\tr{DYN}) closures.  There is no \tr{DYN}
 566 closure with 0 pointers -- \tr{DATA} is used instead.
 567
 568 \begin{code}
 569 STGFUN(_PRStart_Dyn)
 570 {
 571     FUNBEGIN;
 572     if (IS_MARK_BIT_SET(Mark)) {
 573         DEBUG_PR_MARKED;
 574         JUMP_MARK_RETURN;
 575     } else {
 576     INIT_MARK_NODE("DYN ", DYN_CLOSURE_NoPTRS(Mark));
 577         INIT_MSTACK(DYN_CLOSURE_PTR);
 578     }
 579     FUNEND;
 580 }
 581 \end{code}
 582
 583 and the corresponding ``in'' code.
 584
 585 \begin{code}
 586 STGFUN(_PRIn_I_Dyn)
 587 {
 588     W_ ptrs;
 589     BitWord pos;
 590
 591     FUNBEGIN;
 592     ptrs = DYN_CLOSURE_NoPTRS(MStack);
 593     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 594
 595     if (++pos < ptrs) {
 596         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 597         CONTINUE_MARKING_NODE("DYN",pos);
 598         MOVE_TO_NEXT_PTR(DYN_CLOSURE_PTR,pos);
 599     } else {
 600         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 601         POP_MSTACK("DYN ",DYN_CLOSURE_PTR,ptrs);
 602       }
 603     FUNEND;
 604 }
 605 \end{code}
 606
 607
 608 The start code for \tr{TUPLE} (all-pointer) objects.  There can be no
 609 such object without any pointers, so we don't check for this case.
 610
 611 \begin{code}
 612 STGFUN(_PRStart_Tuple)
 613 {
 614     FUNBEGIN;
 615     if (IS_MARK_BIT_SET(Mark)) {
 616         DEBUG_PR_MARKED;
 617         JUMP_MARK_RETURN;
 618     } else {
 619     INIT_MARK_NODE("TUPL", TUPLE_CLOSURE_NoPTRS(Mark));
 620         INIT_MSTACK(TUPLE_CLOSURE_PTR);
 621     }
 622     FUNEND;
 623 }
 624 \end{code}
 625
 626 Now the ``in'' case.
 627
 628 \begin{code}
 629 STGFUN(_PRIn_I_Tuple)
 630 {
 631     W_ ptrs;
 632     BitWord pos;
 633
 634     FUNBEGIN;
 635     ptrs = TUPLE_CLOSURE_NoPTRS(MStack);
 636     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 637
 638     if (++pos < ptrs) {
 639         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 640         CONTINUE_MARKING_NODE("TUPL",pos);
 641         MOVE_TO_NEXT_PTR(TUPLE_CLOSURE_PTR,pos);
 642     } else {
 643         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 644         POP_MSTACK("TUPL",TUPLE_CLOSURE_PTR,ptrs);
 645       }
 646     FUNEND;
 647 }
 648 \end{code}
 649
 650
 651 \begin{code}
 652 /*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
 653 /*             Only if special GC treatment required           */
 654
 655 #ifdef GC_MUT_REQUIRED
 656
 657 STGFUN(_PRStart_MuTuple)
 658 {
 659     FUNBEGIN;
 660     if (IS_MARK_BIT_SET(Mark)) {
 661         DEBUG_PR_MARKED;
 662         JUMP_MARK_RETURN;
 663     } else {
 664     INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark));
 665         INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
 666     }
 667     FUNEND;
 668 }
 669
 670 STGFUN(_PRIn_I_MuTuple)
 671 {
 672     W_ ptrs;
 673     BitWord pos;
 674
 675     FUNBEGIN;
 676     ptrs = MUTUPLE_CLOSURE_NoPTRS(MStack);
 677     GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
 678
 679     if (++pos < ptrs) {
 680         SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
 681         CONTINUE_MARKING_NODE("MUT",pos);
 682         MOVE_TO_NEXT_PTR(MUTUPLE_CLOSURE_PTR,pos);
 683     } else {
 684         SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
 685         POP_MSTACK("MUT ",MUTUPLE_CLOSURE_PTR,ptrs);
 686       }
 687     FUNEND;
 688 }
 689
 690 #endif /* GCap || GCgn */
 691 \end{code}
 692
 693 There are no pointers in a \tr{DATA} closure, so just mark the
 694 closure and return.
 695
 696 \begin{code}
 697 STGFUN(_PRStart_Data)
 698 {
 699     FUNBEGIN;
 700     if (IS_MARK_BIT_SET(Mark)) {
 701         DEBUG_PR_MARKED;
 702     } else
 703     INIT_MARK_NODE("DATA", 0);
 704     JUMP_MARK_RETURN;
 705     FUNEND;
 706 }
 707 \end{code}
 708
 709 %****************************************************************************
 710 %
 711 \subsubsection[mark-specials]{Special cases}
 712 %
 713 %****************************************************************************
 714
 715 Black hole closures simply mark themselves and return.
 716
 717 \begin{code}
 718 STGFUN(_PRStart_BH)
 719 {
 720     FUNBEGIN;
 721     if (IS_MARK_BIT_SET(Mark)) {
 722         DEBUG_PR_MARKED;
 723     } else
 724     INIT_MARK_NODE("BH  ", 0);
 725     JUMP_MARK_RETURN;
 726     FUNEND;
 727 }
 728 \end{code}
 729
 730 Marking a Static Closure -- Just return as if Marked
 731
 732 \begin{code}
 733 STGFUN(_PRStart_Static)
 734 {
 735     FUNBEGIN;
 736     DEBUG_PR_STAT;
 737     JUMP_MARK_RETURN;
 738     FUNEND;
 739 }
 740 \end{code}
 741
 742 Marking an Indirection -- Set Mark to ind addr and mark this.
 743 Updating of reference when we return will short indirection.
 744
 745 \begin{code}
 746 STGFUN(_PRStart_Ind)
 747 {
 748     FUNBEGIN;
 749     DEBUG_PR_IND;
 750     GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
 751
 752     Mark = (P_) IND_CLOSURE_PTR(Mark);
 753     JUMP_MARK;
 754     FUNEND;
 755 }
 756 \end{code}
 757
 758 ``Permanent indirection''---used in profiling.  Works basically
 759 like @_PRStart_1@ (one pointer).
 760 \begin{code}
 761 #if defined(PROFILING) || defined(TICKY_TICKY)
 762
 763 STGFUN(_PRStart_PI)
 764 {
 765     FUNBEGIN;
 766
 767     if (IS_MARK_BIT_SET(Mark)) {
 768         DEBUG_PR_MARKED;
 769         JUMP_MARK_RETURN;
 770     } else {
 771         INIT_MARK_NODE("PI  ",1);
 772         /* the "1" above is dodgy (i.e. wrong), but it is never
 773            used except in debugging info.  ToDo??? WDP 95/07
 774         */
 775         INIT_MSTACK(PERM_IND_CLOSURE_PTR);
 776     }
 777     FUNEND;
 778 }
 779
 780 STGFUN(_PRIn_PI)
 781 {
 782     FUNBEGIN;
 783     POP_MSTACK("PI  ",PERM_IND_CLOSURE_PTR,1);
 784     /* the "1" above is dodgy (i.e. wrong), but it is never
 785        used except in debugging info.  ToDo??? WDP 95/07
 786     */
 787     FUNEND;
 788 }
 789
 790 #endif /* PROFILING or TICKY */
 791 \end{code}
 792
 793 Marking a ``selector closure'': This is a size-2 SPEC thunk that
 794 selects word $n$; if the thunk's pointee is evaluated, then we short
 795 out the selection, {\em just like an indirection}.  If it is still
 796 unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}.
 797
 798 {\em Should we select ``on the way down'' (in \tr{_PRStart_Selector})
 799 or ``on the way back up'' (\tr{_PRIn_Selector})?}  Answer: probably on
 800 the way down.  Downside: we are flummoxed by indirections, so we'll
 801 have to wait until the {\em next} major GC to do the selections (after
 802 the indirections are shorted out in this GC).  But the downside of
 803 doing selections on the way back up is that we are then in a world of
 804 reversed pointers, and selecting a reversed pointer---we've see this
 805 on selectors for very recursive structures---is a total disaster.
 806 (WDP 94/12)
 807
 808 \begin{code}
 809 #if defined(DEBUG)
 810 #define IF_GC_DEBUG(x) x
 811 #else
 812 #define IF_GC_DEBUG(x) /*nothing*/
 813 #endif
 814
 815 #if !defined(CONCURRENT)
 816 # define NOT_BLACKHOLING (! RTSflags.GcFlags.lazyBlackHoling)
 817 #else
 818 # define NOT_BLACKHOLING 0
 819 #endif
 820
 821 /* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
 822
 823 #define MARK_SELECTOR(n)                                                \
 824 STGFUN(CAT2(_PRStartSelector_,n))                                       \
 825 {                                                                       \
 826     P_ maybe_con;                                                       \
 827     FUNBEGIN;                                                           \
 828                                                                         \
 829     /* must be a SPEC 2 1 closure */                                    \
 830     ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);                             \
 831     ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);                           \
 832     ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */            \
 833                                                                         \
 834     if (IS_MARK_BIT_SET(Mark)) { /* already marked */                   \
 835         DEBUG_PR_MARKED;                                                \
 836         JUMP_MARK_RETURN;                                               \
 837     }                                                                   \
 838                                                                         \
 839     maybe_con = (P_) *(Mark + _FHS);                                    \
 840                                                                         \
 841     IF_GC_DEBUG(                                                        \
 842     if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING)  {                                                \
 843         fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, info 0x%lx", \
 844                 (n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)),   \
 845                 INFO_NoPTRS(INFO_PTR(Mark)),                            \
 846                 maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/       \
 847                 INFO_PTR(maybe_con));                                   \
 848         fprintf(stderr, ", tag %ld, size %ld, ptrs %ld",                \
 849             INFO_TAG(INFO_PTR(maybe_con)),                              \
 850             INFO_SIZE(INFO_PTR(maybe_con)),                             \
 851             INFO_NoPTRS(INFO_PTR(maybe_con)));                          \
 852         if (INFO_TAG(INFO_PTR(maybe_con)) >=0) {                        \
 853             fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]);         \
 854         }                                                               \
 855         fprintf(stderr, "\n");                                          \
 856     } )                                                                 \
 857                                                                         \
 858     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
 859      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */    \
 860      || INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */             \
 861      || NOT_BLACKHOLING  /* see "price of laziness" paper */            \
 862      || (! RTSflags.GcFlags.doSelectorsAtGC ))                          \
 863         /* see below for OLD test we used here (WDP 95/04) */           \
 864         /* ToDo: decide WHNFness another way? */                        \
 865         JMP_(_PRStart_1);                                               \
 866                                                                         \
 867     /* some things should be true about the pointee */                  \
 868     ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0);                         \
 869     /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
 870                                                                         \
 871     /* OK, it is evaluated: behave just like an indirection */          \
 872     GC_SEL_MAJOR(); /* ticky-ticky */                                   \
 873                                                                         \
 874     Mark = (P_) (maybe_con[_FHS + (n)]);                                \
 875     /* Mark now has the result of the selection */                      \
 876     JUMP_MARK;                                                          \
 877                                                                         \
 878     FUNEND;                                                             \
 879 }
 880
 881 #if 0
 882 /* OLD test:
 883    the IS_STATIC test was to protect the IS_MARK_BIT_SET check;
 884    but the IS_MARK_BIT_SET test was only there to avoid
 885    mangled pointers, but we cannot have mangled pointers anymore
 886    (after RTBLs came our way).
 887    SUMMARY: we toss both of the "guard" tests.
 888  */
 889     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */
 890      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */
 891      || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
 892 #endif /* 0 */
 893
 894 MARK_SELECTOR(0)
 895 MARK_SELECTOR(1)
 896 MARK_SELECTOR(2)
 897 MARK_SELECTOR(3)
 898 MARK_SELECTOR(4)
 899 MARK_SELECTOR(5)
 900 MARK_SELECTOR(6)
 901 MARK_SELECTOR(7)
 902 MARK_SELECTOR(8)
 903 MARK_SELECTOR(9)
 904 MARK_SELECTOR(10)
 905 MARK_SELECTOR(11)
 906 MARK_SELECTOR(12)
 907
 908 #undef IF_GC_DEBUG /* get rid of it */
 909 \end{code}
 910
 911 Marking a Constant Closure -- Set Mark to corresponding static
 912 closure.  Updating of reference will redirect reference to the static
 913 closure.
 914
 915 \begin{code}
 916 STGFUN(_PRStart_Const)
 917 {
 918     FUNBEGIN;
 919     DEBUG_PR_CONST;
 920
 921 #ifndef TICKY_TICKY
 922     /* normal stuff */
 923     Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 924
 925 #else /* TICKY */
 926     if (IS_MARK_BIT_SET(Mark)) {
 927         DEBUG_PR_MARKED;
 928     } else {
 929         if (!AllFlags.doUpdEntryCounts) {
 930
 931             GC_COMMON_CONST(); /* ticky */
 932
 933             Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 934
 935         } else { /* no commoning */
 936             INIT_MARK_NODE("CONST ",0);
 937         }
 938     }
 939 #endif /* TICKY */
 940
 941     JUMP_MARK_RETURN;
 942     FUNEND;
 943 }
 944 \end{code}
 945
 946 Marking a CharLike Closure -- Set Mark to corresponding static
 947 closure.  Updating of reference will redirect reference to the static
 948 closure.
 949
 950 \begin{code}
 951 STGFUN(_PRStart_CharLike)
 952 {
 953     I_ val;
 954
 955     FUNBEGIN;
 956
 957     DEBUG_PR_CHARLIKE;
 958
 959 #ifndef TICKY_TICKY
 960     /* normal stuff */
 961
 962     Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
 963
 964 #else /* TICKY */
 965
 966     if (IS_MARK_BIT_SET(Mark)) {
 967         DEBUG_PR_MARKED;
 968     } else {
 969         val = CHARLIKE_VALUE(Mark);
 970
 971         if (!AllFlags.doUpdEntryCounts) {
 972             GC_COMMON_CHARLIKE(); /* ticky */
 973
 974             INFO_PTR(Mark) = (W_) Ind_info;
 975             IND_CLOSURE_PTR(Mark) = (W_) CHARLIKE_CLOSURE(val);
 976             Mark = (P_) IND_CLOSURE_PTR(Mark);
 977
 978         } else { /* no commoning */
 979             INIT_MARK_NODE("CHAR ",0);
 980         }
 981     }
 982 #endif /* TICKY */
 983
 984     JUMP_MARK_RETURN;
 985     FUNEND;
 986 }
 987 \end{code}
 988
 989 Marking an IntLike Closure -- Set Mark to corresponding static closure
 990 if in range.  Updating of reference to this will redirect reference to
 991 the static closure.
 992
 993 \begin{code}
 994 STGFUN(_PRStart_IntLike)
 995 {
 996     I_ val;
 997
 998     FUNBEGIN;
 999     if (IS_MARK_BIT_SET(Mark)) {
1000         DEBUG_PR_MARKED;
1001     } else {
1002         val = INTLIKE_VALUE(Mark);
1003
1004         if (val >= MIN_INTLIKE
1005          && val <= MAX_INTLIKE
1006 #ifdef TICKY_TICKY
1007          && !AllFlags.doUpdEntryCounts
1008 #endif
1009            ) {
1010             DEBUG_PR_INTLIKE_TO_STATIC;
1011             GC_COMMON_INTLIKE(); /* ticky */
1012
1013             INFO_PTR(Mark) = (W_) Ind_info;
1014             IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
1015             Mark = (P_) IND_CLOSURE_PTR(Mark);
1016
1017         } else {        /* out of range of static closures */
1018             DEBUG_PR_INTLIKE_IN_HEAP;
1019 #ifdef TICKY_TICKY
1020             if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
1021 #endif
1022             INIT_MARK_NODE("INT ",0);
1023         }
1024     }
1025     JUMP_MARK_RETURN;
1026     FUNEND;
1027 }
1028 \end{code}
1029
1030 Special error routine, used for closures which should never call their
1031 ``in'' code.
1032
1033 \begin{code}
1034 STGFUN(_PRIn_Error)
1035 {
1036     FUNBEGIN;
1037     fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n");
1038     abort();
1039     FUNEND;
1040 }
1041 \end{code}
1042
1043 %****************************************************************************
1044 %
1045 \subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)}
1046 %
1047 %****************************************************************************
1048
1049 \begin{code}
1050 #ifdef PAR
1051 \end{code}
1052
1053 FetchMe's present a unique problem during global GC.  Since the IMU short-circuits
1054 indirections during its evacuation, it may return a PLC as the new global address
1055 for a @FetchMe@ node.  This has the effect of turning the @FetchMe@ into an
1056 indirection during local garbage collection.  Of course, we'd like to short-circuit
1057 this indirection immediately.
1058
1059 \begin{code}
1060 STGFUN(_PRStart_FetchMe)
1061 {
1062     FUNBEGIN;
1063     if (IS_MARK_BIT_SET(Mark)) {
1064         DEBUG_PR_MARKED;
1065     } else
1066         INIT_MARK_NODE("FME ", 0);
1067
1068     JUMP_MARK_RETURN;
1069     FUNEND;
1070 }
1071
1072 STGFUN(_PRStart_BF)
1073 {
1074     FUNBEGIN;
1075     if (IS_MARK_BIT_SET(Mark)) {
1076         DEBUG_PR_MARKED;
1077         JUMP_MARK_RETURN;
1078     } else {
1079         INIT_MARK_NODE("BF  ", BF_CLOSURE_NoPTRS(dummy));
1080         INIT_MSTACK(BF_CLOSURE_PTR);
1081     }
1082     FUNEND;
1083 }
1084
1085 STGFUN(_PRIn_BF)
1086 {
1087     BitWord mbw;
1088
1089     FUNBEGIN;
1090     GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy));
1091     if (++mbw < BF_CLOSURE_NoPTRS(dummy)) {
1092         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw);
1093         CONTINUE_MARKING_NODE("BF  ", mbw);
1094         MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw);
1095     } else {
1096         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L);
1097         POP_MSTACK("BF  ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy));
1098     }
1099     FUNEND;
1100 }
1101
1102 #endif /* PAR */
1103 \end{code}
1104
1105 %****************************************************************************
1106 %
1107 \subsubsection[mark-tso]{Marking Thread State Objects (threaded only)}
1108 %
1109 %****************************************************************************
1110
1111 First mark the link, then mark all live registers (StkO plus the VanillaRegs
1112 indicated by Liveness).
1113
1114 CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
1115
1116 \begin{code}
1117
1118 #ifdef CONCURRENT
1119
1120 STGFUN(_PRStart_BQ)
1121 {
1122     FUNBEGIN;
1123     if (IS_MARK_BIT_SET(Mark)) {
1124         DEBUG_PR_MARKED;
1125         JUMP_MARK_RETURN;
1126     } else {
1127     INIT_MARK_NODE("BQ  ", BQ_CLOSURE_NoPTRS(Mark));
1128         INIT_MSTACK(BQ_CLOSURE_PTR);
1129     }
1130     FUNEND;
1131 }
1132
1133 STGFUN(_PRIn_BQ)
1134 {
1135     FUNBEGIN;
1136     POP_MSTACK("BQ  ",BQ_CLOSURE_PTR,1);
1137     FUNEND;
1138 }
1139
1140 STGFUN(_PRStart_TSO)
1141 {
1142     P_ temp;
1143     FUNBEGIN;
1144     if (IS_MARK_BIT_SET(Mark)) {
1145         DEBUG_PR_MARKED;
1146         JUMP_MARK_RETURN;
1147     } else {
1148     INIT_MARK_NODE("TSO ", 0);
1149     temp = TSO_LINK(Mark);
1150     TSO_LINK(Mark) = MStack;
1151     MStack = Mark;
1152     Mark = temp;
1153     JUMP_MARK;
1154     }
1155     FUNEND;
1156 }
1157 \end{code}
1158
1159 When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to
1160 the vanilla registers r[pos-2].
1161
1162 \begin{code}
1163 STGFUN(_PRIn_TSO)
1164 {
1165     W_ liveness;
1166     BitWord oldpos, newpos;
1167     STGRegisterTable *r;
1168     P_ temp, mstack;
1169
1170     FUNBEGIN;
1171     GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS);
1172     r = TSO_INTERNAL_PTR(MStack);
1173
1174     switch(oldpos) {
1175     case 0:
1176         /* Just did the link; now do the StkO */
1177         SET_MARKED_PTRS(MStack,TSO_PTRS,1L);
1178         temp = r->rStkO;
1179         r->rStkO = TSO_LINK(MStack);
1180         TSO_LINK(MStack) = Mark;
1181         Mark = temp;
1182         DEBUG_PRIN("TSO ", 1);
1183         JUMP_MARK;
1184         break;
1185     case 1:
1186         /* Just did the StkO; just update it, saving the old mstack */
1187         mstack = r->rStkO;
1188         r->rStkO = Mark;
1189         break;
1190     default:
1191         /* update the register we just did; save the old mstack */
1192         mstack = r->rR[oldpos - 2].p;
1193         r->rR[oldpos - 2] = Mark;
1194         break;
1195     }
1196
1197     /* liveness of the remaining registers */
1198     liveness = r->rLiveness >> (oldpos - 1);
1199
1200     if (liveness == 0) {
1201         /* Restore MStack and return */
1202         SET_MARKED_PTRS(MStack,TSO_PTRS,0L);
1203         DEBUG_PRLAST("TSO ", oldpos);
1204         Mark = MStack;
1205         MStack = mstack;
1206         JUMP_MARK_RETURN;
1207     }
1208
1209     /* More to do in this TSO */
1210
1211     /* Shift past non-ptr registers */
1212     for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) {
1213         newpos++;
1214     }
1215
1216     /* Mark the next one */
1217     SET_MARKED_PTRS(MStack,TSO_PTRS,newpos);
1218     Mark = r->rR[newpos - 2].p;
1219     r->rR[newpos - 2].p = mstack;
1220     DEBUG_PRIN("TSO ", oldpos);
1221     JUMP_MARK;
1222
1223     FUNEND;
1224 }
1225
1226 \end{code}
1227
1228 %****************************************************************************
1229 %
1230 \subsubsection[mark-stko]{Marking Stack Objects (threaded only)}
1231 %
1232 %****************************************************************************
1233
1234 First mark the A stack, then mark all updatees in the B stack.
1235
1236 \begin{code}
1237
1238 STGFUN(_PRStart_StkO)
1239 {
1240     P_ temp;
1241     I_ size;
1242     I_ cts_size;
1243
1244     FUNBEGIN;
1245
1246     /* ToDo: ASSERT(sanityChk_StkO(Mark)); ??? */
1247
1248     if (IS_MARK_BIT_SET(Mark)) {
1249         DEBUG_PR_MARKED;
1250         JUMP_MARK_RETURN;
1251     } else {
1252     INIT_MARK_NODE("STKO", 0);
1253     size = STKO_CLOSURE_SIZE(Mark);
1254     cts_size = STKO_CLOSURE_CTS_SIZE(Mark);
1255     SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1));
1256     temp = STKO_LINK(Mark);
1257     STKO_LINK(Mark) = MStack;
1258     MStack = Mark;
1259     Mark = temp;
1260     JUMP_MARK;
1261     }
1262     FUNEND;
1263 }
1264 \end{code}
1265
1266 Now the ``in'' code for \tr{STKO} closures.  First the A stack is flushed,
1267 then we chain down the update frames in the B stack, marking the update
1268 nodes.  When all have been marked we pop the stack and return.
1269
1270 \begin{code}
1271 STGFUN(_PRIn_StkO)
1272 {
1273     BitWord oldpos, newpos;
1274     P_ mstack;
1275     I_ size;
1276
1277     FUNBEGIN;
1278
1279     size = STKO_CLOSURE_SIZE(MStack);
1280     GET_GEN_MARKED_PTRS(oldpos, MStack, size);
1281
1282     if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) {
1283         /* Update the link, saving the old mstack */
1284         mstack = STKO_LINK(MStack);
1285         STKO_LINK(MStack) = Mark;
1286     } else {
1287         /* Update the pointer, saving the old mstack */
1288         mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos);
1289         STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark;
1290     }
1291
1292     /* Calculate the next position to mark */
1293     if (oldpos > STKO_SpA_OFFSET(MStack)) {
1294         /* Just walk backwards down the A stack */
1295         newpos = oldpos - 1;
1296         SET_GEN_MARKED_PTRS(MStack,size,newpos);
1297         Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos);
1298         STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack;
1299         DEBUG_PRIN("STKA", oldpos);
1300         JUMP_MARK;
1301     } else if (oldpos <= STKO_SuB_OFFSET(MStack)) {
1302         /* We're looking at an updatee in the B stack; find the next SuB up the chain */
1303         P_ subptr;
1304
1305         subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE)));
1306         newpos = STKO_CLOSURE_OFFSET(MStack,subptr);
1307     } else {
1308         /* Just fell off the end of the A stack; grab the first SuB */
1309         newpos = STKO_SuB_OFFSET(MStack);
1310     }
1311
1312     if (newpos == 0) {  /* Grrr...  newpos is 1-based */
1313         /* Restore MStack and return */
1314         SET_GEN_MARKED_PTRS(MStack,size,0L);
1315         DEBUG_PRLAST("STKO", oldpos);
1316         Mark = MStack;
1317         MStack = mstack;
1318         JUMP_MARK_RETURN;
1319     }
1320
1321     /* newpos is actually the SuB; we want the corresponding updatee */
1322     SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE));
1323     Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE));
1324     STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack;
1325     DEBUG_PRIN("STKB", oldpos);
1326     JUMP_MARK;
1327
1328     FUNEND;
1329 }
1330 #endif  /* CONCURRENT */
1331 \end{code}
1332
1333 %****************************************************************************
1334 %
1335 \subsubsection[mark-caf]{Marking CAFs}
1336 %
1337 %****************************************************************************
1338
1339 A CAF is shorted out as if it were an indirection.
1340 The CAF reference is explicitly updated by the garbage collector.
1341
1342 \begin{code}
1343 STGFUN(_PRStart_Caf)
1344 {
1345     FUNBEGIN;
1346     DEBUG_PR_CAF;
1347     GC_SHORT_CAF(); /* ticky */
1348
1349     Mark = (P_) IND_CLOSURE_PTR(Mark);
1350     JUMP_MARK;
1351     FUNEND;
1352 }
1353 \end{code}
1354
1355 %****************************************************************************
1356 %
1357 \subsection[mark-root]{Root Marking Code}
1358 %
1359 %****************************************************************************
1360
1361 Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file.
1362
1363 These are routines placed in closures at the bottom of the marking stack
1364
1365 \begin{code}
1366 STGFUN(_Dummy_PRReturn_entry)
1367 {
1368     FUNBEGIN;
1369     fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
1370     abort();
1371     FUNEND;
1372 }
1373
1374 /* various ways to call _Dummy_PRReturn_entry: */
1375
1376 INTFUN(_PRMarking_MarkNextRoot_entry)   { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1377 #ifdef CONCURRENT
1378 INTFUN(_PRMarking_MarkNextSpark_entry)  { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1379 #endif
1380 #ifdef PAR
1381 INTFUN(_PRMarking_MarkNextGA_entry)     { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1382 #endif
1383 INTFUN(_PRMarking_MarkNextAStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1384 INTFUN(_PRMarking_MarkNextBStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1385 INTFUN(_PRMarking_MarkNextCAF_entry)    { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
1386
1387 /* end of various ways to call _Dummy_PRReturn_entry */
1388
1389 EXTFUN(_PRMarking_MarkNextRoot);
1390 EXTFUN(_PRMarking_MarkNextCAF);
1391
1392 #ifdef CONCURRENT
1393 EXTFUN(_PRMarking_MarkNextSpark);
1394 #endif
1395
1396 #ifdef PAR
1397 EXTFUN(_PRMarking_MarkNextGA);
1398 #else
1399 EXTFUN(_PRMarking_MarkNextAStack);
1400 EXTFUN(_PRMarking_MarkNextBStack);
1401 #endif /* not parallel */
1402
1403 CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
1404     /* just one, shared */
1405
1406 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
1407                        _PRMarking_MarkNextRoot_info,
1408                        _PRMarking_MarkNextRoot,
1409                        _PRMarking_MarkNextRoot_entry);
1410
1411 #ifdef CONCURRENT
1412 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
1413                        _PRMarking_MarkNextSpark_info,
1414                        _PRMarking_MarkNextSpark,
1415                        _PRMarking_MarkNextSpark_entry);
1416 #endif
1417
1418 #ifdef PAR
1419 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
1420                        _PRMarking_MarkNextGA_info,
1421                        _PRMarking_MarkNextGA,
1422                        _PRMarking_MarkNextGA_entry);
1423 #else
1424 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
1425                        _PRMarking_MarkNextAStack_info,
1426                        _PRMarking_MarkNextAStack,
1427                        _PRMarking_MarkNextAStack_entry);
1428
1429 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
1430                        _PRMarking_MarkNextBStack_info,
1431                        _PRMarking_MarkNextBStack,
1432                        _PRMarking_MarkNextBStack_entry);
1433
1434 #endif /* PAR */
1435
1436 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
1437                        _PRMarking_MarkNextCAF_info,
1438                        _PRMarking_MarkNextCAF,
1439                        _PRMarking_MarkNextCAF_entry);
1440
1441 extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */
1442
1443 STGFUN(_PRMarking_MarkNextRoot)
1444 {
1445     FUNBEGIN;
1446     /* Update root -- may have short circuited Ind */
1447     *MRoot = (W_) Mark;
1448
1449     /* Is the next off the end */
1450     if (++MRoot >= sm_roots_end)
1451         RESUME_(miniInterpretEnd);
1452
1453     Mark = (P_) *MRoot;
1454     JUMP_MARK;
1455     FUNEND;
1456 }
1457
1458 #ifdef CONCURRENT
1459 extern P_ sm_roots_end; /* PendingSparksTl[pool] */
1460
1461 STGFUN(_PRMarking_MarkNextSpark)
1462 {
1463     FUNBEGIN;
1464     /* Update root -- may have short circuited Ind */
1465     *MRoot = (W_) Mark;
1466
1467     /* Is the next off the end */
1468     if (++MRoot >= sm_roots_end)
1469         RESUME_(miniInterpretEnd);
1470
1471     Mark = (P_) *MRoot;
1472     JUMP_MARK;
1473     FUNEND;
1474 }
1475 #endif
1476
1477 #ifdef PAR
1478 STGFUN(_PRMarking_MarkNextGA)
1479 {
1480     FUNBEGIN;
1481     /* Update root -- may have short circuited Ind */
1482     ((GALA *)MRoot)->la = Mark;
1483
1484     do {
1485         MRoot = (P_) ((GALA *) MRoot)->next;
1486     } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT);
1487
1488     /* Is the next off the end */
1489     if (MRoot == NULL)
1490         RESUME_(miniInterpretEnd);
1491
1492     Mark = ((GALA *)MRoot)->la;
1493     JUMP_MARK;
1494     FUNEND;
1495 }
1496
1497 #else
1498
1499 STGFUN(_PRMarking_MarkNextAStack)
1500 {
1501     FUNBEGIN;
1502     /* Update root -- may have short circuited Ind */
1503     *MRoot = (W_) Mark;
1504
1505     /* Is the next off the end */
1506     if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0)
1507         RESUME_(miniInterpretEnd);
1508
1509     Mark = (P_) *MRoot;
1510     JUMP_MARK;
1511     FUNEND;
1512 }
1513
1514
1515 STGFUN(_PRMarking_MarkNextBStack)
1516 {
1517     FUNBEGIN;
1518     /* Update root -- may have short circuited Ind */
1519     PUSH_UPDATEE(MRoot, Mark);
1520
1521     MRoot = GRAB_SuB(MRoot);
1522
1523     /* Is the next off the end */
1524     if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0)
1525         RESUME_(miniInterpretEnd);
1526
1527     Mark = GRAB_UPDATEE(MRoot);
1528     JUMP_MARK;
1529     FUNEND;
1530 }
1531 #endif  /* PAR */
1532 \end{code}
1533
1534 Mark the next CAF in the CAF list.
1535
1536 \begin{code}
1537 STGFUN(_PRMarking_MarkNextCAF)
1538 {
1539     FUNBEGIN;
1540
1541     /* Update root -- may have short circuited Ind */
1542     IND_CLOSURE_PTR(MRoot) = (W_) Mark;
1543
1544     MRoot = (P_) IND_CLOSURE_LINK(MRoot);
1545
1546     /* Is the next CAF the end of the list */
1547     if (MRoot == 0)
1548         RESUME_(miniInterpretEnd);
1549
1550     GC_SHORT_CAF(); /* ticky (ToDo: wrong?) */
1551
1552     Mark = (P_) IND_CLOSURE_PTR(MRoot);
1553     JUMP_MARK;
1554     FUNEND;
1555 }
1556 \end{code}
1557
1558 Multi-slurp protection.
1559
1560 \begin{code}
1561 #endif /* _INFO_MARKING */
1562 \end{code}