/* Garbage collector. */

/* --------------------------- Specification --------------------------- */

/* Execute a simple garbage collection.
 can trigger GC */
local void gar_col_simple (void);

/* Execute a full garbage collection.
 can trigger GC */
global void gar_col (void);

#ifdef SPVW_PAGES
/* Supplement a simple garbage collection with a compactification.
 can trigger GC */
local void gar_col_compact (void);
#endif

#if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && RESERVE
/* Move the conses, to make a little more room. */
local void move_conses (sintL delta);
#endif

/* --------------------------- Implementation -------------------------- */

/* overall strategy:
 1. pseudo-recursive marking by setting of garcol_bit.
 2. relocate objects if fixed length (conses and similar),
    calculation of displacement of objects of variable length.
 3. update of pointers.
 4. perform the displacements of objects of variable length.
 5. relallocated objects are made to refer to the new location
*/

#include "spvw_genera1.c"

/* marking-subroutine
 procedure: marking routine without stack usage (i.e.
  non-"recursive") by descent into the structure to be marked
  with pointer-modification (pointers are reversed,
  so that they can serve as "ariadne thread")
 Convention: an object X counts as marked, if
  - an object of variable length: bit garcol_bit,(X) is set
  - a two-pointer-object: bit garcol_bit,(X) is set
  - a SUBR/FSUBR: bit garcol_bit,(X+const_offset) is set
  - Character, Short-Float, Fixnum etc.: always.
Use GC_MARK when the argument might be a reallocated string */
#define GC_MARK(o) do {                         \
  if (arrayp(o)) simple_array_to_storage(o); gc_mark(o); } while(0)
local void gc_mark (object obj)
{
  var object dies = obj; /* current object */
  var object vorg = nullobj; /* predecessor-object */

#define down_pair()                                                     \
  if (in_old_generation(dies,typecode(dies),1))                         \
    goto up; /* do not mark older generation */                         \
  { var object* dies_ = (object*)ThePointer(dies);                      \
    if (marked(dies_)) goto up; /* marked -> go up */                   \
      mark(dies_); /* mark */                                           \
  }                                                                     \
  { var object dies_ = objectplus(dies,(soint)(sizeof(cons_)-sizeof(object))<<(oint_addr_shift-addr_shift)); \
    /* start with the last pointer */                                   \
    var object nachf = *(object*)ThePointer(dies_); /* successor */     \
    *(object*)ThePointer(dies_) = vorg; /* store predecessor */         \
    vorg = dies_; /* current object becomes new predecessor */          \
    dies = nachf; /* successor becomes current object */                \
    goto down; /* and descent */                                        \
  }
#define up_pair()                                       \
  { mark(ThePointer(vorg)); /* mark again */            \
    dies = vorg; /* Cons becomes object */              \
    vorg = vorvorg; goto up; /* go further up */        \
  }
#define down_varobject(The,first_offset,last_offset)                    \
  if (in_old_generation(dies,typecode(dies),0))                         \
    goto up; /* do not mark older generation */                         \
  { var object* dies_ = (object*)The(dies);                             \
    if (marked(dies_)) goto up; /* marked -> up */                      \
    mark(dies_); /* mark */                                             \
    mark(pointerplus(dies_,first_offset)); /* mark first pointer */     \
  }                                                                     \
  { var object dies_ = objectplus(dies,(soint)(last_offset)<<(oint_addr_shift-addr_shift)); \
    /* start with the last pointer */                                   \
    var object nachf = *(object*)The(dies_); /* successor */            \
    *(object*)The(dies_) = vorg; /* store predecessor */                \
    vorg = dies_; /* current object becomes new predecessor */          \
    dies = nachf; /* predecessor becomes current object */              \
    goto down; /* and descent */                                        \
  }
#define up_varobject(first_offset)                                      \
  { dies = objectplus(vorg,-(soint)(first_offset)<<(oint_addr_shift-addr_shift)); /* becomes current object */ \
    vorg = vorvorg; goto up; /* go further up */                        \
  }
#define down_nopointers(The)                    \
  if (in_old_generation(dies,typecode(dies),0)) \
    goto up; /* do not mark older generation */ \
  mark(The(dies)); /* mark */                   \
  goto up; /* and up */
#define down_iarray()                                                   \
  if (in_old_generation(dies,typecode(dies),0))                         \
    goto up; /* do not mark older generation */                         \
  { var object* dies_ = (object*)TheIarray(dies);                       \
    if (marked(dies_)) goto up; /* marked -> up */                      \
    mark(dies_); /* mark */                                             \
  }                                                                     \
  { var object dies_ = objectplus(dies,(soint)(iarray_data_offset)<<(oint_addr_shift-addr_shift)); \
    /* data vector is the first and only pointer */                     \
    var object nachf = *(object*)TheIarray(dies_); /* successor */      \
    *(object*)TheIarray(dies_) = vorg; /* stor predecessor */           \
    mark(TheIarray(dies_)); /* mark first and only pointer */           \
    vorg = dies_; /* current object becomes new predecessor */          \
    dies = nachf; /* predecessor becomes current object */              \
    goto down; /* and descent */                                        \
  }
#define up_iarray()                                                     \
  { dies = objectplus(vorg,-(soint)iarray_data_offset<<(oint_addr_shift-addr_shift)); /* array becomes current object */ \
    vorg = vorvorg; goto up; /* go further up */                        \
  }
#define down_svector()                                                  \
  if (in_old_generation(dies,typecode(dies),0))                         \
    goto up; /* do not mark older generation */                         \
  { var object* dies_ = (object*)TheSvector(dies);                      \
    if (marked(dies_)) goto up; /* marked -> up */                      \
    mark(dies_); /* mark */                                             \
  }                                                                     \
  { var uintL len = Svector_length(dies);                               \
    if (len==0) goto up; /* Length 0: up again */                       \
   {var object dies_ = objectplus(dies,((soint)offsetofa(svector_,data) << (oint_addr_shift-addr_shift)) \
    /* the "<< 1" and "/2" are a workaround against a gcc-2.7.2         \
       missed optimization in WIDE_SOFT mode */                         \
      + (((soint)len << 1) * (soint)(sizeof(object)/2) << (oint_addr_shift-addr_shift)) \
      - ((soint)sizeof(object) << (oint_addr_shift-addr_shift)) );      \
    /* start with the last pointer */                                   \
    var object nachf = *(object*)TheSvector(dies_); /* successor */     \
    *(object*)TheSvector(dies_) = vorg; /* store predecessor */         \
    mark(&TheSvector(dies)->data[0]); /* mark first pointer */          \
    vorg = dies_; /* current object becomes new predecessor */          \
    dies = nachf; /* predecessor becomes current object */              \
    goto down; /* and descent */                                        \
  }}
#define up_svector()                            \
  { dies = objectplus(vorg,-(soint)offsetofa(svector_,data)<<(oint_addr_shift-addr_shift)); /* Svector becomes current object */ \
    vorg = vorvorg; goto up; /* go further up */ \
  }
#define down_weakkvt()                                            \
  if (in_old_generation(dies,typecode(dies),0)) goto up;          \
  { var object* dies_ = (object*)TheSvector(dies);                \
    if (marked(dies_)) goto up;                                   \
    mark(dies_);                                                  \
  } goto up; /* no elements to "sub-mark" */
#define up_weakkvt()                             \
  { dies = objectplus(vorg,-(soint)offsetofa(svector_,data)<<(oint_addr_shift-addr_shift)); /* Svector becomes current object */ \
    vorg = vorvorg; goto up; /* go further up */ \
  }
#define down_record()                                                   \
  if (in_old_generation(dies,typecode(dies),0))                         \
    goto up; /* do not mark older generation */                         \
  { var object* dies_ = (object*)TheRecord(dies);                       \
    if (marked(dies_)) goto up; /* marked -> up */                      \
    mark(dies_); /* marked */                                           \
  }                                                                     \
  { var uintL len = Record_length(dies);                                \
    if (len==0) goto up; /* Length 0: up again */                       \
   {var object dies_ = objectplus(dies,((soint)offsetofa(record_,recdata) << (oint_addr_shift-addr_shift)) \
    /* the "<< 1" and "/2" are a workaround against a gcc-2.7.2         \
       missed optimization in WIDE_SOFT mode */                         \
      + (((soint)len << 1) * (soint)(sizeof(object)/2) << (oint_addr_shift-addr_shift)) \
      - ((soint)sizeof(object) << (oint_addr_shift-addr_shift)) );      \
    /* start with the last pointer */                                   \
    var object nachf = *(object*)TheRecord(dies_); /* successor */      \
    *(object*)TheRecord(dies_) = vorg; /* store predecessor */          \
    mark(&TheRecord(dies)->recdata[0]); /* mark first pointer */        \
    vorg = dies_; /* current object becomes new predecessor */          \
    dies = nachf; /* predecessor becomes current object */              \
    goto down; /* and descent */                                        \
  }}
#define up_record()                               \
  { dies = objectplus(vorg,-(soint)offsetofa(record_,recdata)<<(oint_addr_shift-addr_shift)); /* record becomes current object */ \
    vorg = vorvorg; goto up; /* go further up */  \
  }
#define down_subr()                                                     \
  { var object* dies_ = (object*)pointerplus(TheSubr(dies),subr_const_offset);\
    if (marked(dies_)) goto up; /* marked -> up */                      \
    /* mark later */                                                    \
  }                                                                     \
  { var object dies_ = objectplus(dies,(soint)(subr_const_offset+(subr_const_anz-1)*sizeof(object))<<(oint_addr_shift-addr_shift)); \
    /* start with the last pointer */                                   \
    var object nachf = *(object*)TheSubr(dies_); /* successor */        \
    *(object*)TheSubr(dies_) = vorg; /* store predecessor */            \
    /* mark first pointer (and thus the SUBR itself) : */               \
    mark(pointerplus(TheSubr(dies),subr_const_offset));                 \
    vorg = dies_; /* current object becomes new predecessor */          \
    dies = nachf; /* predecessor becomes current object */              \
    goto down; /* and descent */                                        \
  }
#define up_subr()                                                       \
  { mark(TheSubr(vorg)); /* mark again */                               \
    dies = objectplus(vorg,-(soint)subr_const_offset<<(oint_addr_shift-addr_shift)); /* SUBR becomes current object */ \
    vorg = vorvorg; goto up; /* go further up */                        \
  }

 down: /* entry for further descent.
          dies = object to be marked (engl. this),
          vorg = its predecessor */
 #ifdef TYPECODES
  switch (typecode(dies)) {
   case_pair: /* object with exactly two 2 pointers (Cons and similar) */
    down_pair();
   case_symbol: /* Symbol */
    down_varobject(TheSymbol,symbol_objects_offset,
                   sizeof(symbol_)-sizeof(object));
   case_sbvector: /* simple-bit-vector */
   case_sb2vector: /* simple-2bit-vector */
   case_sb4vector: /* simple-4bit-vector */
   case_sb8vector: /* simple-8bit-vector */
   case_sb16vector: /* simple-16bit-vector */
   case_sb32vector: /* simple-32bit-vector */
   case_sstring: /* simple-string */
   case_bignum: /* bignum */
  #ifndef WIDE
   case_ffloat: /* single-float */
  #endif
   case_dfloat: /* double-float */
   case_lfloat: /* long-float */
    /* objects of variable length, that do not contain pointers: */
    down_nopointers(TheVarobject);
   case_mdarray: case_obvector: case_ob2vector: case_ob4vector: case_ob8vector:
   case_ob16vector: case_ob32vector: case_ostring: case_ovector:
    /* arrays, that are not simple: */
    down_iarray();
   case_svector: /* simple-vector */
    down_svector();
   case_weakkvt: /* weak-key-value-table */
    down_weakkvt();
   case_record: /* Srecord/Xrecord */
    down_record();
   case_machine: /* maschine address */
   case_char: /* character */
   case_system: /* frame-pointer, read-label, system */
   case_fixnum: /* fixnum */
   case_sfloat: /* short-float */
  #ifdef WIDE
   case_ffloat: /* single-float */
  #endif
    /* These are direct objects, no pointers. */
    goto up;
   case_subr: /* SUBR */
    down_subr();
   default: /* These are no objects. */
     /*NOTREACHED*/ abort();
  }
 #else
  switch (as_oint(dies) & nonimmediate_bias_mask) {
    case cons_bias: /* cons */
      /* NB: (immediate_bias & nonimmediate_bias_mask) == cons_bias. */
      if (immediate_object_p(dies)) goto up;
      down_pair();
    case varobject_bias:
      switch (Record_type(dies)) {
        case Rectype_Sbvector:
        case Rectype_Sb2vector:
        case Rectype_Sb4vector:
        case Rectype_Sb8vector:
        case Rectype_Sb16vector:
        case Rectype_Sb32vector:
        case Rectype_S8string: case Rectype_Imm_S8string:
        case Rectype_S16string: case Rectype_Imm_S16string:
        case Rectype_S32string: case Rectype_Imm_S32string:
        case Rectype_Bignum:
        case Rectype_Ffloat:
        case Rectype_Dfloat:
        case Rectype_Lfloat:
          down_nopointers(TheRecord);
        case Rectype_Svector:
          down_svector();
        case Rectype_WeakKVT:
          down_weakkvt();
        case Rectype_reallocstring:
          simple_array_to_storage(dies);
          /*FALLTHROUGH*/
        case Rectype_mdarray:
        case Rectype_bvector:
        case Rectype_b2vector:
        case Rectype_b4vector:
        case Rectype_b8vector:
        case Rectype_b16vector:
        case Rectype_b32vector:
        case Rectype_string:
        case Rectype_vector:
          down_iarray();
        default: /* Srecord/Xrecord */
          down_record();
      }
    case subr_bias: /* SUBR */
      down_subr();
    case machine_bias:
      /* These are direct objects, no pointers. */
      goto up;
    default:
      /*NOTREACHED*/ abort();
  }
 #endif
 up: /* entry for ascent.
        dies = currently marked object, vorg = its predecessor */
  if (eq(vorg,nullobj)) /* ending flag reached? */
    return; /* yes -> finished */
  if (!marked(ThePointer(vorg))) { /* already through? */
    /* no ->
       next element further left (come from 'up', go to 'down')
       dies = currently marked  object, store in *vorg */
    var object vorvorg = *(object*)ThePointer(vorg); /* old predecessor */
    *(object*)ThePointer(vorg) = dies; /* write back component */
    vorg = objectplus(vorg,-(soint)(sizeof(object))<<(oint_addr_shift-addr_shift)); /* go to next component */
    if (marked(ThePointer(vorg))) { /* already marked? */
      dies = /* next component, without mark */
        without_mark_bit(*(object*)ThePointer(vorg));
      *(object*)ThePointer(vorg) = /* further relocate old predecessor, thereby renew mark */
        with_mark_bit(vorvorg);
    } else {
      dies = *(object*)ThePointer(vorg); /* next component, without mark */
      *(object*)ThePointer(vorg) = vorvorg; /* further relocate old predecessor */
    }
    goto down;
  }
  { /* already through -> ascent again */
    var object vorvorg = /* fetch old predecessor, without mark bit */
      without_mark_bit(*(object*)ThePointer(vorg));
    *(object*)ThePointer(vorg) = dies; /* write back first component */
   #ifdef TYPECODES
    switch (typecode(vorg)) {
     case_pair: /* object with exactly two pointers (Cons and similar) */
      up_pair();
     case_symbol: /* Symbol */
      up_varobject(symbol_objects_offset);
     case_weakkvt: /* weak-key-value-table */
      up_weakkvt();
     case_svector: /* simple-vector with at least 1 component */
      up_svector();
     case_mdarray: case_obvector: case_ob2vector:
     case_ob4vector: case_ob8vector: case_ob16vector:
     case_ob32vector: case_ostring: case_ovector:
      /* non-simple arrays: */
      up_iarray();
     case_record: /* Srecord/Xrecord */
      up_record();
     case_subr: /* SUBR */
      up_subr();
     case_machine: /* maschine address */
     case_char: /* character */
     case_system: /* frame-pointer, read-label, system */
     case_fixnum: /* fixnum */
     case_sfloat: /* short-float */
    #ifdef WIDE
     case_ffloat: /* single-float */
    #endif
      /* These are direct objects, no pointers. */
     case_sbvector: /* simple-bit-vector */
     case_sb2vector: /* simple-2bit-vector */
     case_sb4vector: /* simple-4bit-vector */
     case_sb8vector: /* simple-8bit-vector */
     case_sb16vector: /* simple-16bit-vector */
     case_sb32vector: /* simple-32bit-vector */
     case_sstring: /* simple-string */
     case_bignum: /* bignum */
    #ifndef WIDE
     case_ffloat: /* single-float */
    #endif
     case_dfloat: /* double-float */
     case_lfloat: /* long-float */
      /* Objects of variable length, that do not contain pointers. */
     default: /* these are no objects. */
      /*NOTREACHED*/ abort();
    }
   #else
    switch (as_oint(vorg) & nonimmediate_bias_mask) {
      case cons_bias: /* Cons */
        up_pair();
      case subr_bias: /* SUBR */
        up_subr();
      case varobject_bias:
        /* This works only because all varobjects have the same
           objects_offset! */
        up_record();
      default: /* these are no objects. */
        /*NOTREACHED*/ abort();
    }
   #endif
  }
#undef up_subr
#undef down_subr
#undef up_record
#undef down_record
#undef up_svector
#undef down_svector
#undef up_weakkvt
#undef down_weakkvt
#undef up_iarray
#undef down_iarray
#undef down_nopointers
#undef up_varobject
#undef down_varobject
#undef up_pair
#undef down_pair
}

