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     Mark = (P_) IND_CLOSURE_PTR(Mark);
 751     JUMP_MARK;
 752     FUNEND;
 753 }
 754 \end{code}
 755
 756 ``Permanent indirection''---used in profiling.  Works basically
 757 like @_PRStart_1@ (one pointer).
 758 \begin{code}
 759 #if defined(USE_COST_CENTRES)
 760 STGFUN(_PRStart_PI)
 761 {
 762     FUNBEGIN;
 763 /* This test would be here if it really was like a PRStart_1.
 764    But maybe it is not needed because a PI cannot have two
 765    things pointing at it (so no need to mark it), because
 766    they are only created in exactly one place in UpdatePAP.
 767    ??? WDP 95/07
 768
 769     if (IS_MARK_BIT_SET(Mark)) {
 770         DEBUG_PR_MARKED;
 771         JUMP_MARK_RETURN;
 772     } else {
 773 */
 774         INIT_MARK_NODE("PI  ",1);
 775         /* the "1" above is dodgy (i.e. wrong), but it is never
 776            used except in debugging info.  ToDo??? WDP 95/07
 777         */
 778         INIT_MSTACK(PERM_IND_CLOSURE_PTR);
 779 /*  } */
 780     FUNEND;
 781 }
 782 STGFUN(_PRIn_PI)
 783 {
 784     FUNBEGIN;
 785     POP_MSTACK("PI  ",PERM_IND_CLOSURE_PTR,1);
 786     /* the "1" above is dodgy (i.e. wrong), but it is never
 787        used except in debugging info.  ToDo??? WDP 95/07
 788     */
 789     FUNEND;
 790 }
 791 #endif
 792 \end{code}
 793
 794 Marking a ``selector closure'': This is a size-2 SPEC thunk that
 795 selects word $n$; if the thunk's pointee is evaluated, then we short
 796 out the selection, {\em just like an indirection}.  If it is still
 797 unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}.
 798
 799 {\em Should we select ``on the way down'' (in \tr{_PRStart_Selector})
 800 or ``on the way back up'' (\tr{_PRIn_Selector})?}  Answer: probably on
 801 the way down.  Downside: we are flummoxed by indirections, so we'll
 802 have to wait until the {\em next} major GC to do the selections (after
 803 the indirections are sorted out in this GC).  But the downside of
 804 doing selections on the way back up is that we are then in a world of
 805 reversed pointers, and selecting a reversed pointer---we've see this
 806 on selectors for very recursive structures---is a total disaster.
 807 (WDP 94/12)
 808
 809 \begin{code}
 810 #if defined(_GC_DEBUG)
 811 #define IF_GC_DEBUG(x) x
 812 #else
 813 #define IF_GC_DEBUG(x) /*nothing*/
 814 #endif
 815
 816 /* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
 817
 818 #if 0
 819 /* testing */
 820 #define MARK_SELECTOR(n)                                                \
 821 STGFUN(CAT2(_PRStartSelector_,n))                                       \
 822 {                                                                       \
 823     P_ maybe_con;                                                       \
 824     FUNBEGIN;                                                           \
 825                                                                         \
 826     /* must be a SPEC 2 1 closure */                                    \
 827     ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);                             \
 828     ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);                           \
 829     ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */            \
 830                                                                         \
 831     JMP_(_PRStart_1);                                                   \
 832                                                                         \
 833     FUNEND;                                                             \
 834 }
 835 #endif /* 0 */
 836
 837 #define MARK_SELECTOR(n)                                                \
 838 STGFUN(CAT2(_PRStartSelector_,n))                                       \
 839 {                                                                       \
 840     P_ maybe_con;                                                       \
 841     FUNBEGIN;                                                           \
 842                                                                         \
 843     /* must be a SPEC 2 1 closure */                                    \
 844     ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2);                             \
 845     ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1);                           \
 846     ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */            \
 847                                                                         \
 848     if (IS_MARK_BIT_SET(Mark)) { /* already marked */                   \
 849         DEBUG_PR_MARKED;                                                \
 850         JUMP_MARK_RETURN;                                               \
 851     }                                                                   \
 852                                                                         \
 853     maybe_con = (P_) *(Mark + _FHS);                                    \
 854                                                                         \
 855     IF_GC_DEBUG(                                                        \
 856     if (SM_trace & 2)  {                                                \
 857         fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, marked? 0x%%lx, info 0x%lx", \
 858                 (n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)),   \
 859                 INFO_NoPTRS(INFO_PTR(Mark)),                            \
 860                 maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/       \
 861                 INFO_PTR(maybe_con));                                   \
 862         fprintf(stderr, ", tag %ld, size %ld, ptrs %ld",                \
 863             INFO_TAG(INFO_PTR(maybe_con)),                              \
 864             INFO_SIZE(INFO_PTR(maybe_con)),                             \
 865             INFO_NoPTRS(INFO_PTR(maybe_con)));                          \
 866         if (INFO_TAG(INFO_PTR(maybe_con)) >=0) {                        \
 867             /* int i; */                                                \
 868             /* for (i = 0; i < INFO_SIZE(INFO_PTR(maybe_con)); i++) { */ \
 869                 /* fprintf(stderr, ", 0x%lx", maybe_con[_FHS + i]); */  \
 870             /*}*/                                                       \
 871             fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]);         \
 872         }                                                               \
 873         fprintf(stderr, "\n");                                          \
 874     } )                                                                 \
 875                                                                         \
 876     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
 877      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */    \
 878      || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */            \
 879         /* see below for OLD test we used here (WDP 95/04) */           \
 880         /* ToDo: decide WHNFness another way? */                        \
 881         JMP_(_PRStart_1);                                               \
 882                                                                         \
 883     /* some things should be true about the pointee */                  \
 884     ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0);                         \
 885     /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
 886                                                                         \
 887     /* OK, it is evaluated: behave just like an indirection */          \
 888                                                                         \
 889     Mark = (P_) (maybe_con[_FHS + (n)]);                                \
 890     /* Mark now has the result of the selection */                      \
 891     JUMP_MARK;                                                          \
 892                                                                         \
 893     FUNEND;                                                             \
 894 }
 895
 896 #if 0
 897 /* OLD test:
 898    the IS_STATIC test was to protect the IS_MARK_BIT_SET check;
 899    but the IS_MARK_BIT_SET test was only there to avoid
 900    mangled pointers, but we cannot have mangled pointers anymore
 901    (after RTBLs came our way).
 902    SUMMARY: we toss both of the "guard" tests.
 903  */
 904     if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */
 905      || IS_MARK_BIT_SET(maybe_con)   /* been here: may be mangled */
 906      || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
 907 #endif /* 0 */
 908
 909 MARK_SELECTOR(0)
 910 MARK_SELECTOR(1)
 911 MARK_SELECTOR(2)
 912 MARK_SELECTOR(3)
 913 MARK_SELECTOR(4)
 914 MARK_SELECTOR(5)
 915 MARK_SELECTOR(6)
 916 MARK_SELECTOR(7)
 917 MARK_SELECTOR(8)
 918 MARK_SELECTOR(9)
 919 MARK_SELECTOR(10)
 920 MARK_SELECTOR(11)
 921 MARK_SELECTOR(12)
 922
 923 #undef IF_GC_DEBUG /* get rid of it */
 924 \end{code}
 925
 926 Marking a Constant Closure -- Set Mark to corresponding static
 927 closure.  Updating of reference will redirect reference to the static
 928 closure.
 929
 930 \begin{code}
 931 STGFUN(_PRStart_Const)
 932 {
 933     FUNBEGIN;
 934     DEBUG_PR_CONST;
 935     Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
 936     JUMP_MARK_RETURN;
 937     FUNEND;
 938 }
 939 \end{code}
 940
 941 Marking a CharLike Closure -- Set Mark to corresponding static
 942 closure.  Updating of reference will redirect reference to the static
 943 closure.
 944
 945 \begin{code}
 946 STGFUN(_PRStart_CharLike)
 947 {
 948     FUNBEGIN;
 949     DEBUG_PR_CHARLIKE;
 950     Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
 951     JUMP_MARK_RETURN;
 952     FUNEND;
 953 }
 954 \end{code}
 955
 956 Marking an IntLike Closure -- Set Mark to corresponding static closure
 957 if in range.  Updating of reference to this will redirect reference to
 958 the static closure.
 959
 960 \begin{code}
 961 STGFUN(_PRStart_IntLike)
 962 {
 963     I_ val;
 964
 965     FUNBEGIN;
 966     if (IS_MARK_BIT_SET(Mark)) {
 967         DEBUG_PR_MARKED;
 968     } else {
 969     val = INTLIKE_VALUE(Mark);
 970
 971     if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
 972         DEBUG_PR_INTLIKE_TO_STATIC;
 973             INFO_PTR(Mark) = (W_) Ind_info;
 974             IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
 975             Mark = (P_) IND_CLOSURE_PTR(Mark);
 976         } else {
 977             /* out of range of static closures */
 978         DEBUG_PR_INTLIKE_IN_HEAP;
 979             INIT_MARK_NODE("INT ",0);
 980     }
 981     }
 982     JUMP_MARK_RETURN;
 983     FUNEND;
 984 }
 985 \end{code}
 986
 987 CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
 988
 989 \begin{code}
 990 #if defined(GCgn)
 991
 992 /* Marking an OldGen root -- treat as indirection if it references the old generation */
 993
 994 STGFUN(_PRStart_OldRoot)
 995 {
 996     P_ oldroot;
 997
 998     FUNBEGIN;
 999     oldroot = (P_) IND_CLOSURE_PTR(Mark);
1000
1001     if (oldroot <= HeapLim)                               /* does the root reference the old generation ? */
1002       {
1003         DEBUG_PR_OLDIND;
1004         Mark = oldroot;                                   /* short circut if the old generation root */
1005         JUMP_MARK;                                        /* references an old generation closure    */
1006       }
1007
1008     else
1009       {
1010         INIT_MARK_NODE("OldRoot",1);                   /* oldroot to new generation */
1011         INIT_MSTACK(SPEC_CLOSURE_PTR);                    /* treat as _PRStart_1       */
1012       }
1013     FUNEND;
1014 }
1015
1016 #endif /* GCgn */
1017
1018 \end{code}
1019
1020 Special error routine, used for closures which should never call their
1021 ``in'' code.
1022
1023 \begin{code}
1024 STGFUN(_PRIn_Error)
1025 {
1026     FUNBEGIN;
1027     fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n");
1028     abort();
1029     FUNEND;
1030 }
1031 \end{code}
1032
1033 %****************************************************************************
1034 %
1035 \subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)}
1036 %
1037 %****************************************************************************
1038
1039 \begin{code}
1040 #ifdef PAR
1041 \end{code}
1042
1043 FetchMe's present a unique problem during global GC.  Since the IMU short-circuits
1044 indirections during its evacuation, it may return a PLC as the new global address
1045 for a @FetchMe@ node.  This has the effect of turning the @FetchMe@ into an
1046 indirection during local garbage collection.  Of course, we'd like to short-circuit
1047 this indirection immediately.
1048
1049 \begin{code}
1050 STGFUN(_PRStart_FetchMe)
1051 {
1052     FUNBEGIN;
1053     if (IS_MARK_BIT_SET(Mark)) {
1054         DEBUG_PR_MARKED;
1055     } else
1056         INIT_MARK_NODE("FME ", 0);
1057
1058     JUMP_MARK_RETURN;
1059     FUNEND;
1060 }
1061
1062 STGFUN(_PRStart_BF)
1063 {
1064     FUNBEGIN;
1065     if (IS_MARK_BIT_SET(Mark)) {
1066         DEBUG_PR_MARKED;
1067         JUMP_MARK_RETURN;
1068     } else {
1069         INIT_MARK_NODE("BF  ", BF_CLOSURE_NoPTRS(dummy));
1070         INIT_MSTACK(BF_CLOSURE_PTR);
1071     }
1072     FUNEND;
1073 }
1074
1075 STGFUN(_PRIn_BF)
1076 {
1077     BitWord mbw;
1078
1079     FUNBEGIN;
1080     GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy));
1081     if (++mbw < BF_CLOSURE_NoPTRS(dummy)) {
1082         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw);
1083         CONTINUE_MARKING_NODE("BF  ", mbw);
1084         MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw);
1085     } else {
1086         SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L);
1087         POP_MSTACK("BF  ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy));
1088     }
1089     FUNEND;
1090 }
1091
1092 #endif /* PAR */
1093 \end{code}
1094
1095 %****************************************************************************
1096 %
1097 \subsubsection[mark-tso]{Marking Thread State Objects (threaded only)}
1098 %
1099 %****************************************************************************
1100
1101 First mark the link, then mark all live registers (StkO plus the VanillaRegs
1102 indicated by Liveness).
1103
1104 CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
1105
1106 \begin{code}
1107
1108 #ifdef CONCURRENT
1109
1110 STGFUN(_PRStart_BQ)
1111 {
1112     FUNBEGIN;
1113     if (IS_MARK_BIT_SET(Mark)) {
1114         DEBUG_PR_MARKED;
1115         JUMP_MARK_RETURN;
1116     } else {
1117     INIT_MARK_NODE("BQ  ", BQ_CLOSURE_NoPTRS(Mark));
1118         INIT_MSTACK(BQ_CLOSURE_PTR);
1119     }
1120     FUNEND;
1121 }
1122
1123 STGFUN(_PRIn_BQ)
1124 {
1125     FUNBEGIN;
1126     POP_MSTACK("BQ  ",BQ_CLOSURE_PTR,1);
1127     FUNEND;
1128 }
1129
1130 STGFUN(_PRStart_TSO)
1131 {
1132     P_ temp;
1133     FUNBEGIN;
1134     if (IS_MARK_BIT_SET(Mark)) {
1135         DEBUG_PR_MARKED;
1136         JUMP_MARK_RETURN;
1137     } else {
1138     INIT_MARK_NODE("TSO ", 0);
1139     temp = TSO_LINK(Mark);
1140     TSO_LINK(Mark) = MStack;
1141     MStack = Mark;
1142     Mark = temp;
1143     JUMP_MARK;
1144     }
1145     FUNEND;
1146 }
1147 \end{code}
1148
1149 When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to
1150 the vanilla registers r[pos-2].
1151
1152 \begin{code}
1153 STGFUN(_PRIn_TSO)
1154 {
1155     W_ liveness;
1156     BitWord oldpos, newpos;
1157     STGRegisterTable *r;
1158     P_ temp, mstack;
1159
1160     FUNBEGIN;
1161     GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS);
1162     r = TSO_INTERNAL_PTR(MStack);
1163
1164     switch(oldpos) {
1165     case 0:
1166         /* Just did the link; now do the StkO */
1167         SET_MARKED_PTRS(MStack,TSO_PTRS,1L);
1168         temp = r->rStkO;
1169         r->rStkO = TSO_LINK(MStack);
1170         TSO_LINK(MStack) = Mark;
1171         Mark = temp;
1172         DEBUG_PRIN("TSO ", 1);
1173         JUMP_MARK;
1174         break;
1175     case 1:
1176         /* Just did the StkO; just update it, saving the old mstack */
1177         mstack = r->rStkO;
1178         r->rStkO = Mark;
1179         break;
1180     default:
1181         /* update the register we just did; save the old mstack */
1182         mstack = r->rR[oldpos - 2].p;
1183         r->rR[oldpos - 2] = Mark;
1184         break;
1185     }
1186
1187     /* liveness of the remaining registers */
1188     liveness = r->rLiveness >> (oldpos - 1);
1189
1190     if (liveness == 0) {
1191         /* Restore MStack and return */
1192         SET_MARKED_PTRS(MStack,TSO_PTRS,0L);
1193         DEBUG_PRLAST("TSO ", oldpos);
1194         Mark = MStack;
1195         MStack = mstack;
1196         JUMP_MARK_RETURN;
1197     }
1198
1199     /* More to do in this TSO */
1200
1201     /* Shift past non-ptr registers */
1202     for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) {
1203         newpos++;
1204     }
1205
1206     /* Mark the next one */
1207     SET_MARKED_PTRS(MStack,TSO_PTRS,newpos);
1208     Mark = r->rR[newpos - 2].p;
1209     r->rR[newpos - 2].p = mstack;
1210     DEBUG_PRIN("TSO ", oldpos);
1211     JUMP_MARK;
1212
1213     FUNEND;
1214 }
1215
1216 \end{code}
1217
1218 %****************************************************************************
1219 %
1220 \subsubsection[mark-stko]{Marking Stack Objects (threaded only)}
1221 %
1222 %****************************************************************************
1223
1224 First mark the A stack, then mark all updatees in the B stack.
1225
1226 \begin{code}
1227
1228 STGFUN(_PRStart_StkO)
1229 {
1230     P_ temp;
1231     I_ size;
1232     I_ cts_size;
1233
1234     FUNBEGIN;
1235     if (IS_MARK_BIT_SET(Mark)) {
1236         DEBUG_PR_MARKED;
1237         JUMP_MARK_RETURN;
1238     } else {
1239     INIT_MARK_NODE("STKO", 0);
1240     size = STKO_CLOSURE_SIZE(Mark);
1241     cts_size = STKO_CLOSURE_CTS_SIZE(Mark);
1242     SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1));
1243     temp = STKO_LINK(Mark);
1244     STKO_LINK(Mark) = MStack;
1245     MStack = Mark;
1246     Mark = temp;
1247     JUMP_MARK;
1248     }
1249     FUNEND;
1250 }
1251 \end{code}
1252
1253 Now the ``in'' code for \tr{STKO} closures.  First the A stack is flushed,
1254 then we chain down the update frames in the B stack, marking the update
1255 nodes.  When all have been marked we pop the stack and return.
1256
1257 \begin{code}
1258 STGFUN(_PRIn_StkO)
1259 {
1260     BitWord oldpos, newpos;
1261     P_ mstack;
1262     I_ size;
1263
1264     FUNBEGIN;
1265
1266     size = STKO_CLOSURE_SIZE(MStack);
1267     GET_GEN_MARKED_PTRS(oldpos, MStack, size);
1268
1269     if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) {
1270         /* Update the link, saving the old mstack */
1271         mstack = STKO_LINK(MStack);
1272         STKO_LINK(MStack) = Mark;
1273     } else {
1274         /* Update the pointer, saving the old mstack */
1275         mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos);
1276         STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark;
1277     }
1278
1279     /* Calculate the next position to mark */
1280     if (oldpos > STKO_SpA_OFFSET(MStack)) {
1281         /* Just walk backwards down the A stack */
1282         newpos = oldpos - 1;
1283         SET_GEN_MARKED_PTRS(MStack,size,newpos);
1284         Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos);
1285         STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack;
1286         DEBUG_PRIN("STKA", oldpos);
1287         JUMP_MARK;
1288     } else if (oldpos <= STKO_SuB_OFFSET(MStack)) {
1289         /* We're looking at an updatee in the B stack; find the next SuB up the chain */
1290         P_ subptr;
1291
1292         subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE)));
1293         newpos = STKO_CLOSURE_OFFSET(MStack,subptr);
1294     } else {
1295         /* Just fell off the end of the A stack; grab the first SuB */
1296         newpos = STKO_SuB_OFFSET(MStack);
1297     }
1298
1299     if (newpos == 0) {  /* Grrr...  newpos is 1-based */
1300         /* Restore MStack and return */
1301         SET_GEN_MARKED_PTRS(MStack,size,0L);
1302         DEBUG_PRLAST("STKO", oldpos);
1303         Mark = MStack;
1304         MStack = mstack;
1305         JUMP_MARK_RETURN;
1306     }
1307
1308     /* newpos is actually the SuB; we want the corresponding updatee */
1309     SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE));
1310     Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE));
1311     STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack;
1312     DEBUG_PRIN("STKB", oldpos);
1313     JUMP_MARK;
1314
1315     FUNEND;
1316 }
1317 #endif  /* CONCURRENT */
1318 \end{code}
1319
1320 %****************************************************************************
1321 %
1322 \subsubsection[mark-caf]{Marking CAFs}
1323 %
1324 %****************************************************************************
1325
1326 A CAF is shorted out as if it is an indirection.
1327 The CAF reference is explicitly updated by the garbage collector.
1328
1329 \begin{code}
1330 STGFUN(_PRStart_Caf)
1331 {
1332     FUNBEGIN;
1333     DEBUG_PR_CAF;
1334     Mark = (P_) IND_CLOSURE_PTR(Mark);
1335     JUMP_MARK;
1336     FUNEND;
1337 }
1338
1339 #if 0 /* Code to avoid explicit updating of CAF references */
1340       /* We need auxiliary mark and update reference info table */
1341
1342 CAF_MARK_UPD_ITBL(Caf_Mark_Upd_info,const);
1343
1344 /* Start marking a CAF -- special mark upd info table */
1345 /* Change to marking state and mark reference */
1346
1347 STGFUN(_PRStart_Caf)
1348 {
1349     FUNBEGIN;
1350     if (IS_MARK_BIT_SET(Mark)) {
1351         DEBUG_PR_MARKED;
1352         JUMP_MARK_RETURN;
1353     } else {
1354         INIT_MARK_NODE("CAF ",1);
1355     INIT_MSTACK(IND_CLOSURE_PTR2);
1356     }
1357     FUNEND;
1358 }
1359
1360 /* Completed marking a CAF -- special mark upd info table */
1361 /* Change info table back to normal CAF info, return reference (Mark) */
1362
1363 STGFUN(_PRInLast_Caf)
1364 {
1365     P_ temp;
1366
1367     FUNBEGIN;
1368     DEBUG_PRLAST_CAF;
1369     SET_INFO_PTR(MStack, Caf_info); /* normal marked CAF */
1370
1371     /* Like POP_MSTACK */
1372     temp = MStack;
1373     MStack = (P_) IND_CLOSURE_PTR(temp);
1374     IND_CLOSURE_PTR(temp) = (W_) Mark;
1375
1376     /* Mark left unmodified so CAF reference is returned */
1377     JUMP_MARK_RETURN;
1378     FUNEND;
1379 }
1380
1381 /* Marking a CAF currently being marked -- special mark upd info table */
1382 /* Just return CAF as if marked -- wont be shorted out */
1383 /* Marking once reference marked and updated -- normal CAF info table */
1384 /* Return reference to short CAF out */
1385
1386 STGFUN(_PRStart_Caf)
1387 {
1388     FUNBEGIN;
1389     if (IS_MARK_BIT_SET(Mark)) {
1390         DEBUG_PR_MARKING_CAF;
1391         JUMP_MARK_RETURN;
1392     } else {
1393     DEBUG_PR_MARKED_CAF;
1394     Mark = (P_) IND_CLOSURE_PTR(Mark);
1395     JUMP_MARK_RETURN;
1396     }
1397     FUNEND;
1398 }
1399
1400 #define DEBUG_PR_MARKED_CAF \
1401     if (SM_trace & 8)   \
1402         fprintf(stderr, "PRMark CAF (Marked): 0x%lx -> 0x%lx, info 0x%lx\n", \
1403                 Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
1404
1405 #define DEBUG_PR_MARKING_CAF \
1406     if (SM_trace & 8)   \
1407         fprintf(stderr, "PRMark CAF (Marking): 0x%lx -> 0x%lx, info 0x%lx\n", \
1408                 Mark, Mark, INFO_PTR(Mark))
1409
1410 #define DEBUG_PRLAST_CAF \
1411     if (SM_trace & 8)    \
1412         fprintf(stderr, "PRRet  Last  (CAF ): 0x%lx -> 0x%lx, info 0x%lx -> 0x%lx ptrs 1\n", \
1413                 MStack, Mark, INFO_PTR(MStack), Caf_info)
1414
1415 #endif /* 0 */
1416
1417 \end{code}
1418
1419 %****************************************************************************
1420 %
1421 \subsection[mark-root]{Root Marking Code}
1422 %
1423 %****************************************************************************
1424
1425 Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file.
1426
1427 These are routines placed in closures at the bottom of the marking stack
1428
1429 \begin{code}
1430 STGFUN(_Dummy_PRReturn_entry)
1431 {
1432     FUNBEGIN;
1433     fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
1434     abort();
1435     return(0);    /* won't happen; quiets compiler warnings */
1436     FUNEND;
1437 }
1438
1439 EXTFUN(_PRMarking_MarkNextRoot);
1440 EXTFUN(_PRMarking_MarkNextCAF);
1441
1442 #ifdef CONCURRENT
1443 EXTFUN(_PRMarking_MarkNextSpark);
1444 #endif
1445
1446 #ifdef PAR
1447 EXTFUN(_PRMarking_MarkNextGA);
1448 #else
1449 EXTFUN(_PRMarking_MarkNextAStack);
1450 EXTFUN(_PRMarking_MarkNextBStack);
1451 #endif /* not parallel */
1452
1453 CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
1454     /* just one, shared */
1455
1456 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
1457                        _PRMarking_MarkNextRoot_info,
1458                        _PRMarking_MarkNextRoot,
1459                        _Dummy_PRReturn_entry);
1460
1461 #ifdef CONCURRENT
1462 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
1463                        _PRMarking_MarkNextSpark_info,
1464                        _PRMarking_MarkNextSpark,
1465                        _Dummy_PRReturn_entry);
1466 #endif
1467
1468 #ifdef PAR
1469 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
1470                        _PRMarking_MarkNextGA_info,
1471                        _PRMarking_MarkNextGA,
1472                        _Dummy_PRReturn_entry);
1473 #else
1474 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
1475                        _PRMarking_MarkNextAStack_info,
1476                        _PRMarking_MarkNextAStack,
1477                        _Dummy_PRReturn_entry);
1478
1479 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
1480                        _PRMarking_MarkNextBStack_info,
1481                        _PRMarking_MarkNextBStack,
1482                        _Dummy_PRReturn_entry);
1483
1484 #endif /* PAR */
1485
1486 DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
1487                        _PRMarking_MarkNextCAF_info,
1488                        _PRMarking_MarkNextCAF,
1489                        _Dummy_PRReturn_entry);
1490
1491 STGFUN(_PRMarking_MarkNextRoot)
1492 {
1493     extern P_ sm_roots_end;     /* &roots[rootno] -- one beyond the end */
1494
1495     FUNBEGIN;
1496     /* Update root -- may have short circuited Ind */
1497     *MRoot = (W_) Mark;
1498
1499     /* Is the next off the end */
1500     if (++MRoot >= sm_roots_end)
1501         RESUME_(miniInterpretEnd);
1502
1503     Mark = (P_) *MRoot;
1504     JUMP_MARK;
1505     FUNEND;
1506 }
1507
1508 #ifdef CONCURRENT
1509 STGFUN(_PRMarking_MarkNextSpark)
1510 {
1511     extern P_ sm_roots_end;     /* PendingSparksTl[pool] */
1512
1513     FUNBEGIN;
1514     /* Update root -- may have short circuited Ind */
1515     *MRoot = (W_) Mark;
1516
1517     /* Is the next off the end */
1518     if (++MRoot >= sm_roots_end)
1519         RESUME_(miniInterpretEnd);
1520
1521     Mark = (P_) *MRoot;
1522     JUMP_MARK;
1523     FUNEND;
1524 }
1525 #endif
1526
1527 #ifdef PAR
1528 STGFUN(_PRMarking_MarkNextGA)
1529 {
1530     FUNBEGIN;
1531     /* Update root -- may have short circuited Ind */
1532     ((GALA *)MRoot)->la = Mark;
1533
1534     do {
1535         MRoot = (P_) ((GALA *) MRoot)->next;
1536     } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT);
1537
1538     /* Is the next off the end */
1539     if (MRoot == NULL)
1540         RESUME_(miniInterpretEnd);
1541
1542     Mark = ((GALA *)MRoot)->la;
1543     JUMP_MARK;
1544     FUNEND;
1545 }
1546
1547 #else
1548
1549 STGFUN(_PRMarking_MarkNextAStack)
1550 {
1551     FUNBEGIN;
1552     /* Update root -- may have short circuited Ind */
1553     *MRoot = (W_) Mark;
1554
1555     /* Is the next off the end */
1556     if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0)
1557         RESUME_(miniInterpretEnd);
1558
1559     Mark = (P_) *MRoot;
1560     JUMP_MARK;
1561     FUNEND;
1562 }
1563
1564
1565 STGFUN(_PRMarking_MarkNextBStack)
1566 {
1567     FUNBEGIN;
1568     /* Update root -- may have short circuited Ind */
1569     PUSH_UPDATEE(MRoot, Mark);
1570
1571     MRoot = GRAB_SuB(MRoot);
1572
1573     /* Is the next off the end */
1574     if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0)
1575         RESUME_(miniInterpretEnd);
1576
1577     Mark = GRAB_UPDATEE(MRoot);
1578     JUMP_MARK;
1579     FUNEND;
1580 }
1581 #endif  /* PAR */
1582 \end{code}
1583
1584 Mark the next CAF in the CAF list.
1585
1586 \begin{code}
1587 STGFUN(_PRMarking_MarkNextCAF)
1588 {
1589     FUNBEGIN;
1590     /* Update root -- may have short circuted Ind */
1591     IND_CLOSURE_PTR(MRoot) = (W_) Mark;
1592
1593     MRoot = (P_) IND_CLOSURE_LINK(MRoot);
1594
1595     /* Is the next CAF the end of the list */
1596     if (MRoot == 0)
1597         RESUME_(miniInterpretEnd);
1598
1599     Mark = (P_) IND_CLOSURE_PTR(MRoot);
1600     JUMP_MARK;
1601     FUNEND;
1602 }
1603 \end{code}
1604
1605 \begin{code}
1606 #if 0 /* Code to avoid explicit updating of CAF references */
1607
1608 STGFUN(_PRMarking_MarkNextCAF)
1609 {
1610     FUNBEGIN;
1611     MRoot = (P_) IND_CLOSURE_LINK(MRoot);
1612
1613     /* Is the next CAF the end of the list */
1614     if (MRoot == 0)
1615         RESUME_(miniInterpretEnd);
1616
1617     Mark = MRoot;
1618     JUMP_MARK;
1619     FUNEND;
1620 }
1621 #endif /* 0 */
1622 \end{code}
1623
1624 Multi-slurp protection.
1625
1626 \begin{code}
1627 #endif /* _INFO_MARKING */
1628 \end{code}