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