# pack a pointer into an object, without  typeinfo.
# pointer_as_object(ptr): void* --> object
# pointer_was_object(obj): object --> void*
  #ifdef TYPECODES
    #define pointer_as_object(ptr)  type_pointer_object(0,ptr)
    #define pointer_was_object(obj)  type_pointable(0,obj)
  #else
    #define pointer_as_object(ptr)  as_object((oint)(ptr))
    #define pointer_was_object(obj)  ((void*)as_oint(obj))
  #endif

# marking phase:
  # All "active" struktures are marked.
  # everything is active, that is reachable
  # - from the LISP-stack or
  # - at Generational-GC: from the old generation or
  # - as program-constant (the list of all packages belongs to this).
    local void gc_mark_stack (object* objptr);
    local void gc_mark_stack(objptr)
      var object* objptr;
      { until (eq(*objptr,nullobj)) # until STACK is finished:
          { if ( as_oint(*objptr) & wbit(frame_bit_o) ) # does a frame start here?
             { if (( as_oint(*objptr) & wbit(skip2_bit_o) ) == 0) # without skip2-Bit?
                objptr skipSTACKop 2; # yes -> advance by 2
                else
                objptr skipSTACKop 1; # no -> advance by 1
             }
             else
             { # normal object, mark:
               var object obj = *objptr;
               #ifndef NO_symbolflags
               switch (typecode(obj)) # poss. remove Symbol-flags
                 { case_symbolflagged:
                     obj = symbol_without_flags(obj);
                   default: break;
                 }
               #endif
               GC_MARK(*objptr);
               objptr skipSTACKop 1; # advance
      }   }  }

  #include "spvw_genera2.c"

  local void gc_markphase (void);
  local void gc_markphase()
    {
      # Mark all the STACKs
      for_all_STACKs(gc_mark_stack(objptr));
      #ifdef GENERATIONAL_GC
      # mark old generation, whereas it is perused sparingly:
      if (generation > 0) { gc_mark_old_generation(); }
      #endif
      # mark all program constants:
      for_all_subrs( gc_mark(subr_tab_ptr_as_object(ptr)); ); # peruse subr_tab
      #if !defined(GENERATIONAL_GC)
      for_all_constsyms( gc_mark(symbol_tab_ptr_as_object(ptr)); ); # peruse symbol_tab
      #else
      # because of the macro in_old_generation(), gc_mark() regards all constant
      # symbols as belonging to the old generation and does not peruse them.
      for_all_constsyms( # peruse symbol_tab
        { gc_mark(ptr->symvalue);
          gc_mark(ptr->symfunction);
          gc_mark(ptr->proplist);
          gc_mark(ptr->pname);
          gc_mark(ptr->homepackage);
        });
      #endif
      for_all_constobjs( gc_mark(*objptr); ); # peruse object_tab
      for_all_threadobjs( gc_mark(*objptr); ); # peruse threads
    }

# UP: Determine, if an object is still "live".
# I.e. if the mark bit is set after the marking phase.
  local bool alive (object obj);
  local bool alive(obj)
    var object obj;
    {
      #ifdef TYPECODES
      switch (typecode(obj)) # according to type
        { case_pair: # Cons
            if (in_old_generation(obj,typecode(obj),1)) return true;
            if (marked(ThePointer(obj))) return true; else return false;
          case_symbol: # Symbol
          case_array: # Array
          case_bignum: # Bignum
          #ifndef WIDE
          case_ffloat: # Single-Float
          #endif
          case_dfloat: # Double-Float
          case_lfloat: # Long-Float
          case_record: # Record
            if (in_old_generation(obj,typecode(obj),0)) return true;
            if (marked(ThePointer(obj))) return true; else return false;
          case_subr: # Subr
            if (marked(pointerplus(TheSubr(obj),subr_const_offset)))
              return true; else return false;
          case_machine: # Maschine Pointer
          case_char: # Character
          case_system: # Frame-pointer, Read-label, system
          case_fixnum: # Fixnum
          case_sfloat: # Short-Float
          #ifdef WIDE
          case_ffloat: # Single-Float
          #endif
            return true;
          default:
            # these are no objects.
            /*NOTREACHED*/ abort();
        }
      #else
      switch (as_oint(obj) & nonimmediate_bias_mask)
        { case varobject_bias:
            if (in_old_generation(obj,,0)) return true;
            if (marked(ThePointer(obj))) return true; else return false;
          case (cons_bias & immediate_bias):
            if (immediate_object_p(obj)) return true;
            if (in_old_generation(obj,,1)) return true;
            if (marked(ThePointer(obj))) return true; else return false;
          case subr_bias:
            if (marked(pointerplus(TheSubr(obj),subr_const_offset)))
              return true; else return false;
          default:
            return true;
        }
      #endif
    }

# unmark SUBRs and fixed Symbols:
  local void unmark_fixed_varobjects (void);
  local void unmark_fixed_varobjects()
    { for_all_subrs( unmark((aint)ptr+subr_const_offset); ); # unmark each Subr
      #if !defined(GENERATIONAL_GC)
      for_all_constsyms( unmark(&((Symbol)ptr)->GCself); ); # unmark each Symbol in symbol_tab
      #else
      # As we have not marked the constant Symbols, but only their
      # content, we do not have to unmark them.
      #endif
    }

#if !defined(MORRIS_GC)

 #ifdef SPVW_MIXED_BLOCKS_OPPOSITE

  # concentrate CONS-cells between page->page_start and page->page_end
  # aloft:
  local void gc_compact_cons_page (Page* page);
  local void gc_compact_cons_page(page)
    var Page* page;
    # the pointer p1 moves from below and the pointer p2 from
    # above through the memory region, until they collide.
    # Marked structures are moved above unmarked.
    { var aint p1 = page->page_start; # lower bound
      var aint p2 = page->page_end; # upper bound
      sweeploop:
        # search the next-higher unmarked cell <p2 and unmark all:
        sweeploop1:
          if (p1==p2) goto sweepok2; # bounds are equal -> finished
          p2 -= sizeof(cons_); # capture next cell from above
          if (marked(p2)) # marked?
            { unmark(p2); # unmark
              goto sweeploop1;
            }
        # p1 <= p2, p2 points to an unmarked cell.
        # search next lower marked cell >=p1:
        sweeploop2:
          if (p1==p2) goto sweepok1; # bounds are equal -> finished
          if (!marked(p1)) # unmarked?
            { p1 += sizeof(cons_); # at the next lower cell
              goto sweeploop2; # continue search
            }
        # p1 < p2, p1 points to a marked cell.
        unmark(p1); # unmark
        # copy content of cell into the unmark cell:
        ((object*)p2)[0] = ((object*)p1)[0];
        ((object*)p2)[1] = ((object*)p1)[1];
        *(object*)p1 = pointer_as_object(p2); # leave new addresse
        mark(p1); # and mark (as identification for the update)
        p1 += sizeof(cons_); # this cell is finished.
        goto sweeploop; # continue
      sweepok1: p1 += sizeof(cons_); # skip last unmarked Cons
      sweepok2:
      # p1 = new lower bound of the Cons-region
      page->page_start = p1;
    }

 #else

  # concentrate CONS-cells between page->page_start and page->page_end
  # below:
  local void gc_compact_cons_page (Page* page);
  local void gc_compact_cons_page(page)
    var Page* page;
    # the pointer p1 moves from below and the pointer p2 from
    # above through the memory region, until they collide.
    # Marked structures are moved above unmarked.
    { var aint p1 = page->page_start; # lower bound
      var aint p2 = page->page_end; # upper bound
      sweeploop:
        # search next higher marked cell <p2:
        sweeploop1:
          if (p1==p2) goto sweepok2; # bounds are equal -> finished
          p2 -= sizeof(cons_); # capture next cell from above
          if (!marked(p2)) goto sweeploop1; # unmarked?
        # p1 <= p2, p2 points to a marked cell.
        unmark(p2); # unmark
        # search next lower unmarked cell >=p1 and unmark all:
        sweeploop2:
          if (p1==p2) goto sweepok1; # bounds are equal -> finished
          if (marked(p1)) # marked?
            { unmark(p1); # unmark
              p1 += sizeof(cons_); # at next upper cell
              goto sweeploop2; # continue search
            }
        # p1 < p2, p1 points to an unmarked cell.
        # copy cell content from the marked into the unmark cell:
        ((object*)p1)[0] = ((object*)p2)[0];
        ((object*)p1)[1] = ((object*)p2)[1];
        *(object*)p2 = pointer_as_object(p1); # leave new address
        mark(p2); # and mark (as identification for update)
        p1 += sizeof(cons_); # this cell is finished.
        goto sweeploop; # continue
      sweepok1: p1 += sizeof(cons_); # skip last marked Cons
      sweepok2:
      # p1 = new upper bound of the Cons-region
      page->page_end = p1;
    }

 #endif

#else # defined(MORRIS_GC)

# Algorithm see:
# [F. Lockwood Morris: A time- and space-efficient garbage collection algorithm.
#  CACM 21,8 (August 1978), 662-665.]

  # Delete all unmarked CONS-cells and unmark the marked CONS-cells,
  # so that the mark bit is available for the reverse spointers.
  local void gc_morris1 (Page* page);
  local void gc_morris1(page)
    var Page* page;
    { var aint p1 = page->page_start; # lower bound
      var aint p2 = page->page_end; # upper bound
      var aint d = 0; # also count free memory
      until (p1==p2)
        { if (!marked(p1))
            { ((object*)p1)[0] = nullobj;
              ((object*)p1)[1] = nullobj;
              d += sizeof(cons_);
            }
            else
            { unmark(p1);
              #ifdef DEBUG_SPVW
              if (eq(((object*)p1)[0],nullobj) || eq(((object*)p1)[1],nullobj))
                abort();
              #endif
            }
          p1 += sizeof(cons_); # this cell is finished.
        }
      page->page_gcpriv.d = d; # store free memory
    }

 #ifdef SPVW_MIXED_BLOCKS_OPPOSITE

  # There is only one page with Two-Pointer-Objects.

  local void gc_morris2 (Page* page);
  local void gc_morris2(page)
    var Page* page;
    { # Each cell within a Cons now contains a list of all
      # addresses of pointers to this cell, that point to this cell
      # from a root or from a Varobject.
      #
      # traverse the undeleted conses from left to right:
      # (in between, each cell contains a liste of all addresses
      # of pointers to this cell, that point to this cell from a root,
      # from a varobject or a cons lying further to the left.)
      var aint p1 = page->page_start; # lower bound
      var aint p2 = p1 + page->page_gcpriv.d; # later lower bound
      var aint p1limit = page->page_end; # upper bound
      until (p1==p1limit) # always: p1 <= p2 <= p1limit
        { # both cells of a cons are treated exactly the same.
          var object obj = *(object*)p1;
          if (!eq(obj,nullobj))
            { # p1 is moved to p2.
              #ifdef TYPECODES
                # the so far registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = upointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = type_pointer_object(typecode(obj),p2);
                    obj = next_obj;
                  }}
                # if the cell contains a pointer "to the right",
                # it is reversed.
                { var tint type = typecode(obj);
                  switch (type)
                    { case_pair:
                        { var aint p = upointer(obj);
                          if (!in_old_generation(obj,type,1) && (p > p1))
                            { # For later update, insert
                              # p1 in the list of pointers to p:
                              *(object*)p1 = *(object*)p;
                              *(object*)p = with_mark_bit(type_pointer_object(type,p1));
                              break;
                        }   }
                      default:
                        *(object*)p1 = obj;
                }   }
              #else # no TYPECODES
                # the so far registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = (aint)ThePointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2);
                    obj = next_obj;
                  }}
                # if the cell contains a pointer "to the right",
                # it is reversed.
                if (consp(obj))
                  { var aint p = (aint)ThePointer(obj);
                    if (!in_old_generation(obj,,1) && (p > p1))
                      { # For later update, insert
                        # p1 in the list of pointers to p:
                        *(object*)p1 = *(object*)p;
                        *(object*)p = with_mark_bit(as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p1));
                      }
                      else
                      { *(object*)p1 = obj; }
                  }
                  else
                  { *(object*)p1 = obj; }
              #endif
              p2 += sizeof(object);
            }
          p1 += sizeof(object);
        }
      if (!(p2==p1limit)) abort();
    }
  local void gc_morris3 (Page* page);
  local void gc_morris3(page)
    var Page* page;
    { # Each cell within a cons now contains again the original
      # content.
      #
      # Traverse the undeleted conses from right to left
      # and compact them on the right:
      # (in between, each cell contains a list of all addresses
      # of pointers to this cell, that point to this cell
      # from a cons lying further to the right.)
      var aint p1limit = page->page_start; # lower bound
      var aint p1 = page->page_end; # upper bound
      var aint p2 = p1; # upper bound
      #ifdef DEBUG_SPVW
      until (p1==p1limit)
        { p1 -= 2*sizeof(object);
          if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
            abort();
        }
      p1 = page->page_end;
      #endif
      until (p1==p1limit) # always: p1limit <= p1 <= p2
        { # both cells of a cons are treated exactly the same.
          p1 -= sizeof(object);
          #ifdef DEBUG_SPVW
          if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
            abort();
          if (!((p1 % (2*sizeof(object))) == 0))
            { if (!((p2 % (2*sizeof(object))) == 0))
                abort();
            }
          #endif
         {var object obj = *(object*)p1;
          if (!eq(obj,nullobj))
            { p2 -= sizeof(object);
              # p1 is moved to p2.
              #ifdef TYPECODES
                # The newly registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = upointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = type_pointer_object(typecode(obj),p2);
                    obj = next_obj;
                  }}
                #ifdef DEBUG_SPVW
                if (eq(obj,nullobj)) abort();
                #endif
                *(object*)p2 = obj;
                { var tint type = typecode(obj);
                  if (!gcinvariant_type_p(type)) # un-movable -> do nothing
                    switch (type)
                      { case_pair: # Two-Pointer-Object
                          { var aint p = upointer(obj);
                            if (p < p1) # pointer to the left?
                              { # For later update, insert
                                # p2 into the list of pointers to p:
                                #ifdef DEBUG_SPVW
                                if (eq(*(object*)p,nullobj)) abort();
                                #endif
                                *(object*)p2 = *(object*)p;
                                *(object*)p = with_mark_bit(type_pointer_object(type,p2));
                              }
                            elif (p == p1) # pointer to itself?
                              { *(object*)p2 = type_pointer_object(type,p2); }
                          }
                          break;
                        default: # object of variable length
                          if (marked(ThePointer(obj))) # marked?
                            *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
                          break;
                }     }
              #else # no TYPECODES
                # The newly registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = (aint)ThePointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2);
                    obj = next_obj;
                  }}
                #ifdef DEBUG_SPVW
                if (eq(obj,nullobj)) abort();
                #endif
                *(object*)p2 = obj;
                if (!gcinvariant_object_p(obj)) # un-movable -> do nothing
                  { if (consp(obj))
                      # Two-Pointer-Object
                      { var aint p = (aint)ThePointer(obj);
                        if (p < p1) # pointer to the left?
                          { # for later update, insert
                            # p2 into the list of pointers to p:
                            #ifdef DEBUG_SPVW
                            if (eq(*(object*)p,nullobj)) abort();
                            #endif
                            *(object*)p2 = *(object*)p;
                            *(object*)p = with_mark_bit(as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2));
                          }
                        elif (p == p1) # pointer to itself?
                          { *(object*)p2 = as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2); }
                      }
                      else
                        # object of variable length
                        { if (marked(ThePointer(obj))) # marked?
                            *(object*)p2 = as_object((as_oint(obj) & nonimmediate_bias_mask) | (as_oint(*(object*)ThePointer(obj)) & ~wbit(garcol_bit_o) & ~(oint)nonimmediate_bias_mask));
                        }
                  }
              #endif
            }
        }}
      # p2 = new lower bound of the Cons-region
      if (!(p2 == page->page_start + page->page_gcpriv.d)) abort();
      page->page_start = p2;
    }

 #elif defined(SPVW_MIXED_BLOCKS_STAGGERED)

  local void gc_morris2 (Page* page);
  local void gc_morris2(page)
    var Page* page;
    { # Each cell within a Cons now contains a list of all
      # addresses of pointers to this cell, that point to this cell
      # from a root or from a Varobject.
      #
      # Traverse the undeleted conses from right to left:
      # (in between, each cell contains a liste of all addresses
      # of pointers to this cell, that point to this cell from a root,
      # from a varobject or a cons lying further to the right.)
      var aint p1 = page->page_end; # upper bound
      var aint p2 = p1 - page->page_gcpriv.d; # later upper bound
      var aint p1limit = page->page_start; # lower bound
      #ifdef DEBUG_SPVW
      until (p1==p1limit)
        { p1 -= 2*sizeof(object);
          if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
            abort();
        }
      p1 = page->page_end;
      #endif
      until (p1==p1limit) # always: p1limit <= p2 <= p1
        { # both cells of a cons are treated exactly the same.
          p1 -= sizeof(object);
          #ifdef DEBUG_SPVW
          if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
            abort();
          #endif
         {var object obj = *(object*)p1;
          if (!eq(obj,nullobj))
            { p2 -= sizeof(object);
              # p1 is moved to p2.
              #ifdef TYPECODES
                # the so far registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = upointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = type_pointer_object(typecode(obj),p2);
                    obj = next_obj;
                  }}
                # obj = original content of the cell p1.
                #ifdef DEBUG_SPVW
                if (eq(obj,nullobj)) abort();
                #endif
                # if the cell contains a pointer "to the left", it is reversed.
                { var tint type = typecode(obj);
                  switch (type)
                    { case_pair:
                        { var aint p = upointer(obj);
                          if (!in_old_generation(obj,type,1) && (p < p1))
                            { # For later update, insert
                              # p1 into the list of pointers to p:
                              *(object*)p1 = *(object*)p;
                              *(object*)p = with_mark_bit(type_pointer_object(type,p1));
                              break;
                        }   }
                      default:
                        *(object*)p1 = obj;
                }   }
              #else
                # the so far registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = (aint)ThePointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2);
                    obj = next_obj;
                  }}
                # obj = original content of the cell p1.
                #ifdef DEBUG_SPVW
                if (eq(obj,nullobj)) abort();
                #endif
                # if the cell contains a pointer "to the left", it is reversed.
                if (consp(obj))
                  { var aint p = (aint)ThePointer(obj);
                    if (!in_old_generation(obj,,1) && (p < p1))
                      { # For later update, insert
                        # p1 into the list of pointers to p:
                        *(object*)p1 = *(object*)p;
                        *(object*)p = with_mark_bit(as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p1));
                      }
                      else
                      { *(object*)p1 = obj; }
                  }
                  else
                  { *(object*)p1 = obj; }
              #endif
            }
        }}
      if (!(p2==p1limit)) abort();
    }
  local void gc_morris3 (Page* page);
  local void gc_morris3(page)
    var Page* page;
    { # Each cell within a cons now contains again the original
      # content.
      #
      # Traverse the undeleted conses from left to right
      # and compact them on the left:
      # (in between, each cell contains a list of all addresses
      # of pointers to this cell, that point to this cell
      # from a cons lying further to the left.)
      var aint p1limit = page->page_end; # obere Grenze
      var aint p1 = page->page_start; # lower bound
      var aint p2 = p1; # lower bound
      until (p1==p1limit) # always: p1limit <= p1 <= p2
        { # both cells of a cons are treated exactly the same.
          var object obj = *(object*)p1;
          if (!eq(obj,nullobj))
            { # p1 is moved to p2.
              #ifdef TYPECODES
                # The newly registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = upointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = type_pointer_object(typecode(obj),p2);
                    obj = next_obj;
                  }}
                # obj = true content of the cell p1.
                { var tint type = typecode(obj);
                  if (!gcinvariant_type_p(type)) # un-movable -> do nothing
                    switch (type)
                      { case_pair: # Two-Pointer-Object
                          { var aint p = upointer(obj);
                            if (p > p1) # pointer to the right?
                              { # For later update, insert
                                # p2 into the list of pointers to p:
                                #ifdef DEBUG_SPVW
                                if (eq(*(object*)p,nullobj)) abort();
                                #endif
                                *(object*)p2 = *(object*)p;
                                *(object*)p = with_mark_bit(type_pointer_object(type,p2));
                              }
                            elif (p == p1) # Pointer to itself?
                              { *(object*)p2 = type_pointer_object(type,p2); }
                            else
                              { *(object*)p2 = obj; }
                          }
                          break;
                        default: # object of variable length
                          if (marked(ThePointer(obj))) # marked?
                            *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
                            else
                            *(object*)p2 = obj;
                          break;
                      }
                    else # un-movable or pointer into the old generation -> do nothing
                    { *(object*)p2 = obj; }
                }
              #else
                # The newly registered pointers to this cell are updated:
                until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                  { obj = without_mark_bit(obj);
                   {var aint p = (aint)ThePointer(obj);
                    var object next_obj = *(object*)p;
                    *(object*)p = as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2);
                    obj = next_obj;
                  }}
                # obj = true content of the cell p1.
                if (!gcinvariant_object_p(obj)) # un-movable -> do nothing
                  { if (consp(obj))
                      # Two-Pointer-Object
                      { var aint p = (aint)ThePointer(obj);
                        if (p > p1) # pointer to the right?
                          { # For later update, insert
                            # p2 into the list of pointers to p:
                            #ifdef DEBUG_SPVW
                            if (eq(*(object*)p,nullobj)) abort();
                            #endif
                            *(object*)p2 = *(object*)p;
                            *(object*)p = with_mark_bit(as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2));
                          }
                        elif (p == p1) # pointer to itself?
                          { *(object*)p2 = as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)p2); }
                        else
                          { *(object*)p2 = obj; }
                      }
                      else
                      # Object of variable length
                      { if (marked(ThePointer(obj))) # marked?
                          *(object*)p2 = as_object((as_oint(obj) & nonimmediate_bias_mask) | (as_oint(*(object*)ThePointer(obj)) & ~wbit(garcol_bit_o) & ~(oint)nonimmediate_bias_mask));
                          else
                          *(object*)p2 = obj;
                      }
                  }
                  else # un-movable or pointer into the old generation -> do nothing
                  { *(object*)p2 = obj; }
              #endif
              p2 += sizeof(object);
            }
          p1 += sizeof(object);
        }
      # p2 = new upper bound of the Cons-region
      if (!(p2 == page->page_end - page->page_gcpriv.d)) abort();
      page->page_end = p2;
    }

 #else # SPVW_PURE_BLOCKS <==> SINGLEMAP_MEMORY

  # gc_morris2 and gc_morris3 must be called for each page exactly once,
  # first gc_morris2 from right to left, then gc_morris3 from left to right
  # (in terms of the positioning of the addresses)!

  local void gc_morris2 (Page* page);
  local void gc_morris2(page)
    var Page* page;
    { # Each cell within a Cons now contains a list of all
      # addresses of pointers to this cell, that point to this cell
      # from a root or from a Varobject.
      #
      # Traverse the undeleted conses from right to left:
      # (in between, each cell contains a liste of all addresses
      # of pointers to this cell, that point to this cell from a root,
      # from a varobject or a cons lying further to the right.)
      var aint p1 = page->page_end; # upper bound
      var aint p2 = p1 - page->page_gcpriv.d; # later upper bound
      var aint p1limit = page->page_start; # lower bound
      until (p1==p1limit) # always: p1limit <= p2 <= p1
        { # both cells of a cons are treated exactly the same.
          p1 -= sizeof(object);
         {var object obj = *(object*)p1;
          if (!eq(obj,nullobj))
            { p2 -= sizeof(object);
              # p1 is moved to p2.
              # the so far registered pointers to this cell are updated:
              until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                { obj = without_mark_bit(obj);
                 {var object next_obj = *(object*)pointable(obj);
                  *(object*)pointable(obj) = as_object(p2);
                  obj = next_obj;
                }}
              # obj = original content of the cell p1.
              # if the cell contains a pointer "to the left", it is reversed.
              if (is_cons_heap(typecode(obj))
                  && !in_old_generation(obj,typecode(obj),1)
                  && ((aint)pointable(obj) < p1)
                 )
                { # For later update, insert
                  # p1 into the list of pointers to obj:
                  *(object*)p1 = *(object*)pointable(obj);
                  *(object*)pointable(obj) = with_mark_bit(as_object(p1));
                }
                else
                { *(object*)p1 = obj; }
            }
        }}
      if (!(p2==p1limit)) abort();
    }
  local void gc_morris3 (Page* page);
  local void gc_morris3(page)
    var Page* page;
    { # Each cell within a cons now contains again the original
      # content.
      #
      # Traverse the undeleted conses from left to right
      # and compact them on the left:
      # (in between, each cell contains a list of all addresses
      # of pointers to this cell, that point to this cell
      # from a cons lying further to the left.)
      var aint p1limit = page->page_end; # upper bound
      var aint p1 = page->page_start; # lower bound
      var aint p2 = p1; # lower bound
      until (p1==p1limit) # always: p1limit <= p1 <= p2
        { # both cells of a cons are treated exactly the same.
          var object obj = *(object*)p1;
          if (!eq(obj,nullobj))
            { # p1 is moved to p2.
              # The newly registered pointers to this cell are updated:
              until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # process list
                { obj = without_mark_bit(obj);
                 {var object next_obj = *(object*)pointable(obj);
                  *(object*)pointable(obj) = as_object(p2);
                  obj = next_obj;
                }}
              # obj = true content of cell p1.
              { var tint type = typecode(obj);
                if (!is_unused_heap(type) && !in_old_generation(obj,type,?))
                  if (is_cons_heap(type))
                    # Two-Pointer-Object
                    { if ((aint)pointable(obj) > p1) # pointer to the right?
                        { # For later update, insert
                          # p2 into the list of pointers to obj:
                          *(object*)p2 = *(object*)pointable(obj);
                          *(object*)pointable(obj) = with_mark_bit(as_object(p2));
                        }
                      elif ((aint)pointable(obj) == p1) # pointer to itself?
                        { *(object*)p2 = as_object(p2); }
                      else
                        { *(object*)p2 = obj; }
                    }
                    else
                    # object of variable length
                    { if (marked(ThePointer(obj))) # marked?
                        *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
                        else
                        *(object*)p2 = obj;
                    }
                  else # un-movable or pointer into the old generation -> do nothing
                  { *(object*)p2 = obj; }
              }
              p2 += sizeof(object);
            }
          p1 += sizeof(object);
        }
      # p2 = new upper bound of the Cons-region
      if (!(p2 == page->page_end - page->page_gcpriv.d)) abort();
      page->page_end = p2;
    }

 #endif

#endif

# modify the self-pointer of an object of variable length:
# set_GCself(p,type,addr);
# sets p->GCself to type_pointer_object(type,addr).
  #ifdef TYPECODES
    #if !(exact_uint_size_p(oint_type_len) && ((oint_type_shift%hfintsize)==0) && (tint_type_mask == bit(oint_type_len)-1))
      #ifdef MAP_MEMORY
        # addr contains typeinfo
        #define set_GCself(p,type,addr)  \
          ((Varobject)(p))->GCself = type_pointer_object((type)&(tint_type_mask),(addr)&(oint_addr_mask))
      #else
        # addr contains no typeinfo
        #define set_GCself(p,type,addr)  \
          ((Varobject)(p))->GCself = type_pointer_object((type)&(tint_type_mask),addr)
      #endif
    #else # better: though two memory accesses, but less arithmetics
      #define set_GCself(p,type,addr)  \
        ((Varobject)(p))->GCself = type_pointer_object(0,addr), \
        ((Varobject)(p))->header_flags = (type)
    #endif
  #else
    #define set_GCself(p,type,addr)  /* ignore type */ \
      ((Varobject)(p))->GCself = as_object((oint)(addr))
  #endif

# prepare objects of variable length between page->page_start and
# page->page_end for compactification below. Therefore, in each marked
# object the pointer in front is pointed to the location, where the
# object will be located later (including typeinfo). If the sequencing
# object is unmarked, then its first pointer is oriented to the address
# of the next marked object.
  #ifdef SPVW_PURE
  local aint gc_sweep1_varobject_page (uintL heapnr, aint start, aint end, object* firstmarked, aint dest);
  local aint gc_sweep1_varobject_page (
    var uintL heapnr,
    var aint start,
    var aint end,
    var object* firstmarked,
    var aint dest)
  #elif defined(GENERATIONAL_GC)
  local aint gc_sweep1_varobject_page (aint start, aint end, object* firstmarked, aint dest);
  local aint gc_sweep1_varobject_page (
    var aint start,
    var aint end,
    var object* firstmarked,
    var aint dest)
  #else
  local void gc_sweep1_varobject_page (Page* page);
  local void gc_sweep1_varobject_page (
    var Page* page)
  #endif
    {
      #if defined(SPVW_PURE) || defined(GENERATIONAL_GC)
      var object* last_open_ptr = firstmarked;
      var aint p2 = start; # source-pointer
      var aint p2end = end; # upper bound of the source-region
      var aint p1 = dest; # destination-pointer
      #else
      var object* last_open_ptr = &page->page_gcpriv.firstmarked;
        # In *last_open_ptr, always store the address of the next marked
        # object (als oint) .
        # Via chained-list-mechanism: At the end, page->page_gcpriv.firstmarked
        # contains the address of the 1. marked object
      var aint p2 = page->page_start; # source-pointer
      var aint p2end = page->page_end; # upper bound of the source-region
      var aint p1 = p2; # destination-pointer
      #endif
      # start <= p1 <= p2 <= end, p1 and p2 grow, p2 faster than p1.
      var_prepare_objsize;
      sweeploop1:
        # search next marked object.
        # enter address of the next marked object in *last_open_ptr .
        if (p2==p2end) goto sweepok1; # upper bound reached -> finished
        {
          #ifdef TYPECODES
          var tint flags = mtypecode(((Varobject)p2)->GCself);
          # save typeinfo (and flags for symbols)
          #endif
          var uintL laenge = objsize((Varobject)p2); # determine byte-length
          if (!marked(p2)) # object unmarked?
            { p2 += laenge; goto sweeploop1; } # yes -> goto next object
          # object marked
          *last_open_ptr = pointer_as_object(p2); # store address
          set_GCself(p2, flags,p1); # enter new address, with old
                         # typeinfo (the mark bit is contained within)
          #ifndef TYPECODES
          mark(p2);
          #endif
          p2 += laenge; # source address for next object
          p1 += laenge; # destination address for next object
        }
      sweeploop2:
        # search next unmarked object.
        if (p2==p2end) goto sweepok2; # upper bound reached -> finished
        {
          #ifdef TYPECODES
          var tint flags = mtypecode(((Varobject)p2)->GCself);
          # save typeinfo (and flags for symbols)
          #endif
          var uintL laenge = objsize((Varobject)p2); # determine byte-length
          if (!marked(p2)) # object unmarked?
            { last_open_ptr = (object*)p2; # yes -> store the next pointer here
              p2 += laenge; goto sweeploop1; # goto next object
            }
          # object marked
          set_GCself(p2, flags,p1); # enter new address, with old
                         # typeinfo (the mark bit is contained within)
          #ifndef TYPECODES
          mark(p2);
          #endif
          p2 += laenge; # source address for next object
          p1 += laenge; # destination address for next object
          goto sweeploop2;
        }
      sweepok1: *last_open_ptr = pointer_as_object(p2);
      sweepok2: ;
      #if defined(SPVW_PURE) || defined(GENERATIONAL_GC)
      return p1;
      #endif
    }

# update phase:
  # The entire LISP-memory is perused and old addresses are replaced
  # with new ones.
  # update of an object *objptr :
    #if !defined(MORRIS_GC)
      #ifdef TYPECODES
        #define update(objptr)  \
          { var tint type = mtypecode(*(object*)objptr);                     \
            if (!gcinvariant_type_p(type)) # un-movable -> do nothing        \
              { var object obj = *(object*)objptr; # object                  \
                if (!in_old_generation(obj,type,mem.heapnr_from_type[type])) \
                  # older generation -> do nothing (object stayed there)     \
                  if (marked(ThePointer(obj))) # marked?                     \
                    # no -> do nothing (object stayed there)                 \
                    # yes -> enter new address and typeinfobyte (incl.       \
                    #        poss. symbol-binding-flag)                      \
                    *(object*)objptr =                                       \
                      type_untype_object(type,untype(*(object*)ThePointer(obj))); \
          }   }
      #else
        #define update(objptr)  \
          { var object obj = *(object*)objptr; # object                     \
            if (!gcinvariant_object_p(obj)) # un-movable -> do nothing      \
              if (!in_old_generation(obj,,))                                \
                # older generation -> do nothing (object stayed there)      \
                if (marked(ThePointer(obj))) # marked?                      \
                  # no ->  do nothing (object stayed there)                 \
                  # yes -> enter new address                                \
                  *(object*)objptr =                                        \
                    as_object((as_oint(obj) & nonimmediate_bias_mask) | (as_oint(*(object*)ThePointer(obj)) & ~wbit(garcol_bit_o))); \
          }
      #endif
    #else # defined(MORRIS_GC)
      #if defined(SPVW_MIXED_BLOCKS)
        #ifdef TYPECODES
          #define update(objptr)  \
            { var tint type = mtypecode(*(object*)objptr);                  \
              if (!gcinvariant_type_p(type)) # un-movable -> do nothing     \
                switch (type)                                               \
                  { default: # object of variable length                    \
                      { var object obj = *(object*)objptr; # object         \
                        if (!in_old_generation(obj,type,0))                 \
                          if (marked(ThePointer(obj))) # marked?            \
                            *(object*)objptr = type_untype_object(type,untype(*(object*)ThePointer(obj))); \
                      }                                                     \
                      break;                                                \
                    case_pair: # Two-Pointer-Object                         \
                      { var object obj = *(object*)objptr; # object         \
                        if (!in_old_generation(obj,type,1))                 \
                          { # for later update, insert into its list:       \
                            *(object*)objptr = *(object*)ThePointer(obj);   \
                            *(object*)ThePointer(obj) = with_mark_bit(type_pointer_object(type,objptr)); \
                      }   }                                                 \
                      break;                                                \
            }     }
        #else
          #define update(objptr)  \
            { var object obj = *(object*)objptr; # object                   \
              if (!gcinvariant_object_p(obj))                               \
                { if (consp(obj))                                           \
                    # Two-Pointer-Object                                    \
                    { if (!in_old_generation(obj,,1))                       \
                        { # for later update, insert into its list:         \
                          *(object*)objptr = *(object*)ThePointer(obj);     \
                          *(object*)ThePointer(obj) = with_mark_bit(as_object((as_oint(obj) & nonimmediate_bias_mask) | (oint)objptr)); \
                    }   }                                                   \
                    else                                                    \
                    # object of variable length                             \
                    { if (!in_old_generation(obj,,0))                       \
                        { if (marked(ThePointer(obj))) # marked?            \
                            *(object*)objptr = as_object((as_oint(obj) & nonimmediate_bias_mask) | (as_oint(*(object*)ThePointer(obj)) & ~wbit(garcol_bit_o) & ~(oint)nonimmediate_bias_mask)); \
                    }   }                                                   \
            }   }
        #endif
      #else # defined(SPVW_PURE_BLOCKS) # && defined(SINGLEMAP_MEMORY)
        #define update(objptr)  \
          { var tint type = mtypecode(*(object*)objptr);                    \
            if (!is_unused_heap(type)) # unmovable -> do nothing            \
              { var object obj = *(object*)objptr; # object                 \
                if (!in_old_generation(obj,type,?))                         \
                  # older generation -> do nothing (object stayed there)    \
                  { if (is_varobject_heap(type))                            \
                      # object of variable length                           \
                      { if (marked(ThePointer(obj))) # marked?              \
                          *(object*)objptr = type_untype_object(type,untype(*(object*)ThePointer(obj))); \
                      }                                                     \
                      else                                                  \
                      # Two-Pointer-Object                                  \
                      { # for later update, insert into its list:           \
                        *(object*)objptr = *(object*)ThePointer(obj);       \
                        *(object*)ThePointer(obj) = with_mark_bit(pointer_as_object(objptr)); \
                  }   }                                                     \
          }   }
      #endif
    #endif
    #ifndef NO_symbolflags
      #define update_stackobj(objptr)  \
        switch (mtypecode(*objptr))                               \
          { case_symbolflagged: # symbol, poss. with flags        \
              { var object obj1 = *objptr;                        \
                var object obj2 = symbol_without_flags(obj1);     \
                var oint flags = as_oint(obj1) ^ as_oint(obj2);   \
                *objptr = obj2; # delete flags                    \
                update(objptr); # then update                     \
                *objptr = as_object(as_oint(*objptr) | flags); # then back again \
                break;                                            \
              }                                                   \
            default: update(objptr); break;                       \
          }
    #else
      #define update_stackobj(objptr)  \
        update(objptr);
    #endif
  # update of old generation:
    #include "spvw_genera3.c"

# second SWEEP-phase:
  # relocation of an object of variable length, advance p1 and p2:
  # move_aligned_p1_p2(count);
  #if (varobject_alignment==1)
    #define uintV  uintB
  #elif (varobject_alignment==2)
    #define uintV  uintW
  #elif (varobject_alignment==4)
    #define uintV  uintL
  #elif (varobject_alignment==8)
    #define uintV  uintL2
  #else
    #error "Unbekannter Wert von 'varobject_alignment'!"
  #endif
  #if defined(GNU) && !defined(__cplusplus) # better for optimization
    #ifdef fast_dotimesL
      #define move_aligned_p1_p2(count)  \
        dotimespL(count,count/varobject_alignment, *((uintV*)p2)++ = *((uintV*)p1)++; )
    #else
      #define move_aligned_p1_p2(count)  \
        do { *((uintV*)p2)++ = *((uintV*)p1)++; count -= varobject_alignment; } until (count==0)
    #endif
  #else # other compilers do not accept ((type*)p)++ .
    # how efficient is this here??
    #define move_aligned_p1_p2(count)  \
      do { *(uintV*)p2 = *(uintV*)p1;                            \
           p1 += varobject_alignment; p2 += varobject_alignment; \
           count -= varobject_alignment;                         \
         }                                                       \
         until (count==0)
  #endif
  # the objects of variable length are moved into the preordained
  # new places.
  #ifdef SPVW_PURE
  local void gc_sweep2_varobject_page (Page* page, uintL heapnr);
  local void gc_sweep2_varobject_page (
    var Page* page,
    var uintL heapnr)
  #else
  local void gc_sweep2_varobject_page (Page* page);
  local void gc_sweep2_varobject_page (
    var Page* page)
  #endif
    # peruse from below and shift down:
    { var aint p1 = (aint)pointer_was_object(page->page_gcpriv.firstmarked); # source-pointer, first marked object
      var aint p1end = page->page_end;
      var aint p2 = page->page_start; # destination-pointer
      var_prepare_objsize;
      until (p1==p1end) # upper bound reached -> finished
        { # next object has address p1
          if (marked(p1)) # marked?
            { unmark(p1); # delete mark
              # keep object and relocate:
             {var uintL count = objsize((Varobject)p1); # length (divisible by varobject_alignment , >0)
              if (!(p1==p2)) # if relocation is necessary
                { move_aligned_p1_p2(count); } # relocate and advance
                else # else only advance:
                { p1 += count; p2 += count; }
            }}
            else
            { p1 = (aint)pointer_was_object(*(object*)p1); } # with pointer (typeinfo=0) to the next marked object
        }
      page->page_end = p2; # set upper bound of the objects of variable length
    }

#if defined(DEBUG_SPVW) && !defined(GENERATIONAL_GC)
  # check, if everything is really unmarked:
  #define CHECK_GC_UNMARKED()  gc_unmarkcheck()
  local void gc_unmarkcheck (void);
  local void gc_unmarkcheck()
    { for_each_varobject_page(page,
        # peruse from above:
        { var aint p1 = page->page_start;
          var aint p1end = page->page_end;
          var_prepare_objsize;
          until (p1==p1end) # lower bound reached -> finished
            { # next object has address p1
              if (marked(p1)) # marked?
                { asciz_out_1("\nObject 0x%x marked!!\n",p1);
                  abort();
                }
              p1 += objsize((Varobject)p1);
        }   }
        );
      for_each_cons_page(page,
        # peruse from below:
        { var aint p1 = page->page_start;
          var aint p1end = page->page_end;
          until (p1==p1end) # upper bound reached -> finished
            { # next object has address p1
              if (marked(p1)) # marked?
                { asciz_out_1("\nObject 0x%x marked!!\n",p1);
                  abort();
                }
              p1 += sizeof(cons_);
        }   }
        );
    }
#else
  #define CHECK_GC_UNMARKED()
#endif

#ifdef DEBUG_SPVW
  # check agains nullpointer:
  #define CHECK_NULLOBJ()  nullobjcheck(false)
  local void nullobjcheck (bool in_gc);
  local void nullobjcheck_range (aint p1, aint p1end, bool in_gc);
  local void nullobjcheck_range(p1,p1end,in_gc)
    var aint p1;
    var aint p1end;
    var bool in_gc;
    { until (p1==p1end) # upper bound reached -> finished
        { # next object has address p1
          if (eq(((Cons)p1)->cdr,nullobj) || eq(((Cons)p1)->car,nullobj))
            if (!(in_gc && eq(((Cons)p1)->cdr,nullobj) && eq(((Cons)p1)->car,nullobj)))
              abort();
          p1 += sizeof(cons_);
    }   }
  local void nullobjcheck(in_gc)
    var bool in_gc;
    { # peruse from below:
      #ifdef GENERATIONAL_GC
      #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
      for_each_cons_heap(heap,
        { nullobjcheck_range(heap->heap_start,heap->heap_gen1_end,in_gc);
          nullobjcheck_range(heap->heap_gen0_start,heap->heap_gen0_end,in_gc);
        });
      #else
      for_each_cons_heap(heap,
        { nullobjcheck_range(heap->heap_gen0_start,heap->heap_gen0_end,in_gc);
          nullobjcheck_range(heap->heap_gen1_start,heap->heap_end,in_gc);
        });
      #endif
      #else
      for_each_cons_page(page,
        { nullobjcheck_range(page->page_start,page->page_end,in_gc); });
      #endif
    }
#else
  #define CHECK_NULLOBJ()
#endif

#ifdef SPVW_PAGES
  # free superfluous pages:
  # if the space that is available in mem.free_pages after GC,
  # amounts to more than 25% of what we currently need, the rest
  # is returned back to the operating system.
  local void free_some_unused_pages (void);
  local void free_some_unused_pages()
    { var uintL needed_space = floor(mem.last_gcend_space,4); # 25%
      var uintL accu_space = 0;
      var Pages* pageptr = &mem.free_pages;
      var Pages page = *pageptr;
      until (page==NULL)
        { var Pages nextpage = page->page_gcpriv.next;
          if (accu_space < needed_space)
            # retain page
            { accu_space += page->page_room;
              pageptr = (Pages*)&page->page_gcpriv.next; page = nextpage;
            }
            else
            # free page
            { free_page(page); page = *pageptr = nextpage; }
    }   }
#endif

# perform normal Garbage Collection:
  local void gar_col_normal(void);
  local void gar_col_normal()
    { var uintL gcstart_space; # occupied memory at GC-start
      var uintL gcend_space; # occupied memory at GC-end
      var object all_weakpointers; # list of active Weak-pointers
      var object all_weakkvtables; # list of active weak key-value tables
      var object all_finalizers; # list of finalizers
      #ifdef GC_CLOSES_FILES
      var object files_to_close; # list of files to be closed
      #endif
      set_break_sem_1(); # disable BREAK during Garbage Collection
      gc_signalblock_on(); # disable Signals during Garbage Collection
      gc_timer_on();
      gcstart_space = used_space(); # detect occupied memory
      #ifdef HAVE_VADVISE
        begin_system_call();
        vadvise(VA_ANOM); # Paging-behaviour now becomes a little unusual
        end_system_call();
      #endif
      CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
      #ifdef SPVW_PAGES
        { var uintL heapnr;
          for (heapnr=0; heapnr<heapcount; heapnr++)
            { AVL_map(mem.heaps[heapnr].inuse,page,
                      page->page_room += page->page_end;
                     );
              # the end of usable space is stored in page_room.
        }   }
      #endif
      #ifdef GENERATIONAL_GC
      if (generation == 0)
        # update old generation with help of the cache:
        { prepare_old_generation(); }
        else
        # only treat the new generation. Hide old generation:
        #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
        { mem.varobjects.heap_start = mem.varobjects.heap_gen1_start;
          mem.conses.heap_end = mem.conses.heap_gen1_end;
        }
        #else
        { var uintL heapnr;
          for (heapnr=0; heapnr<heapcount; heapnr++)
            mem.heaps[heapnr].heap_start = mem.heaps[heapnr].heap_gen1_start;
        }
        #endif
      #endif
      CHECK_GC_GENERATIONAL();
      # mark phase:
        all_weakpointers = O(all_weakpointers); O(all_weakpointers) = Fixnum_0;
        all_weakkvtables = O(all_weakkvtables); O(all_weakkvtables) = Fixnum_0;
        all_finalizers = O(all_finalizers); O(all_finalizers) = Fixnum_0;
        #ifdef GC_CLOSES_FILES
        files_to_close = O(open_files); O(open_files) = NIL; # O(files_to_close) = NIL;
        #endif
        gc_markphase();
        # split (still unmarked) list all_finalizers into two lists:
        { var object Lu = all_finalizers;
          var object* L1 = &O(all_finalizers);
          var object* L2 = &O(pending_finalizers);
          until (eq(*L2,Fixnum_0))
            { L2 = &TheFinalizer(*L2)->fin_cdr; }
          until (eq(Lu,Fixnum_0))
            { # if fin_alive is dead, the finalizer is thrown away,
              # without being executed:
              if (!alive(TheFinalizer(Lu)->fin_alive))
                { Lu = TheFinalizer(Lu)->fin_cdr; }
                else
                { # if fin_trigger dies, the finalizer is exeecuted:
                  if (alive(TheFinalizer(Lu)->fin_trigger)) # is fin_trigger still alive?
                    # yes -> take over in O(all_finalizers) :
                    { *L1 = Lu; L1 = &TheFinalizer(Lu)->fin_cdr; Lu = *L1; }
                    else
                    # no -> take over in O(pending_finalizers) :
                    { *L2 = Lu; L2 = &TheFinalizer(Lu)->fin_cdr; Lu = *L2; }
                }
            }
          *L1 = Fixnum_0; *L2 = Fixnum_0;
        }
        gc_mark(O(all_finalizers)); gc_mark(O(pending_finalizers)); # mark both lists now
        #ifdef GC_CLOSES_FILES
        # split (still unmarked) list files_to_close into two lists:
        { var object Lu = files_to_close;
          var object* L1 = &O(open_files);
          var object* L2 = &O(files_to_close);
          while (consp(Lu))
            { if (in_old_generation(Car(Lu),stream_type,0)
                  || marked(TheStream(Car(Lu))) # (car Lu) marked?
                 )
                # yes -> take over in O(open_files) :
                { *L1 = Lu; L1 = &Cdr(Lu); Lu = *L1; }
                else
                # no -> take over in O(files_to_close) :
                { *L2 = Lu; L2 = &Cdr(Lu); Lu = *L2; }
            }
          *L1 = NIL; *L2 = NIL;
        }
        gc_mark(O(open_files)); gc_mark(O(files_to_close)); # mark both lists now
        #endif
        { # (still unmarked) shorten the all_weakpointers list:
          var object Lu = all_weakpointers;
          var object* L1 = &O(all_weakpointers);
          while (!eq(Lu,Fixnum_0)) {
            if (!alive(Lu)) {
              # The weak-pointer itself is being GCed.
              # Don't care about its contents. Remove it from the list.
              Lu = TheWeakpointer(Lu)->wp_cdr;
            } else if (!alive(TheWeakpointer(Lu)->wp_value)) {
              # The referenced value is being GCed. Break the
              # weak-pointer and remove it from the list.
              var object next = TheWeakpointer(Lu)->wp_cdr;
              TheWeakpointer(Lu)->wp_cdr = unbound;
              TheWeakpointer(Lu)->wp_value = unbound;
              Lu = next;
            } else {
              # The referenced value is still alive. Keep the
              # weak-pointer in the list.
              *L1 = Lu; L1 = &TheWeakpointer(Lu)->wp_cdr; Lu = *L1;
            }
          }
          *L1 = Fixnum_0;
        }
        { var object L = O(all_weakpointers); # mark the list
          while (!eq(L,Fixnum_0))
            { gc_mark(L); L = TheWeakpointer(L)->wp_cdr; }
        }
        { # (still unmarked) shorten the all_weakkvtables list:
          var object Lu = all_weakkvtables;
          var object* L1 = &O(all_weakkvtables);
          while (!eq(Lu,Fixnum_0)) {
            ASSERT(weakkvtp(Lu));
            if (!alive(Lu)) {
              # The weak key-value table itself is being GCed.
              # Don't care about its contents. Remove it from the list.
              Lu = TheWeakKVT(Lu)->wkvt_cdr;
            } else {
              # kill the key/value pairs where the key is dead
              var uintL len = Weakkvt_length(Lu);
              var uintL idx = 0;
              var WeakKVT wt = TheWeakKVT(Lu);
              var object* data = wt->data;
              for (; idx < len; idx += 2) {
                var object key = data[idx];
                if (boundp(key)) {
                  if (alive(key)) # mark value
                    gc_mark(data[idx+1]);
                  else # drop both key and value from the table
                    data[idx] = data[idx+1] = unbound;
                }
              }
              # Keep the WeakKVT in the list.
              *L1 = Lu; L1 = &TheWeakKVT(Lu)->wkvt_cdr; Lu = *L1;
            }
          }
          *L1 = Fixnum_0;
        }
        { var object L = O(all_weakkvtables); # mark the list
          while (!eq(L,Fixnum_0))
            { gc_mark(L); L = TheWeakKVT(L)->wkvt_cdr; }
        }
      # All active objects are marked now:
      # active objects of variable length and active two-pointer-objects carry
      # in their first byte a set mark bit, active SUBRs carry
      # in their first constant pointer a set mark bit, all other
      # mark bits are deleted.
      # "Sweep"-Phase:
        # the CONSes and similar (objects with 2 pointers) are compacted.
        # the destinations of the objects of variable length for phase 4
        # are calculated and stored.
        # SUBRs and fixed symbols (they are all active) are unmarked first:
          unmark_fixed_varobjects();
        #ifndef MORRIS_GC
        # compact CONS-cells:
          for_each_cons_page(page, { gc_compact_cons_page(page); } );
        #endif
        # prepare objects of variable length for compactification below:
          #ifdef SPVW_PURE
          #ifdef GENERATIONAL_GC
          if (generation == 0)
            { for_each_varobject_heap(heap,
                { if (heap->heap_gen0_end < heap->heap_gen1_start)
                    # Luecke    durch  einen Pointer     ueberspringen
                    # (gap n)  (by p)  (a)  (pointer n)  (skip v)
                    # skip gap by/with a pointer (??, translation unclear)
                    { var aint tmp =
                        gc_sweep1_varobject_page(heapnr,
                                                 heap->heap_gen0_start,heap->heap_gen0_end,
                                                 &heap->pages.page_gcpriv.firstmarked,
                                                 heap->heap_gen0_start);
                      var aint gen0_end = heap->heap_gen0_end;
                      heap->heap_gen0_end = heap->heap_gen1_start; # temporary - for handle_fault() if SELFMADE_MMAP
                      gc_sweep1_varobject_page(heapnr,
                                               heap->heap_gen1_start,heap->heap_end,
                                               (object*)gen0_end,
                                               tmp);
                      heap->heap_gen0_end = gen0_end; # temporary - end
                    }
                    else
                    # no gap
                    { gc_sweep1_varobject_page(heapnr,
                                               heap->heap_gen0_start,heap->heap_end,
                                               &heap->pages.page_gcpriv.firstmarked,
                                               heap->heap_gen0_start);
                    }
                });
            }
            else
          #endif
          for_each_varobject_page(page,
            { gc_sweep1_varobject_page(heapnr,
                                       page->page_start,page->page_end,
                                       &page->page_gcpriv.firstmarked,
                                       page->page_start);
            });
          #else # SPVW_MIXED
          #ifdef GENERATIONAL_GC
          if (generation == 0)
            { for_each_varobject_heap(heap,
                { if (heap->heap_gen0_end < heap->heap_gen1_start)
                    # Luecke durch einen Pointer ueberspringen
                    # skip gap by/with a pointer (??, translation unclear)
                    { var aint tmp =
                        gc_sweep1_varobject_page(heap->heap_gen0_start,heap->heap_gen0_end,
                                                 &heap->pages.page_gcpriv.firstmarked,
                                                 heap->heap_gen0_start);
                      gc_sweep1_varobject_page(heap->heap_gen1_start,heap->heap_end,
                                               (object*)(heap->heap_gen0_end),
                                               tmp);
                    }
                    else
                    # no gap
                    { gc_sweep1_varobject_page(heap->heap_gen0_start,heap->heap_end,
                                               &heap->pages.page_gcpriv.firstmarked,
                                               heap->heap_gen0_start);
                    }
                });
            }
            else
            for_each_varobject_page(page,
              { gc_sweep1_varobject_page(page->page_start,page->page_end,
                                         &page->page_gcpriv.firstmarked,
                                         page->page_start);
              });
          #else
          for_each_varobject_page(page, { gc_sweep1_varobject_page(page); } );
          #endif
          #endif
      # Now all active objects are prepared for update:
      # For active objects of variable length A2, (A2).L is the address,
      # where the object will be situated after the GC (incl. Typeinfo and
      # mark bit and poss. symbol-flags).
      # For active two-pointer-objects A2, A2 either remains
      # (then the mark bit in (A2) is deleted), or A2 is relocated
      # (then (A2).L is the new address, without typeinfo, but incl.
      # mark bit).
      # update phase:
        # The entire LISP-memory is perused and old addresses
        # are replaced with new ones.
        #ifdef MORRIS_GC
        for_each_cons_page(page, { gc_morris1(page); } );
        #endif
        # peruse all LISP-objects and update:
          # Update pointers in all LISP-stacks:
            update_STACKs();
          # Update weak-pointers:
            update_weakpointers_mod();
          # Update weak kvtables:
            update_weakkvtables_mod();
          # update program constants:
            update_tables();
          #ifndef MORRIS_GC
          # update pointers in the Cons-cells:
            #define update_conspage  update_conspage_normal
            update_conses();
            #undef update_conspage
          #endif
          # update the pointers in the objects of variable length:
            #define update_page(page,updater)  \
              { var aint ptr = (aint)pointer_was_object(page->page_gcpriv.firstmarked); \
                var aint ptrend = page->page_end;                           \
                # peruse all objects with address >=ptr, <ptrend :          \
                until (ptr==ptrend) # until ptr has reached the end         \
                  { # peruse next object with address ptr (< ptrend) :      \
                    if (marked(ptr)) # marked?                              \
                      # take typeinfo without mark bit!                     \
                      { updater(typecode_at(ptr) & ~bit(garcol_bit_t)); }   \
                      else                                                  \
                      # go with pointer (typeinfo=0) to the next marked object \
                      { ptr = (aint)pointer_was_object(*(object*)ptr); }    \
              }   }
            #define update_fpointer_invalid  false
            #define update_fsubr_function false
            #define update_ht_invalid  mark_ht_invalid
            #define update_fp_invalid  mark_fp_invalid
            #define update_fs_function(ptr)
            update_varobjects();
            #undef update_fs_function
            #undef update_fp_invalid
            #undef update_ht_invalid
            #undef update_fsubr_function
            #undef update_fpointer_invalid
            #undef update_page
          #ifdef GENERATIONAL_GC
          # update pointers in the objects of the old generation:
            if (generation > 0)
              { update_old_generation(); }
          #endif
        #ifdef MORRIS_GC
        # finally, the conses are relocated and simultaneously, all
        # pointers to them (at present, maintained in lists!) are updated.
        for_each_cons_page_reversed(page, { gc_morris2(page); } );
        for_each_cons_page(page, { gc_morris3(page); } );
        #endif
      # now, all active objects are provided with correct content (all
      # pointers within point to the correct addresses after the GC).
      # The active two-pointer-objects are already at the right location and
      # unmarked; the objects of variable length are still at the old
      # location and marked, if active.
      # Second SWEEP-phase:
        # The objects of variable length are moved to the previously
        # calculated new locations.
        #if !defined(GENERATIONAL_GC)
        #ifdef SPVW_MIXED
        for_each_varobject_page(page, { gc_sweep2_varobject_page(page); } );
        #else # SPVW_PURE
        for_each_varobject_page(page, { gc_sweep2_varobject_page(page,heapnr); } );
        #endif
        #else # defined(GENERATIONAL_GC)
        { var uintL heapnr;
          for (heapnr=0; heapnr<heapcount; heapnr++)
            { var Heap* heap = &mem.heaps[heapnr];
              if (!is_unused_heap(heapnr))
                { if (is_varobject_heap(heapnr))
                    {
                      #ifdef SPVW_MIXED
                      gc_sweep2_varobject_page(&heap->pages);
                      #else # SPVW_PURE
                      gc_sweep2_varobject_page(&heap->pages,heapnr);
                      #endif
                    }
                  if (generation == 0)
                    { # The remainder forms the new generation 0.
                      #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
                      if (is_cons_heap(heapnr))
                        { var aint start = heap->heap_start;
                          heap->heap_gen0_start = start;
                          start = start & -physpagesize;
                          heap->heap_start = heap->heap_gen1_end = start;
                        }
                        else
                      #endif
                        { var aint end = heap->heap_end;
                          heap->heap_gen0_end = end;
                          end = (end + (physpagesize-1)) & -physpagesize;
                          heap->heap_gen1_start = heap->heap_end = end;
                        }
                      build_old_generation_cache(heapnr);
                    }
                    else
                    { rebuild_old_generation_cache(heapnr); }
                }
              #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
              if (is_cons_heap(heapnr))
                { heap->heap_end = heap->heap_gen0_end; }
                else
              #endif
                { heap->heap_start = heap->heap_gen0_start; }
        }   }
        #endif
      # Now, all active objects are provided with correct content,
      # at the right location, and unmarked again.
      #ifdef SPVW_PAGES
        { var uintL heapnr;
          for (heapnr=0; heapnr<heapcount; heapnr++)
            { var Pages* heapptr = &mem.heaps[heapnr].inuse;
              AVL_map(*heapptr,page,
                      page->page_room -= page->page_end;
                     );
              # the available space is now stored in page_room again.
              # sort pages according to the available space:
              *heapptr = AVL(AVLID,sort)(*heapptr);
        }   }
        for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
        # treat .reserve??
      #endif
      CHECK_AVL_CONSISTENCY();
      CHECK_GC_CONSISTENCY();
      CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
      CHECK_PACK_CONSISTENCY();
      # end of Garbage Collection.
      #ifdef HAVE_VADVISE
        begin_system_call();
        vadvise(VA_NORM); # no Paging-behaviour becomes normal again
        end_system_call();
      #endif
      inc_gc_count(); # count GCs
      # detect occupied memory:
      #ifdef SPVW_PAGES
      recalc_space(false);
      #endif
      gcend_space = used_space();
      #ifdef SPVW_PAGES
      mem.last_gcend_space = gcend_space;
      # we let the used space grow up to 25%, only then
      # the next GC is triggered:
      { var uintL total_room = floor(mem.last_gcend_space,4);
        if (total_room < 512*1024) { total_room = 512*1024; } # at least 512 KB
        mem.gctrigger_space = mem.last_gcend_space + total_room;
      }
      #endif
      #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
      # make_space() expects, that mem.total_room <= length of the big gap.
      #define set_total_room(space_used_now)  \
        { set_total_room_(space_used_now);                                      \
          if (mem.total_room > mem.conses.heap_start-mem.varobjects.heap_end)   \
            { mem.total_room = mem.conses.heap_start-mem.varobjects.heap_end; } \
        }
      #else
      #define set_total_room  set_total_room_
      #endif
      #if (defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)) && !defined(GENERATIONAL_GC)
      # we let the used space grow by up to 50%, only then
      # the next GC is triggered:
      #define set_total_room_(space_used_now)  \
        { mem.total_room = floor(space_used_now,2); # 50% of the now used space \
          if (mem.total_room < 512*1024) { mem.total_room = 512*1024; } # at least 512 KB \
        }
      set_total_room(gcend_space);
      #endif
      #if defined(GENERATIONAL_GC)
      # we let the used space grow up to 25%, only then
      # the next GC is triggered:
      #define set_total_room_(space_used_now)  \
        { mem.total_room = floor(space_used_now,4); # 25% of the now used space \
          if (mem.total_room < 512*1024) { mem.total_room = 512*1024; } # at least 512 KB \
        }
      { var uintL gen0_sum = 0; # current size of the old generation
        var uintL gen1_sum = 0; # current size of the new generation
        for_each_heap(heap,
          { gen0_sum += heap->heap_gen0_end - heap->heap_gen0_start; });
        #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
        gen1_sum += mem.varobjects.heap_end - mem.varobjects.heap_gen1_start;
        gen1_sum += mem.conses.heap_gen1_end - mem.conses.heap_start;
        #else
        for_each_heap(heap,
          { gen1_sum += heap->heap_end - heap->heap_gen1_start; });
        #endif
        # NB: gcend_space == gen0_sum + gen1_sum.
        set_total_room(gen0_sum);
        mem.last_gcend_space0 = gen0_sum;
        mem.last_gcend_space1 = gen1_sum;
      }
      #endif
      { var uintL freed = gcstart_space - gcend_space; # freed memory
                                                       # by this GC
        inc_gc_space(freed); # add this to the 64-Bit-Accu gc_space
      }
      #ifdef SPVW_PAGES
      free_some_unused_pages();
      #endif
      #if (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)) && defined(VIRTUAL_MEMORY) && defined(HAVE_MUNMAP)
      # free unused, empty pages, so that they do not have to moved
      # by the OS to the swap space:
        begin_system_call();
        #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
        for_each_heap(heap,
          { var aint needed_limit = round_up(heap->heap_end,map_pagesize);
            if (needed_limit > heap->heap_limit)
              abort();
            if (needed_limit < heap->heap_limit)
              { if (munmap((MMAP_ADDR_T)needed_limit,heap->heap_limit-needed_limit) < 0)
                  goto munmap_failure;
                heap->heap_limit = needed_limit;
          }   });
        #else # SPVW_MIXED_BLOCKS_OPPOSITE
        for_each_heap(heap,
          if (is_cons_heap(heapnr))
            { var aint needed_limit = round_down(heap->heap_start,map_pagesize);
              if (needed_limit < heap->heap_limit)
                abort();
              if (needed_limit > heap->heap_limit)
                { if (munmap((MMAP_ADDR_T)heap->heap_limit,needed_limit-heap->heap_limit) < 0)
                    goto munmap_failure;
                  heap->heap_limit = needed_limit;
            }   }
            else
            { var aint needed_limit = round_up(heap->heap_end,map_pagesize);
              if (needed_limit > heap->heap_limit)
                abort();
              if (needed_limit < heap->heap_limit)
                { if (munmap((MMAP_ADDR_T)needed_limit,heap->heap_limit-needed_limit) < 0)
                    goto munmap_failure;
                  heap->heap_limit = needed_limit;
            }   }
          );
        #endif
        if (false) {
         munmap_failure:
          end_system_call();
          asciz_out(GETTEXTL("munmap() failed."));
          errno_out(OS_errno);
          abort();
        }
        end_system_call();
      #endif
      # add time used by this GC to the GC-total-time:
      gc_timer_off();
      #ifdef GC_CLOSES_FILES
      close_some_files(O(files_to_close)); # close previously unmarked files
      O(files_to_close) = NIL;
      #endif
      #ifdef GENERATIONAL_GC
      O(gc_count) = fixnum_inc(O(gc_count),1); # count GCs
      #endif
      gc_signalblock_off(); # release signals again
      clr_break_sem_1(); # allow BREAK again
    }

# end of one Garbage Collection.
# can trigger GC!
  local void gar_col_done (void);
  local void gar_col_done()
    { # perform finalizer-functions:
      until (eq(O(pending_finalizers),Fixnum_0))
        { var object obj = O(pending_finalizers);
          O(pending_finalizers) = TheFinalizer(obj)->fin_cdr;
          pushSTACK(TheFinalizer(obj)->fin_trigger);
          if (!boundp(TheFinalizer(obj)->fin_alive))
            { funcall(TheFinalizer(obj)->fin_function,1); } # (FUNCALL function trigger)
            else
            { pushSTACK(TheFinalizer(obj)->fin_alive);
              funcall(TheFinalizer(obj)->fin_function,2); # (FUNCALL function trigger alive)
        }   }
    }

#ifdef SPVW_PAGES

# a little sorting-routine:
#define SORTID  spvw
#define SORT_ELEMENT  Pages
#define SORT_KEY  uintL
#define SORT_KEYOF(page)  (page)->page_gcpriv.l
#define SORT_COMPARE(key1,key2)  (sintL)((key1)-(key2))
#define SORT_LESS(key1,key2)  ((key1) < (key2))
#include "sort.c"

# list of pages, that have to be freed, as soon as the update
# is completed:
  local var Page* delayed_pages = NULL;
# insertion of a page in this list:
  #define free_page_later(page)  \
    { (page)->page_gcpriv.next = delayed_pages; delayed_pages = page; }
# release of all pages in the list:
  #define free_delayed_pages()  \
    { var Page* page = delayed_pages;                     \
      until (page==NULL)                                  \
        { var Page* next = (Page*)page->page_gcpriv.next; \
          free_page(page);                                \
          page = next;                                    \
        }                                                 \
      delayed_pages = NULL;                               \
    }

# compactification of a page by "decanting" into other pages of the same kind:
  #ifdef SPVW_PURE
  local void gc_compact_from_varobject_page (Heap* heapptr, Page* page, uintL heapnr);
  local void gc_compact_from_varobject_page(heapptr,page,heapnr)
    var Heap* heapptr;
    var Page* page;
    var uintL heapnr;
  #else
  local void gc_compact_from_varobject_page (Heap* heapptr, Page* page);
  local void gc_compact_from_varobject_page(heapptr,page)
    var Heap* heapptr;
    var Page* page;
  #endif
    { var aint p1 = page->page_start;
      var aint p1end = page->page_end;
      var_prepare_objsize;
     {var Pages new_page = EMPTY; # Page, which is being filled
      var AVL(AVLID,stack) stack; # path from the root to the page
      var aint p2; # cache of new_page->page_end
      var uintL l2; # cache of new_page->page_room
      # try to copy all objects between p1 and p1end :
      loop
        { if (p1==p1end) break; # upper bound reached -> finished
         {var uintL laenge = objsize((Varobject)p1); # determine byte-length
          # search a page, that has still 'laenge' free bytes:
          if ((new_page == EMPTY) || (l2 < laenge))
            { if (!(new_page == EMPTY)) # empty cache?
                { new_page->page_end = p2;
                  new_page->page_room = l2;
                  AVL(AVLID,move)(&stack);
                }
              new_page = AVL(AVLID,least)(laenge,&heapptr->inuse,&stack);
              if (new_page==EMPTY) break;
              new_page->page_gcpriv.d = -1L; # mark new_page as "to be filled"
              p2 = new_page->page_end;
              l2 = new_page->page_room;
            }
          {var aint old_p1 = p1;
           var aint old_p2 = p2;
           # copy the object:
           l2 -= laenge; move_aligned_p1_p2(laenge);
           # leave a pointer to the new position:
           *(object*)old_p1 = with_mark_bit(pointer_as_object(old_p2));
           # p1 = source address for the next object
        }}}
      if (!(new_page == EMPTY)) # empty cache?
        { new_page->page_end = p2;
          new_page->page_room = l2;
          AVL(AVLID,move)(&stack);
        }
     }
     # the not copied objects experience a constant shift downward:
     {var aint p2 = page->page_start;
      page->page_gcpriv.d = p1 - p2; # shift
      page->page_start = p1; # current start of the page
      if (!(p1==p2)) # if shift is necessary
        until (p1==p1end) # upper bound reached -> finished
          { var uintL laenge = objsize((Varobject)p1); # calculate byte-length
            #ifdef TYPECODES
            var tint flags = mtypecode(((Varobject)p1)->GCself); # save typeinfo (and flags for symbols) retten
            #endif
            set_GCself(p1, flags,p2); # store new address, with old typeinfo
            mark(p1); # with mark bit
            p1 += laenge; p2 += laenge;
          }
    }}
  local void gc_compact_from_cons_page (Heap* heapptr, Page* page);
  local void gc_compact_from_cons_page(heapptr,page)
    var Heap* heapptr;
    var Page* page;
    { var aint p1 = page->page_end;
      var aint p1start = page->page_start;
     {var Pages new_page = EMPTY; # page, which is filled
      var AVL(AVLID,stack) stack; # path from the root to the page
      var aint p2; # cache of new_page->page_end
      var uintL l2; # cache of new_page->page_room
      # try to copy all objects between p1start and p1:
      loop
        { if (p1==p1start) break; # lower bound reached -> finished
          # search a page, that has at least sizeof(cons_) bytes free:
          if ((new_page == EMPTY) || (l2 == 0)) # l2 < sizeof(cons_) means l2 = 0
            { if (!(new_page == EMPTY)) # empty cache?
                { new_page->page_end = p2;
                  new_page->page_room = l2;
                  AVL(AVLID,move)(&stack);
                }
              new_page = AVL(AVLID,least)(sizeof(cons_),&heapptr->inuse,&stack);
              if (new_page==EMPTY) break;
              new_page->page_gcpriv.d = -1L; # mark new_page as "to be filled"
              p2 = new_page->page_end;
              l2 = new_page->page_room;
            }
          p1 -= sizeof(cons_); # p1 = source address for next object
          # copy the object:
          ((object*)p2)[0] = ((object*)p1)[0];
          ((object*)p2)[1] = ((object*)p1)[1];
          # leave a pointer to the new position:
          *(object*)p1 = with_mark_bit(pointer_as_object(p2));
          p2 += sizeof(cons_); l2 -= sizeof(cons_);
        }
      if (!(new_page == EMPTY)) # empty cache?
        { new_page->page_end = p2;
          new_page->page_room = l2;
          AVL(AVLID,move)(&stack);
        }
     }
     # the not copied objects remain on the spot.
     page->page_gcpriv.d = page->page_end - p1; # gain
     page->page_end = p1; # current end of the page
    }

# compactification of all pages of a certain kind:
  #ifdef SPVW_PURE
  local void gc_compact_heap (Heap* heapptr, sintB heaptype, uintL heapnr);
  local void gc_compact_heap(heapptr,heaptype,heapnr)
    var Heap* heapptr;
    var sintB heaptype;
    var uintL heapnr;
  #else
  local void gc_compact_heap (Heap* heapptr, sintB heaptype);
  local void gc_compact_heap(heapptr,heaptype)
    var Heap* heapptr;
    var sintB heaptype;
  #endif
    { # first, create a list of all pages, sorted ascending
      # according to the number of occupied bytes:
      var uintL pagecount = 0;
      map_heap(*heapptr,page,
               { page->page_gcpriv.l = page->page_end - page->page_start; # number of occupied bytes
                 pagecount++;
               }
              );
      # pagecount = number of pages.
     {var DYNAMIC_ARRAY(pages_sorted,Pages,pagecount);
      {var uintL index = 0;
       map_heap(*heapptr,page, { pages_sorted[index++] = page; } );
      }
      # pages_sorted = Array of pages.
      SORT(SORTID,sort)(pages_sorted,pagecount);
      # pages_sorted = Array of pages, sorted according to number
      # of occupied bytes.
      # In each page, page_gcpriv.d means the shift downwards,
      # that must occur to the page in Phase 3 (>=0).
      # page_gcpriv.d = -1L for the pages to be filled.
      # page_gcpriv.d = -2L for the yet untreated pages.
      map_heap(*heapptr,page, { page->page_gcpriv.d = -2L; } ); # all pages still untreated
      {var uintL index;
       for (index=0; index<pagecount; index++) # peruse all pages
         { var Pages page = pages_sorted[index]; # next page
           if (page->page_gcpriv.d == -2L) # still untreated and
                                           # not yet marked as "to be filled"?
             { # page is being emptied.
               heapptr->inuse = AVL(AVLID,delete1)(page,heapptr->inuse); # take out page
               # empty page:
               if (heaptype==0)
                 { gc_compact_from_cons_page(heapptr,page); }
                 else
                 #ifdef SPVW_PURE
                 { gc_compact_from_varobject_page(heapptr,page,heapnr); }
                 #else
                 { gc_compact_from_varobject_page(heapptr,page); }
                 #endif
      }  }   }
      CHECK_AVL_CONSISTENCY();
      CHECK_GC_CONSISTENCY_2();
      {var uintL index;
       for (index=0; index<pagecount; index++) # peruse all pages
         { var Pages page = pages_sorted[index]; # next page
           if (!(page->page_gcpriv.d == -1L)) # a page to be emptied
             { page->page_room += page->page_gcpriv.d; # room, we have created now
               if (page->page_start == page->page_end)
                 # page completely emptied
                 { # free page:
                   if (page->m_length > min_page_size_brutto)
                     # ultralarge page
                     { free_page_later(page); } # return to OS later
                     else
                     # normal large page
                     { # initialize again (page->page_room remains the same!):
                       page->page_start = page->page_end = page_start0(page);
                       # insert into the pool mem.free_pages:
                       page->page_gcpriv.next = mem.free_pages;
                       mem.free_pages = page;
                 }   }
                 else
                 # Page could not be emptied entirely
                 { heapptr->inuse = AVL(AVLID,insert1)(page,heapptr->inuse); } # insert page again
      }  }   }
      FREE_DYNAMIC_ARRAY(pages_sorted);
      CHECK_AVL_CONSISTENCY();
      CHECK_GC_CONSISTENCY_2();
    }}

# perform compacting Garbage Collection.
# Is called, after gar_col_simple() could not get sufficient room
# in one piece.
# Note: This function does not garbage collect anything; it only reorganizes
# the existing objects in fewer pages. Therefore it does not need to be
# wrapped in with_gc_statistics() calls like do_gar_col_simple and do_gar_col.
  local void gar_col_compact (void);
  local void gar_col_compact()
    { # Lisp-objects from almost empty pages are filled into other pages,
      # in order to return those now empty pages.
      # 1. For each kind of page:
      #    divide pages in pages to be emptied and pages to be filled and
      #    copy as many data as possible from the to be emptied pages into
      #    the pages to be filled. If a page cannot be emptied entirely,
      #    leave it as it is, and within it move the remaining data
      #    just downwards.
      #    return of the completely empty pages.
      # 2. update of pointers.
      # 3. execution of the relocations into the not entirely emptied pages.
      set_break_sem_1(); # disable BREAK during Garbage Collection
      gc_signalblock_on(); # disable signals during Garbage Collection
      gc_timer_on();
      CHECK_GC_UNMARKED(); CHECK_NULLOBJ();
      { var uintL heapnr;
        for (heapnr=0; heapnr<heapcount; heapnr++)
          if (!is_unused_heap(heapnr))
            #ifdef SPVW_PURE
            { gc_compact_heap(&mem.heaps[heapnr],mem.heaptype[heapnr],heapnr); }
            #endif
            #ifdef SPVW_MIXED
            { gc_compact_heap(&mem.heaps[heapnr],1-heapnr); }
            #endif
      }
      # update phase:
        # The entire LISP-memory is perused and old addresses
        # are replaced with new ones.
        # peruse all LISP-objects and update:
          # Update pointers in the LISP-stack:
            update_STACKs();
          # Update weak-pointers:
            update_weakpointers_mod();
          # Update weak kvtables:
            update_weakkvtables_mod();
          # Update program constants:
            update_tables();
          # Update pointers in the cons-cells:
            #define update_conspage  update_conspage_normal
            update_conses();
            #undef update_conspage
          # update pointers in the objects of variable length:
            #define update_page(page,updater)  \
              { var aint ptr = page->page_start;                             \
                var aint ptrend = page->page_end;                            \
                # peruse all objects with address >=ptr, <ptrend :           \
                until (ptr==ptrend) # until ptr has reached the end          \
                  { # peruse next object with address ptr (< ptrend) :       \
                    updater(typecode_at(ptr) & ~bit(garcol_bit_t)); # and advance \
              }   }
            #define update_fpointer_invalid  false
            #define update_fsubr_function false
            #define update_ht_invalid  mark_ht_invalid
            #define update_fp_invalid  mark_fp_invalid
            #define update_fs_function(ptr)
            update_varobjects();
            #undef update_fs_function
            #undef update_fp_invalid
            #undef update_ht_invalid
            #undef update_fsubr_function
            #undef update_fpointer_invalid
            #undef update_page
      # execution of the relocations in the not entirely emptied pages:
        for_each_varobject_page(page,
          { if (!(page->page_gcpriv.d == -1L))
              { var aint p1 = page->page_start;
                var aint p1end = page->page_end;
                var aint p2 = p1 - page->page_gcpriv.d;
                if (!(p1==p2)) # if relocation is necessary
                  { var_prepare_objsize;
                    page->page_start = p2;
                    until (p1==p1end) # upper bound reached -> finished
                      { # next object has address p1, is marked
                        unmark(p1); # delete mark
                        # retain object and relocate:
                       {var uintL count = objsize((Varobject)p1); # length (divisible by varobject_alignment, >0)
                        move_aligned_p1_p2(count); # relocate and advance
                      }}
                    page->page_end = p2;
          }   }   }
          );
      for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
      recalc_space(true);
      free_delayed_pages();
      free_some_unused_pages();
      CHECK_AVL_CONSISTENCY();
      CHECK_GC_CONSISTENCY();
      CHECK_GC_UNMARKED(); CHECK_NULLOBJ();
      CHECK_PACK_CONSISTENCY();
      gc_timer_off();
      gc_signalblock_off(); # release signals again
      clr_break_sem_1(); # allow BREAK again
    }

#endif

# perform Garbage Collection:
  local void gar_col_simple (void);
  local void do_gar_col_simple (void);
  local void do_gar_col_simple()
    {
      #ifdef NOCOST_SP_CHECK
      # Better flag a stack overflow before GC than during GC. (If the
      # stack overflow handler is called during GC, a crash is unavoidable.)
      if (near_SP_overflow()) SP_ueber();
      #endif
      #if !defined(GENERATIONAL_GC)
      gar_col_normal();
      #ifdef SPVW_PAGES
      #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32)
      # if the allocated, but unoccupied memory in pages
      # comprises more than 25% of what is occupied, compactification
      # is worthwhile, because a half-empty page costs the
      # operating system just as much as a full page:
      if (free_space() > floor(mem.last_gcend_space,4))
        { gar_col_compact(); mem.last_gc_compacted = true; }
        else
      #endif
        { mem.last_gc_compacted = false; }
      #endif
      #else # defined(GENERATIONAL_GC)
      # If after the last GC the objects in the new generation
      # amount to more than 25% of the objects in the old generation,
      # then we will perform a full Garbage-Collection this time (both
      # generations at once.)
      if (mem.last_gcend_space1 > floor(mem.last_gcend_space0,4))
        { generation = 0; gar_col_normal(); mem.last_gc_full = true; }
        else
        { generation = 1; gar_col_normal(); mem.last_gc_full = false; }
      #endif
      gar_col_done();
    }
  local void gar_col_simple()
    { var uintC saved_mv_count = mv_count; # save mv_count
      pushSTACK(subr_self); # save subr_self
      with_gc_statistics(&do_gar_col_simple); # GC and statistics
      subr_self = popSTACK(); # restore subr_self
      mv_count = saved_mv_count; # restore mv_count
    }

# perform full Garbage Collection:
  global void gar_col (void);
  local void do_gar_col (void);
  local void do_gar_col()
    {
      #ifdef NOCOST_SP_CHECK
      # Better flag a stack overflow before GC than during GC. (If the
      # stack overflow handler is called during GC, a crash is unavoidable.)
      if (near_SP_overflow()) SP_ueber();
      #endif
      #if !defined(GENERATIONAL_GC)
      gar_col_normal();
      #ifdef SPVW_PAGES
      gar_col_compact(); mem.last_gc_compacted = true;
      #endif
      #else # defined(GENERATIONAL_GC)
      generation = 0; gar_col_normal(); mem.last_gc_full = true;
      #endif
      gar_col_done();
    }
  global void gar_col()
    { var uintC saved_mv_count = mv_count; # save mv_count
      pushSTACK(subr_self); # save subr_self
      with_gc_statistics(&do_gar_col); # GC and statistics
      subr_self = popSTACK(); # restore subr_self
      mv_count = saved_mv_count; # restore mv_count
    }

# Macro update is now unnecessary:
  #undef update_stackobj
  #undef update

#if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && RESERVE

# For Reorganization of the object memory after GC or before and after EXECUTE:
  # sub-program for relocation of the conses.
  # move_conses(delta);
  # the reserve memory is shrinked by delta bytes (divisible by
  # varobject_alignment), the conses are shifted upwards by delta bytes.
  local void move_conses (sintL delta);
  local void move_conses (delta)
    var sintL delta;
    { if (delta==0) return; # no relocation necessary?
      set_break_sem_1(); # disable BREAK
      gc_signalblock_on(); # disable signals
      gc_timer_on();
      if (delta>0)
        # shift upwards, from above
        { var object* source = (object*) mem.conses.heap_end;
          var object* source_end = (object*) mem.conses.heap_start;
          #if !(defined(MIPS) && !defined(GNU))
          var object* dest = (object*) (mem.conses.heap_end += delta);
          #else # circumvent IRIX 4 "cc -ansi" compiler-bug??
          var object* dest = (mem.conses.heap_end += delta, (object*)mem.conses.heap_end);
          #endif
          mem.conses.heap_start += delta;
          until (source==source_end)
            { *--dest = *--source; # copy an entire cons upwards
              *--dest = *--source;
        }   }
        else # delta<0
        # shift downwards, from below
        { var object* source = (object*) mem.conses.heap_start;
          var object* source_end = (object*) mem.conses.heap_end;
          #if !(defined(MIPS) && !defined(GNU))
          var object* dest = (object*) (mem.conses.heap_start += delta);
          #else # circumvent IRIX 4 "cc -ansi" compiler-bug??
          var object* dest = (mem.conses.heap_start += delta, (object*)mem.conses.heap_start);
          #endif
          mem.conses.heap_end += delta;
          until (source==source_end)
            { *dest++ = *source++; # copy an entire cons downwards
              *dest++ = *source++;
        }   }
      # update pointers to conses and similar:
      { var soint odelta = (soint)delta<<(oint_addr_shift-addr_shift); # Offset in the oint
        # The entire LISP-memory is perused and old addresses
        # are replaced with new ones.
        # update of an object *objptr :
          #ifdef TYPECODES
            #define update(objptr)  \
              { switch (mtypecode(*(object*)(objptr)))                        \
                  { case_pair: # Two-Pointer-Object?                          \
                      *(object*)(objptr) = as_object(as_oint(*(object*)(objptr)) + odelta); \
                      break;                                                  \
                    default: break;                                           \
              }   }
          #else
            #define update(objptr)  \
              { if (consp(*(object*)(objptr)))                                \
                  *(object*)(objptr) = as_object(as_oint(*(object*)(objptr)) + odelta); \
              }
          #endif
        # peruse all LISP-objects and update:
          # Update pointers in all LISP-stacks:
            #define update_stackobj  update_stackobj_normal
            update_STACKs();
            #undef update_stackobj
          # Update weak-pointers:
            update_weakpointers_mod();
          # Update weak kvtables:
            update_weakkvtables_mod();
          # update program constants:
            update_tables();
          # update pointers in the Cons-cells:
            #define update_conspage  update_conspage_normal
            update_conses();
            #undef update_conspage
          # update pointers in the objects of variable length:
            #define update_page  update_page_normal
            #define update_fpointer_invalid  false
            #define update_fsubr_function  false
            #define update_ht_invalid  mark_ht_invalid
            #define update_fp_invalid  mark_fp_invalid
            #define update_fs_function(ptr)
            update_varobjects();
            #undef update_fs_function
            #undef update_fp_invalid
            #undef update_ht_invalid
            #undef update_fsubr_function
            #undef update_fpointer_invalid
            #undef update_page
        # Macro update is now unnecessary:
          #undef update
      }
      # End of relocation and update.
      # add needed time to GC-total-time:
      gc_timer_off();
      gc_signalblock_off(); # release signals again
      clr_break_sem_1(); # allow BREAK again
    }

#endif
