source: branches/ia32/lisp-kernel/x86-gc.c @ 9468

/*
   Copyright (C) 1994-2001 Digitool, Inc
   This file is part of OpenMCL.  

   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
   License , known as the LLGPL and distributed with OpenMCL as the
   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
   which is distributed with OpenMCL as the file "LGPL".  Where these
   conflict, the preamble takes precedence.  

   OpenMCL is referenced in the preamble as the "LIBRARY."

   The LLGPL is also available online at
   http://opensource.franz.com/preamble.html
*/

#include "lisp.h"
#include "lisp_globals.h"
#include "bits.h"
#include "gc.h"
#include "area.h"
#include "Threads.h"
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <sys/time.h>

#ifndef timeradd
# define timeradd(a, b, result)                                               \
  do {                                                                        \
    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
    if ((result)->tv_usec >= 1000000)                                         \
      {                                                                       \
        ++(result)->tv_sec;                                                   \
        (result)->tv_usec -= 1000000;                                         \
      }                                                                       \
  } while (0)
#endif
#ifndef timersub
# define timersub(a, b, result)                                               \
  do {                                                                        \
    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
    if ((result)->tv_usec < 0) {                                              \
      --(result)->tv_sec;                                                     \
      (result)->tv_usec += 1000000;                                           \
    }                                                                         \
  } while (0)
#endif

void
comma_output_decimal(char *buf, int len, natural n) 
{
  int nout = 0;

  buf[--len] = 0;
  do {
    buf[--len] = n%10+'0';
    n = n/10;
    if (n == 0) {
      while (len) {
        buf[--len] = ' ';
      }
      return;
    }
    if (len == 0) return;
    nout ++;
    if (nout == 3) {
      buf[--len] = ',';
      nout = 0;
    }
  } while (len >= 0);
}


/* Heap sanity checking. */

void
check_node(LispObj n)
{
  int tag = fulltag_of(n), header_tag;
  area *a;
  LispObj header;

  if (n == (n & 0xff)) {
    return;
  }

  switch (tag) {
  case fulltag_even_fixnum:
  case fulltag_odd_fixnum:
#ifdef X8632
  case fulltag_imm:
#endif
#ifdef X8664
  case fulltag_imm_0:
  case fulltag_imm_1:
#endif
    return;

#ifdef X8664
  case fulltag_nil:
    if (n != lisp_nil) {
      Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n);
    }
    return;
#endif

#ifdef X8632
  case fulltag_nodeheader:
  case fulltag_immheader:
#endif
#ifdef X8664
  case fulltag_nodeheader_0: 
  case fulltag_nodeheader_1: 
  case fulltag_immheader_0: 
  case fulltag_immheader_1: 
  case fulltag_immheader_2: 
#endif
    Bug(NULL, "Header not expected : 0x%lx", n);
    return;

#ifdef X8632
  case fulltag_tra:
#endif
#ifdef X8664
  case fulltag_tra_0:
  case fulltag_tra_1:
#endif
    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
    if (a == NULL) {
      a = active_dynamic_area;
      if ((n > (ptr_to_lispobj(a->active))) &&
          (n < (ptr_to_lispobj(a->high)))) {
        Bug(NULL, "TRA points to heap free space: 0x%lx", n);
      }
      return;
    }
    /* tra points into the heap.  Check displacement, then
       check the function it (should) identify.
    */
#ifdef X8632
    {
      LispObj fun = 0;

      if (*(unsigned char *)n == RECOVER_FN_OPCODE)
        fun = *(LispObj *)(n + 1);
      if (fun == 0 ||
         (header_subtag(header_of(fun)) != subtag_function) ||
         (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) {
        Bug(NULL, "TRA at 0x%x has bad function address 0x%x\n", n, fun);
      }
      n = fun;
    }
#endif
#ifdef X8664
    {
      int disp = 0;
      LispObj m = n;

      if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
          (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
        disp = (*(int *) (n+3));
        n = RECOVER_FN_FROM_RIP_LENGTH+m+disp;
      }
      if ((disp == 0) ||
          (fulltag_of(n) != fulltag_function) ||
          (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) {
        Bug(NULL, "TRA at 0x%lx has bad displacement %d\n", n, disp);
      }
    }
#endif
    /* Otherwise, fall through and check the header on the function
       that the tra references */

  case fulltag_misc:
  case fulltag_cons:
#ifdef X8664
  case fulltag_symbol:
  case fulltag_function:
#endif
    a = heap_area_containing((BytePtr)ptr_from_lispobj(n));
    
    if (a == NULL) {
      /* Can't do as much sanity checking as we'd like to
         if object is a defunct stack-consed object.
         If a dangling reference to the heap, that's
         bad .. */
      a = active_dynamic_area;
      if ((n > (ptr_to_lispobj(a->active))) &&
          (n < (ptr_to_lispobj(a->high)))) {
        Bug(NULL, "Node points to heap free space: 0x%lx", n);
      }
      return;
    }
    break;
  }
  /* Node points to heap area, so check header/lack thereof. */
  header = header_of(n);
  header_tag = fulltag_of(header);
  if (tag == fulltag_cons) {
    if ((nodeheader_tag_p(header_tag)) ||
        (immheader_tag_p(header_tag))) {
      Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header);
    }
    return;
  }

  if ((!nodeheader_tag_p(header_tag)) &&
      (!immheader_tag_p(header_tag))) {
    Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header);
  }
  return;
}

void
check_all_mark_bits(LispObj *nodepointer) 
{
}


Boolean GCDebug = true, GCverbose = true;



void
check_range(LispObj *start, LispObj *end, Boolean header_allowed)
{
  LispObj node, *current = start, *prev;
  int tag;
  natural elements;

  while (current < end) {
    prev = current;
    node = *current++;
    tag = fulltag_of(node);
    if (immheader_tag_p(tag)) {
      if (! header_allowed) {
        Bug(NULL, "Header not expected at 0x%lx\n", prev);
      }
      current = (LispObj *)skip_over_ivector((natural)prev, node);
    } else if (nodeheader_tag_p(tag)) {
      if (! header_allowed) {
        Bug(NULL, "Header not expected at 0x%lx\n", prev);
      }
      elements = header_element_count(node) | 1;
      if (header_subtag(node) == subtag_function) {
#ifdef X8632
        int skip = *(unsigned short *)current;
#else
        int skip = *(int *)current;
#endif
        current += skip;
        elements -= skip;
      }
      while (elements--) {
        check_node(*current++);
      }
    } else {
      check_node(node);
      check_node(*current++);
    }
  }

  if (current != end) {
    Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x",
        start, end, prev, current);
  }
}

void
check_all_areas()
{
  area *a = active_dynamic_area;
  area_code code = a->code;

  while (code != AREA_VOID) {
    switch (code) {
    case AREA_DYNAMIC:
    case AREA_STATIC:
    case AREA_MANAGED_STATIC:
      check_range((LispObj *)a->low, (LispObj *)a->active, true);
      break;

    case AREA_VSTACK:
      {
        LispObj* low = (LispObj *)a->active;
        LispObj* high = (LispObj *)a->high;
        
        if (((natural)low) & node_size) {
          check_node(*low++);
        }
        check_range(low, high, false);
      }
      break;

    case AREA_TSTACK:
      {
        LispObj *current, *next,
                *start = (LispObj *) a->active,
                *end = start,
                *limit = (LispObj *) a->high;
                 
        for (current = start;
             end != limit;
             current = next) {
          next = ptr_from_lispobj(*current);
          end = ((next >= start) && (next < limit)) ? next : limit;
          check_range(current+2, end, true);
        }
      }
      break;
    }
    a = a->succ;
    code = (a->code);
  }
}

natural
static_dnodes_for_area(area *a)
{
  if (a->low == tenured_area->low) {
    return tenured_area->static_dnodes;
  }
  return 0;
}







bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
LispObj GCarealow, GCareadynamiclow;
natural GCndnodes_in_area, GCndynamic_dnodes_in_area;
LispObj GCweakvll = (LispObj)NULL;
LispObj GCephemeral_low;
natural GCn_ephemeral_dnodes;


/* Sooner or later, this probably wants to be in assembler */
/* Return false if n is definitely not an ephemeral node, true if
   it might be */
void
mark_root(LispObj n)
{
  int tag_n = fulltag_of(n);
  natural dnode, bits, *bitsp, mask;

  if (!is_node_fulltag(tag_n)) {
    return;
  }

#ifdef X8632
  if (tag_n == fulltag_tra) {
    if (*(unsigned char *)n == RECOVER_FN_OPCODE) {
      n = *(LispObj *)(n + 1);
      tag_n = fulltag_misc;
    } else
      return;
  }
#endif
#ifdef X8664
  if (tag_of(n) == tag_tra) {
    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
      int sdisp = (*(int *) (n+3));
      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
      tag_n = fulltag_function;
    }
    else {
      return;
    }
  }
#endif


  dnode = gc_area_dnode(n);
  if (dnode >= GCndnodes_in_area) {
    return;
  }
  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
  if (bits & mask) {
    return;
  }
  *bitsp = (bits | mask);

  if (tag_n == fulltag_cons) {
    cons *c = (cons *) ptr_from_lispobj(untag(n));

    rmark(c->car);
    rmark(c->cdr);
    return;
  }
  {
    LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
    natural
      header = *((natural *) base),
      subtag = header_subtag(header),
      element_count = header_element_count(header),
      total_size_in_bytes,      /* including 4/8-byte header */
      suffix_dnodes;
    natural prefix_nodes = 0;

    tag_n = fulltag_of(header);

#ifdef X8664
    if ((nodeheader_tag_p(tag_n)) ||
        (tag_n == ivector_class_64_bit)) {
      total_size_in_bytes = 8 + (element_count<<3);
    } else if (tag_n == ivector_class_32_bit) {
      total_size_in_bytes = 8 + (element_count<<2);
    } else {
      /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */
      if (subtag == subtag_bit_vector) {
        total_size_in_bytes = 8 + ((element_count+7)>>3);
      } else if (subtag >= min_8_bit_ivector_subtag) {
        total_size_in_bytes = 8 + element_count;
      } else {
        total_size_in_bytes = 8 + (element_count<<1);
      }
    }
#endif
#ifdef X8632
    if ((tag_n == fulltag_nodeheader) ||
        (subtag <= max_32_bit_ivector_subtag)) {
      total_size_in_bytes = 4 + (element_count<<2);
    } else if (subtag <= max_8_bit_ivector_subtag) {
      total_size_in_bytes = 4 + element_count;
    } else if (subtag <= max_16_bit_ivector_subtag) {
      total_size_in_bytes = 4 + (element_count<<1);
    } else if (subtag == subtag_double_float_vector) {
      total_size_in_bytes = 8 + (element_count<<3);
    } else {
      total_size_in_bytes = 4 + ((element_count+7)>>3);
    }
#endif


    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1;

    if (suffix_dnodes) {
      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
    }

    if (nodeheader_tag_p(tag_n)) {
      if (subtag == subtag_hash_vector) {
        /* Don't invalidate the cache here.  It should get
           invalidated on the lisp side, if/when we know
           that rehashing is necessary. */
        LispObj flags = ((hash_table_vector_header *) base)->flags;

        if (flags & nhash_weak_mask) {
          ((hash_table_vector_header *) base)->cache_key = undefined;
          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
        }
        deref(ptr_to_lispobj(base),1) = GCweakvll;
        GCweakvll = n;
        return;
      }

      if (subtag == subtag_pool) {
        deref(ptr_to_lispobj(base), 1) = lisp_nil;
      }
      
      if (subtag == subtag_weak) {
        natural weak_type = (natural) base[2];
        if (weak_type >> population_termination_bit) {
          element_count -= 2;
        } else {
          element_count -= 1;
        }
      }

      if (subtag == subtag_function) {
#ifdef X8632
        prefix_nodes = (natural) ((unsigned short) deref(base,1));
#else
        prefix_nodes = (natural) ((int) deref(base,1));
#endif
        if (prefix_nodes > element_count) {
          Bug(NULL, "Function 0x%lx trashed",n);
        }
      }
      base += (1+element_count);

      element_count -= prefix_nodes;

      while(element_count--) {
        rmark(*--base);
      }
      if (subtag == subtag_weak) {
        deref(ptr_to_lispobj(base),1) = GCweakvll;
        GCweakvll = n;
      }
    }
  }
}


/* 
  This marks the node if it needs to; it returns true if the node
  is either a hash table vector header or a cons/misc-tagged pointer
  to ephemeral space.
  Note that it  might be a pointer to ephemeral space even if it's
  not pointing to the current generation.
*/

Boolean
mark_ephemeral_root(LispObj n)
{
  int tag_n = fulltag_of(n);
  natural eph_dnode;

  if (nodeheader_tag_p(tag_n)) {
    return (header_subtag(n) == subtag_hash_vector);
  }
 
  if (is_node_fulltag (tag_n)) {
    eph_dnode = area_dnode(n, GCephemeral_low);
    if (eph_dnode < GCn_ephemeral_dnodes) {
      mark_root(n);             /* May or may not mark it */
      return true;              /* but return true 'cause it's an ephemeral node */
    }
  }
  return false;                 /* Not a heap pointer or not ephemeral */
}
  


#ifdef X8664
#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */
#define RMARK_PREV_CAR fulltag_nil /* fulltag_nil + node_size. Coincidence ? I think not. */
#else
#define RMARK_PREV_ROOT fulltag_imm
#define RMARK_PREV_CAR fulltag_immheader
#endif

natural
GCstack_limit = 0;

/*
  This wants to be in assembler even more than "mark_root" does.
  For now, it does link-inversion: hard as that is to express in C,
  reliable stack-overflow detection may be even harder ...
*/
void
rmark(LispObj n)
{
  int tag_n = fulltag_of(n);
  bitvector markbits = GCmarkbits;
  natural dnode, bits, *bitsp, mask, original_n = n;

  if (!is_node_fulltag(tag_n)) {
    return;
  }

#ifdef X8632
  if (tag_n == fulltag_tra) {
    if (*(unsigned char *)n == RECOVER_FN_OPCODE) {
      n = *(LispObj *)(n + 1);
      tag_n = fulltag_misc;
    } else {
      return;
    }
  }
#endif
#ifdef X8664
  if (tag_of(n) == tag_tra) {
    if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) &&
        (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
      int sdisp = (*(int *) (n+3));
      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
      tag_n = fulltag_function;
    } else {
      return;
    }
  }
#endif

  dnode = gc_area_dnode(n);
  if (dnode >= GCndnodes_in_area) {
    return;
  }
  set_bits_vars(markbits,dnode,bitsp,bits,mask);
  if (bits & mask) {
    return;
  }
  *bitsp = (bits | mask);

  if (current_stack_pointer() > GCstack_limit) {
    if (tag_n == fulltag_cons) {
      rmark(deref(n,1));
      rmark(deref(n,0));
    } else {
      LispObj *base = (LispObj *) ptr_from_lispobj(untag(n));
      natural
        header = *((natural *) base),
        subtag = header_subtag(header),
        element_count = header_element_count(header),
        total_size_in_bytes,
        suffix_dnodes,
        nmark;

      tag_n = fulltag_of(header);

#ifdef X8664
      if ((nodeheader_tag_p(tag_n)) ||
          (tag_n == ivector_class_64_bit)) {
        total_size_in_bytes = 8 + (element_count<<3);
      } else if (tag_n == ivector_class_32_bit) {
        total_size_in_bytes = 8 + (element_count<<2);
      } else {
        /* ivector_class_other_bit contains 16-bit arrays & bitvector */
        if (subtag == subtag_bit_vector) {
          total_size_in_bytes = 8 + ((element_count+7)>>3);
        } else if (subtag >= min_8_bit_ivector_subtag) {
          total_size_in_bytes = 8 + element_count;
        } else {
          total_size_in_bytes = 8 + (element_count<<1);
        }
      }
#else
      if ((tag_n == fulltag_nodeheader) ||
          (subtag <= max_32_bit_ivector_subtag)) {
        total_size_in_bytes = 4 + (element_count<<2);
      } else if (subtag <= max_8_bit_ivector_subtag) {
        total_size_in_bytes = 4 + element_count;
      } else if (subtag <= max_16_bit_ivector_subtag) {
        total_size_in_bytes = 4 + (element_count<<1);
      } else if (subtag == subtag_double_float_vector) {
        total_size_in_bytes = 8 + (element_count<<3);
      } else {
        total_size_in_bytes = 4 + ((element_count+7)>>3);
      }
#endif

      suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;

      if (suffix_dnodes) {
        set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
      }

      if (!nodeheader_tag_p(tag_n)) return;

      if (subtag == subtag_hash_vector) {
        /* Splice onto weakvll, then return */
        /* In general, there's no reason to invalidate the cached
           key/value pair here.  However, if the hash table's weak,
           we don't want to retain an otherwise unreferenced key
           or value simply because they're referenced from the
           cache.  Clear the cached entries iff the hash table's
           weak in some sense.
        */
        LispObj flags = ((hash_table_vector_header *) base)->flags;

        if (flags & nhash_weak_mask) {
          ((hash_table_vector_header *) base)->cache_key = undefined;
          ((hash_table_vector_header *) base)->cache_value = lisp_nil;
        }
        deref(ptr_to_lispobj(base),1) = GCweakvll;
        GCweakvll = n;
        return;
      }

      if (subtag == subtag_pool) {
        deref(n, 1) = lisp_nil;
      }

      if (subtag == subtag_weak) {
        natural weak_type = (natural) base[2];
        if (weak_type >> population_termination_bit)
          element_count -= 2;
        else
          element_count -= 1;
      }

      nmark = element_count;

      if (subtag == subtag_function) {
#ifdef X8664
        int code_words = (int)base[1];
#else
        int code_words = (unsigned short)base[1];
#endif
        if (code_words >= nmark) {
          Bug(NULL,"Bad function at 0x%lx",n);
        }
        nmark -= code_words;
      }

      while (nmark--) {
        rmark(deref(n,element_count));
        element_count--;
      }

      if (subtag == subtag_weak) {
        deref(n, 1) = GCweakvll;
        GCweakvll = n;
      }

    }
  } else {
#ifdef X8632
    fprintf(stderr, "probably in trouble here\n");
#endif
    /* This is all a bit more complicated than the PPC version:

       - a symbol-vector can be referenced via either a FULLTAG-MISC
       pointer or a FULLTAG-SYMBOL pointer.  When we've finished
       marking the symbol-vector's elements, we need to know which tag
       the object that pointed to the symbol-vector had originally.

       - a function-vector can be referenced via either a FULLTAG-MISC
       pointer or a FULLTAG-FUNCTION pointer.  That introduces pretty
       much the same set of issues, but ...

       - a function-vector can also be referenced via a TRA; the
       offset from the TRA to the function header is arbitrary (though
       we can probably put an upper bound on it, and it's certainly
       not going to be more than 32 bits.)

       - function-vectors contain a mixture of code and constants,
       with a "boundary" word (that doesn't look like a valid
       constant) in between them.  There are 56 unused bits in the
       boundary word; the low 8 bits must be = to the constant
       'function_boundary_marker'.  We can store the byte displacement
       from the address of the object which references the function
       (tagged fulltag_misc, fulltag_function, or tra) to the address
       of the boundary marker when the function vector is first marked
       and recover that offset when we've finished marking the
       function vector.  (Note that the offset is signed; it's
       probably simplest to keep it in the high 32 bits of the
       boundary word.) 

 So:

       - while marking a CONS, the 'this' pointer as a 3-bit tag of
       tag_list; the 4-bit fulltag indicates which cell is being
       marked.

       - while marking a gvector (other than a symbol-vector or
       function-vector), the 'this' pointer is tagged tag_misc.
       (Obviously, it alternates between fulltag_misc and
       fulltag_nodeheader_0, arbitrarily.)  When we encounter the
       gvector header when the 'this' pointer has been tagged as
       fulltag_misc, we can restore 'this' to the header's address +
       fulltag_misc and enter the 'climb' state.  (Note that this
       value happens to be exactly what's in 'this' when the header's
       encountered.)

       - if we encounter a symbol-vector via the FULLTAG-MISC pointer
       to the symbol (not very likely, but legal and possible), it's
       treated exactly like the gvector case above.

       - in the more likely case where a symbol-vector is referenced
       via a FULLTAG-SYMBOL, we do the same loop as in the general
       gvector case, backing up through the vector with 'this' tagged
       as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter
       the symbol header, 'this' gets fulltag_symbol added to the
       dnode-aligned address of the header, and we climb.

       - if anything (fulltag_misc, fulltag_function, tra) references
       an unmarked function function vector, we store the byte offfset
       from the tagged reference to the address of the boundary word
       in the high 32 bits of the boundary word, then we back up
       through the function-vector's constants, with 'this' tagged
       tag_function/ fulltag_immheader_0, until the (specially-tagged)
       boundary word is encountered.  The displacement stored in the boundary
       word is added to the aligned address of the  boundary word (restoring
       the original 'this' pointer, and we climb.

       Not that bad.
    */
       
    LispObj prev = undefined, this = n, next, *base;
    natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary;

    if (tag_n == fulltag_cons) goto MarkCons;
    goto MarkVector;

  ClimbCdr:
    prev = deref(this,0);
    deref(this,0) = next;

  Climb:
    next = this;
    this = prev;
    tag_n = fulltag_of(prev);
    switch(tag_n) {
    case tag_misc:
    case fulltag_misc:
#ifdef X8664
    case tag_symbol:
    case fulltag_symbol:
    case tag_function:
    case fulltag_function:
#endif
      goto ClimbVector;

    case RMARK_PREV_ROOT:
      return;

    case fulltag_cons:
      goto ClimbCdr;

    case RMARK_PREV_CAR:
      goto ClimbCar;

      /* default: abort() */
    }

  DescendCons:
    prev = this;
    this = next;

  MarkCons:
    next = deref(this,1);
    this += node_size;
    tag_n = fulltag_of(next);
    if (!is_node_fulltag(tag_n)) goto MarkCdr;
    dnode = gc_area_dnode(next);
    if (dnode >= GCndnodes_in_area) goto MarkCdr;
    set_bits_vars(markbits,dnode,bitsp,bits,mask);
    if (bits & mask) goto MarkCdr;
    *bitsp = (bits | mask);
    deref(this,1) = prev;
    if (tag_n == fulltag_cons) goto DescendCons;
    goto DescendVector;

  ClimbCar:
    prev = deref(this,1);
    deref(this,1) = next;

  MarkCdr:
    next = deref(this, 0);
    this -= node_size;
    tag_n = fulltag_of(next);
    if (!is_node_fulltag(tag_n)) goto Climb;
    dnode = gc_area_dnode(next);
    if (dnode >= GCndnodes_in_area) goto Climb;
    set_bits_vars(markbits,dnode,bitsp,bits,mask);
    if (bits & mask) goto Climb;
    *bitsp = (bits | mask);
    deref(this, 0) = prev;
    if (tag_n == fulltag_cons) goto DescendCons;
    /* goto DescendVector; */

  DescendVector:
    prev = this;
    this = next;

  MarkVector:
#ifdef X8664
    if ((tag_n == fulltag_tra_0) ||
        (tag_n == fulltag_tra_1)) {
      int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH;

      base = (LispObj *) (untag(n-disp));
      header = *((natural *) base);
      subtag = header_subtag(header);
      boundary = base + (int)(base[1]);
      (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
      this = (LispObj)(base)+fulltag_function;
      /* Need to set the initial markbit here */
      dnode = gc_area_dnode(this);
      set_bit(markbits,dnode);
    } else {
      base = (LispObj *) ptr_from_lispobj(untag(this));
      header = *((natural *) base);
      subtag = header_subtag(header);
      if (subtag == subtag_function) {
        boundary = base + (int)(base[1]);
        (((int *)boundary)[1]) = (int)(this-((LispObj)boundary));
      }
    }
    element_count = header_element_count(header);
    tag_n = fulltag_of(header);

    if ((nodeheader_tag_p(tag_n)) ||
        (tag_n == ivector_class_64_bit)) {
      total_size_in_bytes = 8 + (element_count<<3);
    } else if (tag_n == ivector_class_32_bit) {
      total_size_in_bytes = 8 + (element_count<<2);
    } else {
      /* ivector_class_other_bit contains 16-bit arrays & bitvector */
      if (subtag == subtag_bit_vector) {
        total_size_in_bytes = 8 + ((element_count+7)>>3);
      } else if (subtag >= min_8_bit_ivector_subtag) {
        total_size_in_bytes = 8 + element_count;
      } else {
        total_size_in_bytes = 8 + (element_count<<1);
      }
    }
#else
    if (tag_n == fulltag_tra) {
      LispObj fn = *(LispObj *)(n + 1);

      base = (LispObj *)untag(fn);
      header = *(natural *)base;
      subtag = header_subtag(header);
      boundary = base + (unsigned short)base[1];
      /*
       * On x8632, the upper 24 bits of the boundary word are zero.
       * Functions on x8632 can be no more than 2^16 words (or 2^24
       * bytes) long (including the self-reference table but excluding
       * any constants).  Therefore, we can do the same basic thing
       * that the x8664 port does: namely, we keep the byte
       * displacement from the address of the object (tagged tra or
       * fulltag_misc) that references the function to the address of
       * the boundary marker in those 24 bits, recovering it when
       * we've finished marking the function vector.
       */
      ((int *)boundary)[1] &= 0xff;
      ((int *)boundary)[1] |= (this-(LispObj)boundary) << 8;
      this = (LispObj)(base)+fulltag_misc;
      dnode = gc_area_dnode(this);
      set_bit(markbits,dnode);
    } else {
      base = (LispObj *) ptr_from_lispobj(untag(this));
      header = *((natural *) base);
      subtag = header_subtag(header);
      if (subtag == subtag_function) {
        boundary = base + (unsigned short)base[1];
        ((int *)boundary)[1] &= 0xff;
        ((int *)boundary)[1] |= (this-((LispObj)boundary)) << 8;
      }
    }
    element_count = header_element_count(header);
    tag_n = fulltag_of(header);

    if ((tag_n == fulltag_nodeheader) ||
        (subtag <= max_32_bit_ivector_subtag)) {
      total_size_in_bytes = 4 + (element_count<<2);
    } else if (subtag <= max_8_bit_ivector_subtag) {
      total_size_in_bytes = 4 + element_count;
    } else if (subtag <= max_16_bit_ivector_subtag) {
      total_size_in_bytes = 4 + (element_count<<1);
    } else if (subtag == subtag_double_float_vector) {
      total_size_in_bytes = 8 + (element_count<<3);
    } else {
      total_size_in_bytes = 4 + ((element_count+7)>>3);
    }
#endif

    suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1;
    
    if (suffix_dnodes) {
      set_n_bits(GCmarkbits, dnode+1, suffix_dnodes);
    }
    
    if (!nodeheader_tag_p(tag_n)) goto Climb;
    
    if (subtag == subtag_hash_vector) {
      /* Splice onto weakvll, then climb */
      LispObj flags = ((hash_table_vector_header *) base)->flags;
      
      if (flags & nhash_weak_mask) {
        ((hash_table_vector_header *) base)->cache_key = undefined;
        ((hash_table_vector_header *) base)->cache_value = lisp_nil;
      }

      deref(ptr_to_lispobj(base),1) = GCweakvll;
      GCweakvll = this;
      goto Climb;
    }

    if (subtag == subtag_pool) {
      deref(this, 1) = lisp_nil;
    }

    if (subtag == subtag_weak) {
      natural weak_type = (natural) base[2];
      if (weak_type >> population_termination_bit)
        element_count -= 2;
      else
        element_count -= 1;
    }

    this = (LispObj)(base) + (tag_of(this))  + ((element_count+1) << node_shift);
    goto MarkVectorLoop;

  ClimbVector:
    prev = indirect_node(this);
    indirect_node(this) = next;

  MarkVectorLoop:
    this -= node_size;
    next = indirect_node(this);
#ifdef X8664
    if ((tag_of(this) == tag_function) &&
        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
#else
    if ((tag_of(this) == tag_misc) &&
        (header_subtag(this) == subtag_function) &&
        (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone;
#endif

    tag_n = fulltag_of(next);
    if (nodeheader_tag_p(tag_n)) goto MarkVectorDone;
    if (!is_node_fulltag(tag_n)) goto MarkVectorLoop;
    dnode = gc_area_dnode(next);
    if (dnode >= GCndnodes_in_area) goto MarkVectorLoop;
    set_bits_vars(markbits,dnode,bitsp,bits,mask);
    if (bits & mask) goto MarkVectorLoop;
    *bitsp = (bits | mask);
    indirect_node(this) = prev;
    if (tag_n == fulltag_cons) goto DescendCons;
    goto DescendVector;

  MarkVectorDone:
    /* "next" is vector header; "this" tagged tag_misc or tag_symbol.
       If  header subtag = subtag_weak_header, put it on weakvll */
    this += node_size;          /* make it fulltag_misc/fulltag_symbol */

    if (header_subtag(next) == subtag_weak) {
      deref(this, 1) = GCweakvll;
      GCweakvll = this;
    }
    goto Climb;

  MarkFunctionDone:
    boundary = (LispObj *)(node_aligned(this));
#ifdef X8664
    this = ((LispObj)boundary) + (((int *)boundary)[1]);
    (((int *)boundary)[1]) = 0;
#else
    this = ((LispObj)boundary) + ((int *)boundary)[1] >> 8;
    ((int *)boundary)[1] &= 0xff;
    goto Climb;
#endif
  }
}

LispObj *
skip_over_ivector(natural start, LispObj header)
{
  natural 
    element_count = header_element_count(header),
    subtag = header_subtag(header),
    nbytes;


#ifdef X8664
  switch (fulltag_of(header)) {
  case ivector_class_64_bit:
    nbytes = element_count << 3;
    break;
  case ivector_class_32_bit:
    nbytes = element_count << 2;
    break;
  case ivector_class_other_bit:
  default:
    if (subtag == subtag_bit_vector) {
      nbytes = (element_count+7)>>3;
    } else if (subtag >= min_8_bit_ivector_subtag) {
      nbytes = element_count;
    } else {
      nbytes = element_count << 1;
    }
  }
  return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15)));
#else
  if (subtag <= max_32_bit_ivector_subtag) {
    nbytes = element_count << 2;
  } else if (subtag <= max_8_bit_ivector_subtag) {
    nbytes = element_count;
  } else if (subtag <= max_16_bit_ivector_subtag) {
    nbytes = element_count << 1;
  } else if (subtag == subtag_double_float_vector) {
    nbytes = 4 + (element_count << 3);
  } else {
    nbytes = (element_count+7) >> 3;
  }
  return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7)));
#endif
}


void
check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits)
{
  LispObj x1, *base = start, *prev = start;
  int tag;
  natural ref_dnode, node_dnode;
  Boolean intergen_ref;

  while (start < end) {
    x1 = *start;
    prev = start;
    tag = fulltag_of(x1);
    if (immheader_tag_p(tag)) {
      start = skip_over_ivector(ptr_to_lispobj(start), x1);
    } else {
      if (header_subtag(x1) == subtag_function) {
        int skip = (int) deref(start,1);
        start += ((1+skip)&~1);
        x1 = *start;
        tag = fulltag_of(x1);
      }
      intergen_ref = false;
      if (is_node_fulltag(tag)) {        
        node_dnode = gc_area_dnode(x1);
        if (node_dnode < GCndnodes_in_area) {
          intergen_ref = true;
        }
      }
      if (intergen_ref == false) {        
        x1 = start[1];
        tag = fulltag_of(x1);
      if (is_node_fulltag(tag)) {        
          node_dnode = gc_area_dnode(x1);
          if (node_dnode < GCndnodes_in_area) {
            intergen_ref = true;
          }
        }
      }
      if (intergen_ref) {
        ref_dnode = area_dnode(start, base);
        if (!ref_bit(refbits, ref_dnode)) {
          Bug(NULL, "Missing memoization in doublenode at 0x%08X", start);
          set_bit(refbits, ref_dnode);
        }
      }
      start += 2;
    }
  }
  if (start > end) {
    Bug(NULL, "Overran end of range!");
  }
}



void
mark_memoized_area(area *a, natural num_memo_dnodes)
{
  bitvector refbits = a->refbits;
  LispObj *p = (LispObj *) a->low, x1, x2;
  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0;
  Boolean keep_x1, keep_x2;

  if (GCDebug) {
    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
  }

  /* The distinction between "inbits" and "outbits" is supposed to help us
     detect cases where "uninteresting" setfs have been memoized.  Storing
     NIL, fixnums, immediates (characters, etc.) or node pointers to static
     or readonly areas is definitely uninteresting, but other cases are
     more complicated (and some of these cases are hard to detect.)

     Some headers are "interesting", to the forwarder if not to us. 

     We -don't- give anything any weak treatment here.  Weak things have
     to be seen by a full gc, for some value of 'full'.
     */

  /*
    We need to ensure that there are no bits set at or beyond
    "num_memo_dnodes" in the bitvector.  (This can happen as the EGC
    tenures/untenures things.)  We find bits by grabbing a fullword at
    a time and doing a cntlzw instruction; and don't want to have to
    check for (< memo_dnode num_memo_dnodes) in the loop.
    */

  {
    natural 
      bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask),
      index_of_last_word = (num_memo_dnodes >> bitmap_shift);

    if (bits_in_last_word != 0) {
      natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L);
      refbits[index_of_last_word] &= mask;
    }
  }
        
  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
  inbits = outbits = bits;
  while (memo_dnode < num_memo_dnodes) {
    if (bits == 0) {
      int remain = nbits_in_word - bitidx;
      memo_dnode += remain;
      p += (remain+remain);
      if (outbits != inbits) {
        *bitsp = outbits;
      }
      bits = *++bitsp;
      inbits = outbits = bits;
      bitidx = 0;
    } else {
      nextbit = count_leading_zeros(bits);
      if ((diff = (nextbit - bitidx)) != 0) {
        memo_dnode += diff;
        bitidx = nextbit;
        p += (diff+diff);
      }
      x1 = *p++;
      x2 = *p++;
      bits &= ~(BIT0_MASK >> bitidx);
      keep_x1 = mark_ephemeral_root(x1);
      keep_x2 = mark_ephemeral_root(x2);
      if ((keep_x1 == false) && 
          (keep_x2 == false)) {
        outbits &= ~(BIT0_MASK >> bitidx);
      }
      memo_dnode++;
      bitidx++;
    }
  }
  if (GCDebug) {
    p = (LispObj *) a->low;
    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
  }
}

void
mark_headerless_area_range(LispObj *start, LispObj *end)
{
  while (start < end) {
    mark_root(*start++);
  }
}

void
mark_simple_area_range(LispObj *start, LispObj *end)
{
  LispObj x1, *base;
  int tag;

  while (start < end) {
    x1 = *start;
    tag = fulltag_of(x1);
    if (immheader_tag_p(tag)) {
      start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1));
    } else if (!nodeheader_tag_p(tag)) {
      ++start;
      mark_root(x1);
      mark_root(*start++);
    } else {
      int subtag = header_subtag(x1);
      natural element_count = header_element_count(x1);
      natural size = (element_count+1 + 1) & ~1;

      if (subtag == subtag_hash_vector) {
        LispObj flags = ((hash_table_vector_header *) start)->flags;

        if (flags & nhash_weak_mask) {
          ((hash_table_vector_header *) start)->cache_key = undefined;
          ((hash_table_vector_header *) start)->cache_value = lisp_nil;
        }

        start[1] = GCweakvll;
        GCweakvll = (LispObj) (((natural) start) + fulltag_misc);
      } else {

        if (subtag == subtag_pool) {
          start[1] = lisp_nil;
        }

        if (subtag == subtag_weak) {
          natural weak_type = (natural) start[2];
          if (weak_type >> population_termination_bit)
            element_count -= 2;
          else
            element_count -= 1; 
          start[1] = GCweakvll;
          GCweakvll = (LispObj) (((natural) start) + fulltag_misc);    
        }

        base = start + element_count + 1;
        if (subtag == subtag_function) {
#ifdef X8632
          element_count -= (unsigned short)start[1];
#else
          element_count -= (int)start[1];
#endif
        }
        while(element_count--) {
          mark_root(*--base);
        }
      }
      start += size;
    }
  }
}


/* Mark a tstack area */
void
mark_tstack_area(area *a)
{
  LispObj
    *current,
    *next,
    *start = (LispObj *) (a->active),
    *end = start,
    *limit = (LispObj *) (a->high);

  for (current = start;
       end != limit;
       current = next) {
    next = (LispObj *) ptr_from_lispobj(*current);
    end = ((next >= start) && (next < limit)) ? next : limit;
    mark_simple_area_range(current+2, end);
  }
}

/*
  It's really important that headers never wind up in tagged registers.
  Those registers would (possibly) get pushed on the vstack and confuse
  the hell out of this routine.

  vstacks are just treated as a "simple area range", possibly with
  an extra word at the top (where the area's active pointer points.)
  */

void
mark_vstack_area(area *a)
{
  LispObj
    *start = (LispObj *) a->active,
    *end = (LispObj *) a->high;

#if 0
  fprintf(stderr, "mark VSP range: 0x%lx:0x%lx\n", start, end);
#endif
  mark_headerless_area_range(start, end);
}


void
reapweakv(LispObj weakv)
{
  /*
    element 2 of the weak vector should be tagged as a cons: if it
    isn't, just mark it as a root.  if it is, cdr through it until a
    "marked" cons is encountered.  If the car of any unmarked cons is
    marked, mark the cons which contains it; otherwise, splice the
    cons out of the list.  N.B. : elements 0 and 1 are already marked
    (or are immediate, etc.)
  */
  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
  LispObj termination_list = lisp_nil;
  natural weak_type = (natural) deref(weakv,2);
  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
    terminatablep = ((weak_type >> population_termination_bit) != 0);
  Boolean done = false;
  cons *rawcons;
  natural dnode, car_dnode;
  bitvector markbits = GCmarkbits;

  if (terminatablep) {
    termination_list = deref(weakv,1+3);
  }

  if (fulltag_of(cell) != fulltag_cons) {
    mark_root(cell);
  } else if (alistp) {
    /* weak alist */
    while (! done) {
      dnode = gc_area_dnode(cell);
      if ((dnode >= GCndnodes_in_area) ||
          (ref_bit(markbits, dnode))) {
        done = true;
      } else {
        /* Cons cell is unmarked. */
        LispObj alist_cell, thecar;
        unsigned cell_tag;

        rawcons = (cons *) ptr_from_lispobj(untag(cell));
        alist_cell = rawcons->car;
        cell_tag = fulltag_of(alist_cell);

        if ((cell_tag == fulltag_cons) &&
            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
            (! ref_bit(markbits, car_dnode)) &&
            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
            (! ref_bit(markbits, car_dnode))) {
          *prev = rawcons->cdr;
          if (terminatablep) {
            rawcons->cdr = termination_list;
            termination_list = cell;
          }
        } else {
          set_bit(markbits, dnode);
          prev = (LispObj *)(&(rawcons->cdr));
          mark_root(alist_cell);
        }
        cell = *prev;
      }
    }
  } else {
    /* weak list */
    while (! done) {
      dnode = gc_area_dnode(cell);
      if ((dnode >= GCndnodes_in_area) ||
          (ref_bit(markbits, dnode))) {
        done = true;
      } else {
        /* Cons cell is unmarked. */
        LispObj thecar;
        unsigned cartag;

        rawcons = (cons *) ptr_from_lispobj(untag(cell));
        thecar = rawcons->car;
        cartag = fulltag_of(thecar);

        if (is_node_fulltag(cartag) &&
            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
            (! ref_bit(markbits, car_dnode))) {
          *prev = rawcons->cdr;
          if (terminatablep) {
            rawcons->cdr = termination_list;
            termination_list = cell;
          }
        } else {
          set_bit(markbits, dnode);
          prev = (LispObj *)(&(rawcons->cdr));
        }
        cell = *prev;
      }
    }
  }

  if (terminatablep) {
    deref(weakv,1+3) = termination_list;
    if (termination_list != lisp_nil) {
      deref(weakv,1) = GCweakvll;
      GCweakvll = weakv;
    }
  }
}

/* 
  Screw: doesn't deal with finalization.
  */

void
reaphashv(LispObj hashv)
{
  hash_table_vector_header
    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
  natural
    dnode,
    npairs = (header_element_count(hashp->header) - 
              ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1;
  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
  Boolean 
    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
  bitvector markbits = GCmarkbits;
  int tag;

  while (npairs--) {
    if (weak_on_value) {
      weakelement = pairp[1];
    } else {
      weakelement = pairp[0];
    }
    tag = fulltag_of(weakelement);
    if (is_node_fulltag(tag)) {
      dnode = gc_area_dnode(weakelement);
      if ((dnode < GCndnodes_in_area) && 
          ! ref_bit(markbits, dnode)) {
        pairp[0] = slot_unbound;
        pairp[1] = lisp_nil;
        hashp->weak_deletions_count += (1<<fixnumshift);
      }
    }
    pairp += 2;
  }
}    
    


Boolean
mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
{
  natural flags = hashp->flags, key_dnode, val_dnode;
  Boolean 
    marked_new = false, 
    key_marked,
    val_marked,
    weak_value = ((flags & nhash_weak_value_mask) != 0);
  int 
    skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1,
    key_tag,
    val_tag,
    i;
  LispObj 
    *pairp = (LispObj*) (hashp+1),
    key,
    val;

  /* Mark everything in the header */
  
  for (i = 2; i<= skip; i++) {
    mark_root(deref(ptr_to_lispobj(hashp),i));
  }

  elements -= skip;

  for (i = 0; i<elements; i+=2, pairp+=2) {
    key = pairp[0];
    val = pairp[1];
    key_marked = val_marked = true;
    key_tag = fulltag_of(key);
    val_tag = fulltag_of(val);
    if (is_node_fulltag(key_tag)) {
      key_dnode = gc_area_dnode(key);
      if ((key_dnode < GCndnodes_in_area) &&
          ! ref_bit(GCmarkbits,key_dnode)) {
        key_marked = false;
      }
    }
    if (is_node_fulltag(val_tag)) {
      val_dnode = gc_area_dnode(val);
      if ((val_dnode < GCndnodes_in_area) &&
          ! ref_bit(GCmarkbits,val_dnode)) {
        val_marked = false;
      }
    }

    if (weak_value) {
      if (val_marked & !key_marked) {
        mark_root(key);
        marked_new = true;
      }
    } else {
      if (key_marked & !val_marked) {
        mark_root(val);
        marked_new = true;
      }
    }
  }
  return marked_new;
}


Boolean
mark_weak_alist(LispObj weak_alist, int weak_type)
{
  natural
    elements = header_element_count(header_of(weak_alist)),
    dnode;
  int pair_tag;
  Boolean marked_new = false;
  LispObj alist, pair, key, value;
  bitvector markbits = GCmarkbits;

  if (weak_type >> population_termination_bit) {
    elements -= 1;
  }
  for(alist = deref(weak_alist, elements);
      (fulltag_of(alist) == fulltag_cons) &&
      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
      (! ref_bit(markbits,dnode));
      alist = cdr(alist)) {
    pair = car(alist);
    pair_tag = fulltag_of(pair);
    if ((is_node_fulltag(pair_tag)) &&
        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
        (! ref_bit(markbits,dnode))) {
      if (pair_tag == fulltag_cons) {
        key = car(pair);
        if ((! is_node_fulltag(fulltag_of(key))) ||
            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
            ref_bit(markbits,dnode)) {
          /* key is marked, mark value if necessary */
          value = cdr(pair);
          if (is_node_fulltag(fulltag_of(value)) &&
              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
              (! ref_bit(markbits,dnode))) {
            mark_root(value);
            marked_new = true;
          }
        }
      } else {
          mark_root(pair);
          marked_new = true;
      }
    }
  }
  return marked_new;
}
  
void
markhtabvs()
{
  LispObj this, header, pending;
  int subtag;
  bitvector markbits = GCmarkbits;
  hash_table_vector_header *hashp;
  Boolean marked_new;

  do {
    pending = (LispObj) NULL;
    marked_new = false;
    
    while (GCweakvll) {
      this = GCweakvll;
      GCweakvll = deref(this,1);
      
      header = header_of(this);
      subtag = header_subtag(header);
      
      if (subtag == subtag_weak) {
        natural weak_type = deref(this,2);
        deref(this,1) = pending;
        pending = this;
        if ((weak_type & population_type_mask) == population_weak_alist) {
          if (mark_weak_alist(this, weak_type)) {
            marked_new = true;
          }
        }
      } else if (subtag == subtag_hash_vector) {
        natural elements = header_element_count(header), i;

        hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this));
        if (hashp->flags & nhash_weak_mask) {
          deref(this,1) = pending;
          pending = this;
          if (mark_weak_hash_vector(hashp, elements)) {
            marked_new = true;
          }
        } else {
          deref(this,1) = (LispObj)NULL;
          for (i = 2; i <= elements; i++) {
            mark_root(deref(this,i));
          }
        } 
      } else {
        Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this);
      }
    }

    if (marked_new) {
      GCweakvll = pending;
    }
  } while (marked_new);

  /* Now, everything's marked that's going to be,  and "pending" is a list
     of populations and weak hash tables.  CDR down that list and free
     anything that isn't marked.
     */

  while (pending) {
    this = pending;
    pending = deref(this,1);
    deref(this,1) = (LispObj)NULL;

    subtag = header_subtag(header_of(this));
    if (subtag == subtag_weak) {
      reapweakv(this);
    } else {
      reaphashv(this);
    }
  }

  /* Finally, mark the termination lists in all terminatable weak vectors
     They are now linked together on GCweakvll.
     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
     but it will force terminatable popualations to hold on to each other
     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
     */
  pending = GCweakvll;
  GCweakvll = (LispObj)NULL;
  while (pending) {
    this = pending;
    pending = deref(this,1);
    deref(this,1) = (LispObj)NULL;
    mark_root(deref(this,1+3));
  }
}

/* Mark the lisp objects in an exception frame */
#ifdef X8664
void
mark_xp(ExceptionInformation *xp)
{
  natural *regs = (natural *) xpGPRvector(xp), dnode;
  LispObj rip;
    
  

  mark_root(regs[Iarg_z]);
  mark_root(regs[Iarg_y]);
  mark_root(regs[Iarg_x]);
  mark_root(regs[Isave3]);
  mark_root(regs[Isave2]);
  mark_root(regs[Isave1]);
  mark_root(regs[Isave0]);
  mark_root(regs[Ifn]);
  mark_root(regs[Itemp0]);
  mark_root(regs[Itemp1]);
  mark_root(regs[Itemp2]);
  /* If the RIP isn't pointing into a marked function,
     we can -maybe- recover from that if it's tagged as
     a TRA. */
  rip = regs[Iip];
  dnode = gc_area_dnode(rip);
  if ((dnode < GCndnodes_in_area) &&
      (! ref_bit(GCmarkbits,dnode))) {
    if (tag_of(rip) == tag_tra) {
      mark_root(rip);
    } else if ((fulltag_of(rip) == fulltag_function) &&
               (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) &&
               (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) &&
               ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) {
      mark_root(rip);
    } else {
      Bug(NULL, "Can't find function for rip 0x%16lx",rip);
    }
  }
}
#else
void
mark_xp(ExceptionInformation *xp, unsigned char node_regs_mask)
{
  natural *regs = (natural *) xpGPRvector(xp), dnode;
  LispObj eip;
  int i;

  for (i = 0; i < 8; i++)
    if (node_regs_mask & (1<<i))
      mark_root(regs[i]);

  /* If the EIP isn't pointing into a marked function, we're probably
     in trouble.  We can -maybe- recover from that if it's tagged as a
     TRA. */
  eip = regs[Ieip];
  dnode = gc_area_dnode(eip);
  if ((dnode < GCndnodes_in_area) &&
      (! ref_bit(GCmarkbits,dnode))) {
    if (fulltag_of(eip) == fulltag_tra) {
      mark_root(eip);
    } else if ((fulltag_of(eip) == fulltag_misc) &&
               (header_subtag(header_of(eip)) == subtag_function) &&
               (*(unsigned char *)eip == RECOVER_FN_OPCODE) &&
               (*(LispObj *)(eip + 1)) == eip) {
      mark_root(eip);
    } else {
      Bug(NULL, "Can't find function for eip 0x%4x", eip);
    }
  }
}
#endif

void
mark_tcr_tlb(TCR *tcr)
{
  natural n = tcr->tlb_limit;
  LispObj 
    *start = tcr->tlb_pointer,
    *end = (LispObj *) ((BytePtr)start+n),
    node;

  while (start < end) {
    node = *start;
    if (node != no_thread_local_binding_marker) {
      mark_root(node);
    }
    start++;
  }
}

/*
  Mark things that're only reachable through some (suspended) TCR.
  (This basically means the tcr's gc_context and the exception
  frames on its xframe_list.)
*/

void
mark_tcr_xframes(TCR *tcr)
{
  xframe_list *xframes;
  ExceptionInformation *xp;

  xp = tcr->gc_context;
  if (xp) {
#ifdef X8664
    mark_xp(xp);
#else
    mark_xp(xp, tcr->node_regs_mask);
#endif
  }
#ifdef X8632
  mark_root(tcr->save0);
  mark_root(tcr->save1);
  mark_root(tcr->save2);
  mark_root(tcr->save3);
  mark_root(tcr->next_method_context);
#endif
  
  for (xframes = (xframe_list *) tcr->xframe; 
       xframes; 
       xframes = xframes->prev) {
#ifdef X8664
      mark_xp(xframes->curr);
#else
      mark_xp(xframes->curr, xframes->node_regs_mask);
#endif
  }
}
      

void *postGCptrs = NULL;

void
postGCfree(void *p)
{
  *(void **)p = postGCptrs;
  postGCptrs = p;
}

void
freeGCptrs()
{
  void *p, *next;

  for (p = postGCptrs; p; p = next) {
    next = *((void **)p);
    free(p);
  }
  postGCptrs = NULL;
}

void
reap_gcable_ptrs()
{
  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
  xmacptr_flag flag;
  natural dnode;
  xmacptr *x;

  while((next = *prev) != (LispObj)NULL) {
    dnode = gc_area_dnode(next);
    x = (xmacptr *) ptr_from_lispobj(untag(next));

    if ((dnode >= GCndnodes_in_area) ||
        (ref_bit(GCmarkbits,dnode))) {
      prev = &(x->link);
    } else {
      *prev = x->link;
      flag = (xmacptr_flag)(x->flags);
      ptr = x->address;

      if (ptr) {
        switch (flag) {
        case xmacptr_flag_recursive_lock:
          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
          break;

        case xmacptr_flag_ptr:
          postGCfree((void *)ptr_from_lispobj(ptr));
          break;

        case xmacptr_flag_rwlock:
          break;

        case xmacptr_flag_semaphore:
          destroy_semaphore((void**)&(x->address));
          break;

        default:
          /* (warn "unknown xmacptr_flag: ~s" flag) */
          /* Unknowd, and perhaps unknowdable. */
          /* Fall in: */
        case xmacptr_flag_none:
          break;
        }
      }
    }
  }
}



#if  WORD_SIZE == 64
unsigned short *_one_bits = NULL;

unsigned short
logcount16(unsigned short n)
{
  unsigned short c=0;
  
  while(n) {
    n = n & (n-1);
    c++;
  }
  return c;
}

void
gc_init()
{
  int i;
  
  _one_bits = malloc(sizeof(unsigned short) * (1<<16));

  for (i = 0; i < (1<<16); i++) {
    _one_bits[i] = dnode_size*logcount16(i);
  }
}

#define one_bits(x) _one_bits[x]

#else
const unsigned char _one_bits[256] = {
    0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,
    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
    4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8
};

#define one_bits(x) _one_bits[x]

void
gc_init()
{
}

#endif

/* A "pagelet" contains 32 doublewords.  The relocation table contains
   a word for each pagelet which defines the lowest address to which
   dnodes on that pagelet will be relocated.

   The relocation address of a given pagelet is the sum of the relocation
   address for the preceding pagelet and the number of bytes occupied by
   marked objects on the preceding pagelet.
*/

LispObj
calculate_relocation()
{
  LispObj *relocptr = GCrelocptr;
  LispObj current = GCareadynamiclow;
  bitvector 
    markbits = GCdynamic_markbits;
  qnode *q = (qnode *) markbits;
  natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift);
  natural thesebits;
  LispObj first = 0;

  if (npagelets) {
    do {
      *relocptr++ = current;
      thesebits = *markbits++;
      if (thesebits == ALL_ONES) {
        current += nbits_in_word*dnode_size;
        q += 4; /* sic */
      } else {
        if (!first) {
          first = current;
          while (thesebits & BIT0_MASK) {
            first += dnode_size;
            thesebits += thesebits;
          }
        }
        /* We're counting bits in qnodes in the wrong order here, but
           that's OK.  I think ... */
        current += one_bits(*q++);
        current += one_bits(*q++);
        current += one_bits(*q++);
        current += one_bits(*q++);
      }
    } while(--npagelets);
  }
  *relocptr++ = current;
  return first ? first : current;
}


#if 0
LispObj
dnode_forwarding_address(natural dnode, int tag_n)
{
  natural pagelet, nbits;
  unsigned int near_bits;
  LispObj new;

  if (GCDebug) {
    if (! ref_bit(GCdynamic_markbits, dnode)) {
      Bug(NULL, "unmarked object being forwarded!\n");
    }
  }

  pagelet = dnode >> bitmap_shift;
  nbits = dnode & bitmap_shift_count_mask;
  near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)];

  if (nbits < 32) {
    new = GCrelocptr[pagelet] + tag_n;;
    /* Increment "new" by the count of 1 bits which precede the dnode */
    if (near_bits == 0xffffffff) {
      return (new + (nbits << 4));
    } else {
      near_bits &= (0xffffffff00000000 >> nbits);
      if (nbits > 15) {
        new += one_bits(near_bits & 0xffff);
      }
      return (new + (one_bits(near_bits >> 16))); 
    }
  } else {
    new = GCrelocptr[pagelet+1] + tag_n;
    nbits = 64-nbits;

    if (near_bits == 0xffffffff) {
      return (new - (nbits << 4));
    } else {
      near_bits &= (1<<nbits)-1;
      if (nbits > 15) {
        new -= one_bits(near_bits >> 16);
      }
      return (new -  one_bits(near_bits & 0xffff));
    }
  }
}
#else
#ifdef X8664
/* Quicker, dirtier */
LispObj
dnode_forwarding_address(natural dnode, int tag_n)
{
  natural pagelet, nbits, marked;
  LispObj new;

  if (GCDebug) {
    if (! ref_bit(GCdynamic_markbits, dnode)) {
      Bug(NULL, "unmarked object being forwarded!\n");
    }
  }

  pagelet = dnode >> bitmap_shift;
  nbits = dnode & bitmap_shift_count_mask;
  new = GCrelocptr[pagelet] + tag_n;;
  if (nbits) {
    marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits);
    while (marked) {
      new += one_bits((qnode)marked);
      marked >>=16;
    }
  }
  return new;
}
#endif
#ifdef X8632
LispObj
dnode_forwarding_address(natural dnode, int tag_n)
{
  natural pagelet, nbits;
  unsigned short near_bits;
  LispObj new;

  if (GCDebug) {
    if (! ref_bit(GCdynamic_markbits, dnode)) {
      Bug(NULL, "unmarked object being forwarded!\n");
    }
  }

  pagelet = dnode >> 5;
  nbits = dnode & 0x1f;
  /* On little-endian x86, we have to flip the low bit of dnode>>4 to
     get the near_bits from the appropriate half-word. */
  near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1];

  if (nbits < 16) {
    new = GCrelocptr[pagelet] + tag_n;;
    /* Increment "new" by the count of 1 bits which precede the dnode */
    if (near_bits == 0xffff) {
      return (new + (nbits << 3));
    } else {
      near_bits &= (0xffff0000 >> nbits);
      if (nbits > 7) {
        new += one_bits(near_bits & 0xff);
      }
      return (new + (one_bits(near_bits >> 8))); 
    }
  } else {
    new = GCrelocptr[pagelet+1] + tag_n;
    nbits = 32-nbits;

    if (near_bits == 0xffff) {
      return (new - (nbits << 3));
    } else {
      near_bits &= (1<<nbits)-1;
      if (nbits > 7) {
        new -= one_bits(near_bits >> 8);
      }
      return (new - one_bits(near_bits & 0xff));
    }
  }
}
#endif
#endif

LispObj
locative_forwarding_address(LispObj obj)
{
  int tag_n = fulltag_of(obj);
  natural dnode = gc_dynamic_area_dnode(obj);


  if ((dnode >= GCndynamic_dnodes_in_area) ||
      (obj < GCfirstunmarked)) {
    return obj;
  }

  return dnode_forwarding_address(dnode, tag_n);
}

LispObj
node_forwarding_address(LispObj node)
{
  int tag_n;
  natural dnode = gc_dynamic_area_dnode(node);

  if ((dnode >= GCndynamic_dnodes_in_area) ||
      (node < GCfirstunmarked)) {
    return node;
  }

  tag_n = fulltag_of(node);
  if (!is_node_fulltag(tag_n)) {
    return node;
  }

  return dnode_forwarding_address(dnode, tag_n);
}

Boolean
update_noderef(LispObj *noderef)
{
  LispObj
    node = *noderef,
    new = node_forwarding_address(node);

  if (new != node) {
    *noderef = new;
    return true;
  }
  return false;
}

void
update_locref(LispObj *locref)
{
  LispObj
    obj = *locref,
    new = locative_forwarding_address(obj);

  if (new != obj) {
    *locref = new;
  }
}

void
forward_gcable_ptrs()
{
  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;

  while ((next = *prev) != (LispObj)NULL) {
    *prev = node_forwarding_address(next);
    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
  }
}

void
forward_headerless_range(LispObj *range_start, LispObj *range_end)
{
  LispObj *p = range_start;

  while (p < range_end) {
    update_noderef(p);
    p++;
  }
}

void
forward_range(LispObj *range_start, LispObj *range_end)
{
  LispObj *p = range_start, node, new;
  int tag_n;
  natural nwords;
  hash_table_vector_header *hashp;

  while (p < range_end) {
    node = *p;
    tag_n = fulltag_of(node);
    if (immheader_tag_p(tag_n)) {
      p = (LispObj *) skip_over_ivector((natural) p, node);
    } else if (nodeheader_tag_p(tag_n)) {
      nwords = header_element_count(node);
      nwords += (1 - (nwords&1));
      if ((header_subtag(node) == subtag_hash_vector) &&
          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
        natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
        hashp = (hash_table_vector_header *) p;
        p++;
        nwords -= skip;
        while(skip--) {
          update_noderef(p);
          p++;
        }
        /* "nwords" is odd at this point: there are (floor nwords 2)
           key/value pairs to look at, and then an extra word for
           alignment.  Process them two at a time, then bump "p"
           past the alignment word. */
        nwords >>= 1;
        while(nwords--) {
          if (update_noderef(p) && hashp) {
            hashp->flags |= nhash_key_moved_mask;
            hashp = NULL;
          }
          p++;
          update_noderef(p);
          p++;
        }
        *p++ = 0;
      } else {
        if (header_subtag(node) == subtag_function) {
#ifdef X8632
          int skip = (unsigned short)(p[1]);
#else
          int skip = (int)(p[1]);
#endif
          p += skip;
          nwords -= skip;
        }
        p++;
        while(nwords--) {
          update_noderef(p);
          p++;
        }
      }
    } else {
      new = node_forwarding_address(node);
      if (new != node) {
        *p = new;
      }
      p++;
      update_noderef(p);
      p++;
    }
  }
}


void
forward_memoized_area(area *a, natural num_memo_dnodes)
{
  bitvector refbits = a->refbits;
  LispObj *p = (LispObj *) a->low, x1, x2, new;
  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
  int tag_x1;
  hash_table_vector_header *hashp = NULL;
  Boolean header_p;

  if (GCDebug) {
    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
  }

  /* This is pretty straightforward, but we have to note
     when we move a key in a hash table vector that wants
     us to tell it about that. */

  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
  while (memo_dnode < num_memo_dnodes) {
    if (bits == 0) {
      int remain = nbits_in_word - bitidx;
      memo_dnode += remain;
      p += (remain+remain);
      bits = *++bitsp;
      bitidx = 0;
    } else {
      nextbit = count_leading_zeros(bits);
      if ((diff = (nextbit - bitidx)) != 0) {
        memo_dnode += diff;
        bitidx = nextbit;
        p += (diff+diff);
      }
      x1 = p[0];
      x2 = p[1];
      tag_x1 = fulltag_of(x1);
      bits &= ~(BIT0_MASK >> bitidx);
      header_p = (nodeheader_tag_p(tag_x1));

      if (header_p &&
          (header_subtag(x1) == subtag_hash_vector)) {
        hashp = (hash_table_vector_header *) p;
        if (hashp->flags & nhash_track_keys_mask) {
          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
        } else {
          hashp = NULL;
        }
      }


      if (! header_p) {
        new = node_forwarding_address(x1);
        if (new != x1) {
          *p = new;
        }
      }
      p++;

      new = node_forwarding_address(x2);
      if (new != x2) {
        *p = new;
        if (memo_dnode < hash_dnode_limit) {
          hashp->flags |= nhash_key_moved_mask;
          hash_dnode_limit = 0;
          hashp = NULL;
        }
      }
      p++;
      memo_dnode++;
      bitidx++;

    }
  }
}



/* Forward a tstack area */
void
forward_tstack_area(area *a)
{
  LispObj
    *current,
    *next,
    *start = (LispObj *) a->active,
    *end = start,
    *limit = (LispObj *) (a->high);

  for (current = start;
       end != limit;
       current = next) {
    next = ptr_from_lispobj(*current);
    end = ((next >= start) && (next < limit)) ? next : limit;
    forward_range(current+2, end);
  }
}

/* Forward a vstack area */
void
forward_vstack_area(area *a)
{
  LispObj
    *p = (LispObj *) a->active,
    *q = (LispObj *) a->high;

  forward_headerless_range(p, q);
}

void
forward_xp(ExceptionInformation *xp)
{
  natural *regs = (natural *) xpGPRvector(xp);

#ifdef X8664
  update_noderef(&(regs[Iarg_z]));
  update_noderef(&(regs[Iarg_y]));
  update_noderef(&(regs[Iarg_x]));
  update_noderef(&(regs[Isave3]));
  update_noderef(&(regs[Isave2]));
  update_noderef(&(regs[Isave1]));
  update_noderef(&(regs[Isave0]));
  update_noderef(&(regs[Ifn]));
  update_noderef(&(regs[Itemp0]));
  update_noderef(&(regs[Itemp1]));
  update_noderef(&(regs[Itemp2]));
  update_locref(&(regs[Iip]));
#else
  update_noderef(&(regs[Iarg_z]));
  update_noderef(&(regs[Iarg_y]));
  update_noderef(&(regs[Ifn]));
  update_noderef(&(regs[Itemp0]));
  update_noderef(&(regs[Itemp1]));
  update_locref(&(regs[Iip]));
#endif
}


void
forward_tcr_tlb(TCR *tcr)
{
  natural n = tcr->tlb_limit;
  LispObj 
    *start = tcr->tlb_pointer, 
    *end = (LispObj *) ((BytePtr)start+n),
    node;

  while (start < end) {
    node = *start;
    if (node != no_thread_local_binding_marker) {
      update_noderef(start);
    }
    start++;
  }
}

void
forward_tcr_xframes(TCR *tcr)
{
  xframe_list *xframes;
  ExceptionInformation *xp;

  xp = tcr->gc_context;
  if (xp) {
    forward_xp(xp);
  }
  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
    forward_xp(xframes->curr);
  }
}

void
forward_and_resolve_static_references(area *a)
{
  natural 
    nstatic = static_dnodes_for_area(a),
    nstatic_bitmap_words = nstatic >> bitmap_shift;
  if (nstatic != 0) {
    /* exploit the fact that a cons is the same size as a dnode. */
    cons *pagelet_start = (cons *) a->low, *work;
    bitvector markbits = GCmarkbits, 
      usedbits = tenured_area->static_used;
    natural marked, used, used_but_not_marked, ndeleted = 0, i;

    while (nstatic_bitmap_words--) {
      marked = *markbits++;
      used = *usedbits;
      if (marked != used) {
        *usedbits = marked;
      }
      used |= marked;
      used_but_not_marked = used & ~marked;

      while (marked) {
        i = count_leading_zeros(marked);
        marked &= ~(BIT0_MASK >> i);
        work = pagelet_start+i;
        update_noderef(&work->cdr);
        update_noderef(&work->car);
      }

      while (used_but_not_marked) {
        i = count_leading_zeros(used_but_not_marked);
        used_but_not_marked &= ~(BIT0_MASK >> i);
        work = pagelet_start+i;
        if ((work->cdr != undefined) &&
            (work->cdr != slot_unbound)) {
          work->car = slot_unbound;
          work->cdr = slot_unbound;
          ndeleted++;
        }
      }
      usedbits++;
      pagelet_start += nbits_in_word;
    }
    lisp_global(DELETED_STATIC_PAIRS) += box_fixnum(ndeleted);
  }
}

#ifdef X8632
void
update_self_references(LispObj *node)
{
  LispObj fn = fulltag_misc + (LispObj)node;
  unsigned char *p = (unsigned char *)node;
  natural i, offset;

  i = ((unsigned short *)node)[2];
  offset = node[--i];
  while (offset) {
    *(LispObj *)(p + offset) = fn;
    offset = node[--i];
  }    
}
#endif

/*
  Compact the dynamic heap (from GCfirstunmarked through its end.)
  Return the doublenode address of the new freeptr.
  */

LispObj
compact_dynamic_heap()
{
  LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current,  *prev = NULL;
  natural 
    elements, 
    dnode = gc_area_dnode(GCfirstunmarked), 
    node_dnodes = 0, 
    imm_dnodes = 0, 
    bitidx, 
    *bitsp, 
    bits, 
    nextbit, 
    diff;
  int tag;
  bitvector markbits = GCmarkbits;
    /* keep track of whether or not we saw any
       code_vector headers, and only flush cache if so. */
  Boolean GCrelocated_code_vector = false;

  if (dnode < GCndnodes_in_area) {
    lisp_global(FWDNUM) += (1<<fixnum_shift);
  
    set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
    while (dnode < GCndnodes_in_area) {
      if (bits == 0) {
        int remain = nbits_in_word - bitidx;
        dnode += remain;
        src += (remain+remain);
        bits = *++bitsp;
        bitidx = 0;
      } else {
        /* Have a non-zero markbits word; all bits more significant
           than "bitidx" are 0.  Count leading zeros in "bits"
           (there'll be at least "bitidx" of them.)  If there are more
           than "bitidx" leading zeros, bump "dnode", "bitidx", and
           "src" by the difference. */
        nextbit = count_leading_zeros(bits);
        if ((diff = (nextbit - bitidx)) != 0) {
          dnode += diff;
          bitidx = nextbit;
          src += (diff+diff);
        }
        prev = current;
        current = src;
        if (GCDebug) {
          if (dest != ptr_from_lispobj(locative_forwarding_address(ptr_to_lispobj(src)))) {
            Bug(NULL, "Out of synch in heap compaction.  Forwarding from 0x%lx to 0x%lx,\n expected to go to 0x%lx\n", 
                src, dest, locative_forwarding_address(ptr_to_lispobj(src)));
          }
        }

        node = *src++;
        tag = fulltag_of(node);
        if (nodeheader_tag_p(tag)) {
          elements = header_element_count(node);
          node_dnodes = (elements+2)>>1;
          dnode += node_dnodes;
          if (header_subtag(node) == subtag_function) {
#ifdef X8632
            int skip = *((unsigned short *)src);
            LispObj *f = dest;
#else
            int skip = *((int *)src);
#endif
            *dest++ = node;
            elements -= skip;
            while(skip--) {
              *dest++ = *src++;
            }
            update_self_references(f);
            while(elements--) {
              *dest++ = node_forwarding_address(*src++);
            }
            if (((LispObj)src) & node_size) {
              src++;
              *dest++ = 0;
            }
          } else {
            if ((header_subtag(node) == subtag_hash_vector) &&
                (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) {
              hash_table_vector_header *hashp = (hash_table_vector_header *) dest;
              int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;
              
              *dest++ = node;
              elements -= skip;
              while(skip--) {
                *dest++ = node_forwarding_address(*src++);
              }
              /* There should be an even number of (key/value) pairs in elements;
                 an extra alignment word follows. */
              elements >>= 1;
              while (elements--) {
                if (hashp) {
                  node = *src++;
                  new = node_forwarding_address(node);
                  if (new != node) {
                    hashp->flags |= nhash_key_moved_mask;
                    hashp = NULL;
                    *dest++ = new;
                  } else {
                    *dest++ = node;
                  }
                } else {
                  *dest++ = node_forwarding_address(*src++);
                }
                *dest++ = node_forwarding_address(*src++);
              }
              *dest++ = 0;
              src++;
            } else {
              *dest++ = node;
              *dest++ = node_forwarding_address(*src++);
              while(--node_dnodes) {
                *dest++ = node_forwarding_address(*src++);
                *dest++ = node_forwarding_address(*src++);
              }
            }
          }
          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
        } else if (immheader_tag_p(tag)) {
          *dest++ = node;
          *dest++ = *src++;
          elements = header_element_count(node);
          tag = header_subtag(node);

#ifdef X8664
          switch(fulltag_of(tag)) {
          case ivector_class_64_bit:
            imm_dnodes = ((elements+1)+1)>>1;
            break;
          case ivector_class_32_bit:
            imm_dnodes = (((elements+2)+3)>>2);
            break;
          case ivector_class_other_bit:
            if (tag == subtag_bit_vector) {
              imm_dnodes = (((elements+64)+127)>>7);
            } else if (tag >= min_8_bit_ivector_subtag) {
              imm_dnodes = (((elements+8)+15)>>4);
            } else {
              imm_dnodes = (((elements+4)+7)>>3);
            }
          }
#endif
#ifdef X8632
          if (tag <= max_32_bit_ivector_subtag) {
            if (tag == subtag_code_vector) {
              GCrelocated_code_vector = true;
            }
            imm_dnodes = (((elements+1)+1)>>1);
          } else if (tag <= max_8_bit_ivector_subtag) {
            imm_dnodes = (((elements+4)+7)>>3);
          } else if (tag <= max_16_bit_ivector_subtag) {
            imm_dnodes = (((elements+2)+3)>>2);
          } else if (tag == subtag_bit_vector) {
            imm_dnodes = (((elements+32)+63)>>6);
          } else {
            imm_dnodes = elements+1;
          }
#endif

          dnode += imm_dnodes;
          while (--imm_dnodes) {
            *dest++ = *src++;
            *dest++ = *src++;
          }
          set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx);
        } else {
          *dest++ = node_forwarding_address(node);
          *dest++ = node_forwarding_address(*src++);
          bits &= ~(BIT0_MASK >> bitidx);
          dnode++;
          bitidx++;
        }
      }
    }
  }
  return ptr_to_lispobj(dest);
}


Boolean
youngest_non_null_area_p (area *a)
{
  if (a->active == a->high) {
    return false;
  } else {
    for (a = a->younger; a; a = a->younger) {
      if (a->active != a->high) {
        return false;
      }
    }
  };
  return true;
}

Boolean just_purified_p = false;


/*
  All thread's stack areas have been "normalized", as
  has the dynamic heap.  (The "active" pointer in these areas
  matches the stack pointer/freeptr value at the time that
  the exception occurred.)
*/


#define get_time(when) gettimeofday(&when, NULL)



#ifdef FORCE_DWS_MARK
#warning recursive marker disabled for testing; remember to re-enable it
#endif

void 
gc(TCR *tcr, signed_natural param)
{
  xframe_list *xframes = (tcr->xframe);
  struct timeval start, stop;
  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
  unsigned timeidx = 1;
  paging_info paging_info_start;
  xframe_list *x;
  LispObj
    pkg,
    itabvec = 0;
  BytePtr oldfree = a->active;
  TCR *other_tcr;
  natural static_dnodes;

#ifndef FORCE_DWS_MARK
  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
  } else {
    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
  }
#else
  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
#endif

  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
  if (GCephemeral_low) {
    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
  } else {
    GCn_ephemeral_dnodes = 0;
  }
  
  if (GCn_ephemeral_dnodes) {
    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
  } else {
    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
  }

  if (GCephemeral_low) {
    if ((oldfree-g1_area->low) < g1_area->threshold) {
      to = g1_area;
      note = a;
      timeidx = 4;
    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
      to = g2_area;
      from = g1_area;
      note = g1_area;
      timeidx = 3;
    } else {
      to = tenured_area;
      from = g2_area;
      note = g2_area;
      timeidx = 2;
    } 
  } else {
    note = tenured_area;
  }

  if (GCverbose) {
    char buf[16];

    sample_paging_info(&paging_info_start);
    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
    if (GCephemeral_low) {
      fprintf(stderr,
              "\n\n;;; Starting EGC of generation %d",
              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
    } else {
      fprintf(stderr,"\n\n;;; Starting full GC");
    }
    fprintf(stderr, ", %s bytes allocated.\n", buf);
  }


  get_time(start);
  lisp_global(IN_GC) = (1<<fixnumshift);


  if (just_purified_p) {
    just_purified_p = false;
    GCDebug = false;
  } else {
    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
    if (GCDebug) {
      check_all_areas();
    }
  }

  if (from) {
    untenure_from_area(from);
  }
  static_dnodes = static_dnodes_for_area(a);
  GCmarkbits = a->markbits;
  GCarealow = ptr_to_lispobj(a->low);
  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
  GCndnodes_in_area = gc_area_dnode(oldfree);

  if (GCndnodes_in_area) {
    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
    GCdynamic_markbits = 
      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);

    zero_bits(GCmarkbits, GCndnodes_in_area);
    GCweakvll = (LispObj)NULL;
  

    if (GCn_ephemeral_dnodes == 0) {
      /* For GCTWA, mark the internal package hash table vector of
       *PACKAGE*, but don't mark its contents. */
      {
        LispObj
          itab;
        natural
          dnode, ndnodes;
      
        pkg = nrs_PACKAGE.vcell;
        if ((fulltag_of(pkg) == fulltag_misc) &&
            (header_subtag(header_of(pkg)) == subtag_package)) {
          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
          itabvec = car(itab);
          dnode = gc_area_dnode(itabvec);
          if (dnode < GCndnodes_in_area) {
            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
            set_n_bits(GCmarkbits, dnode, ndnodes);
          }
        }
      }
    }

    {
      area *next_area;
      area_code code;

      /* Could make a jump table instead of the typecase */

      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
        switch (code) {
        case AREA_TSTACK:
          mark_tstack_area(next_area);
          break;

        case AREA_VSTACK:
          mark_vstack_area(next_area);
          break;

        case AREA_STATIC:
        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
          /* In both of these cases, we -could- use the area's "markbits"
             bitvector as a reference map.  It's safe (but slower) to
             ignore that map and process the entire area.
          */
          if (next_area->younger == NULL) {
            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
          }
          break;

        default:
          break;
        }
      }
    }
  
    if (lisp_global(OLDEST_EPHEMERAL)) {
      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
    }

    other_tcr = tcr;
    do {
      mark_tcr_xframes(other_tcr);
      mark_tcr_tlb(other_tcr);
      other_tcr = other_tcr->next;
    } while (other_tcr != tcr);




    /* Go back through *package*'s internal symbols, marking
       any that aren't worthless.
    */
    
    if (itabvec) {
      natural
        i,
        n = header_element_count(header_of(itabvec));
      LispObj
        sym,
        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));

      for (i = 0; i < n; i++) {
        sym = *raw++;
#ifdef X8664
        if (fulltag_of(sym) == fulltag_symbol) {
#endif
#ifdef X8632
        if (fulltag_of(sym) == fulltag_misc) {
#endif
          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
          natural dnode = gc_area_dnode(sym);
          
          if ((dnode < GCndnodes_in_area) &&
              (!ref_bit(GCmarkbits,dnode))) {
            /* Symbol is in GC area, not marked.
               Mark it if fboundp, boundp, or if
               it has a plist or another home package.
            */
            
            if (FBOUNDP(rawsym) ||
                BOUNDP(rawsym) ||
                (rawsym->flags != 0) || /* SPECIAL, etc. */
                (rawsym->plist != lisp_nil) ||
                ((rawsym->package_predicate != pkg) &&
                 (rawsym->package_predicate != lisp_nil))) {
              mark_root(sym);
            }
          }
        }
      }
    }

    (void)markhtabvs();

    if (itabvec) {
      natural
        i,
        n = header_element_count(header_of(itabvec));
      LispObj
        sym,
        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));

      for (i = 0; i < n; i++, raw++) {
        sym = *raw;
#ifdef X8664
        if (fulltag_of(sym) == fulltag_symbol) {
#endif
#ifdef X8632
        if (fulltag_of(sym) == fulltag_misc) {
#endif
          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
          natural dnode = gc_area_dnode(sym);

          if ((dnode < GCndnodes_in_area) &&
              (!ref_bit(GCmarkbits,dnode))) {
            *raw = unbound_marker;
          }
        }
      }
    }
  
    reap_gcable_ptrs();

    GCrelocptr = global_reloctab;
    GCfirstunmarked = calculate_relocation();

    forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));

    other_tcr = tcr;
    do {
      forward_tcr_xframes(other_tcr);
      forward_tcr_tlb(other_tcr);
      other_tcr = other_tcr->next;
    } while (other_tcr != tcr);

  
    forward_gcable_ptrs();



    {
      area *next_area;
      area_code code;

      /* Could make a jump table instead of the typecase */

      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
        switch (code) {
        case AREA_TSTACK:
          forward_tstack_area(next_area);
          break;

        case AREA_VSTACK:
          forward_vstack_area(next_area);
          break;


        case AREA_STATIC:
        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
          if (next_area->younger == NULL) {
            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
          }
          break;

        default:
          break;
        }
      }
    }
  
    if (GCephemeral_low) {
      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
    } else {
      /* Full GC, need to process static space */
      forward_and_resolve_static_references(a);
    }
  
    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
    if (to) {
      tenure_to_area(to);
    }

    zero_memory_range(a->active, oldfree);

    resize_dynamic_heap(a->active,
                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);

    /*
      If the EGC is enabled: If there's no room for the youngest
      generation, untenure everything.  If this was a full GC and
      there's now room for the youngest generation, tenure everything.
    */
    if (a->older != NULL) {
      natural nfree = (a->high - a->active);


      if (nfree < a->threshold) {
        untenure_from_area(tenured_area);
      } else {
        if (GCephemeral_low == 0) {
          tenure_to_area(tenured_area);
        }
      }
    }
  }
  lisp_global(GC_NUM) += (1<<fixnumshift);
  if (note) {
    note->gccount += (1<<fixnumshift);
  }

  if (GCDebug) {
    check_all_areas();
  }

  
  lisp_global(IN_GC) = 0;

  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
  get_time(stop);

  {
    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
    LispObj val;
    struct timeval *timeinfo, elapsed;

    val = total_gc_microseconds->vcell;
    if ((fulltag_of(val) == fulltag_misc) &&
        (header_subtag(header_of(val)) == subtag_macptr)) {
      timersub(&stop, &start, &elapsed);
      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
      timeradd(timeinfo,  &elapsed, timeinfo);
      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
    }

    val = total_bytes_freed->vcell;
    if ((fulltag_of(val) == fulltag_misc) &&
        (header_subtag(header_of(val)) == subtag_macptr)) {
      long long justfreed = oldfree - a->active;
      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
      if (GCverbose) {
        char buf[16];
        paging_info paging_info_stop;
        
        sample_paging_info(&paging_info_stop);
        if (justfreed <= heap_segment_size) {
          justfreed = 0;
        }
        comma_output_decimal(buf,16,justfreed);
        if (note == tenured_area) {
          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
        } else {
          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n", 
                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
                  buf, 
                  elapsed.tv_sec, elapsed.tv_usec);
        }
        report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
      }
    }
  }
}

      
    
/*
  Total the (physical) byte sizes of all ivectors in the indicated memory range
*/

natural
unboxed_bytes_in_range(LispObj *start, LispObj *end)
{
  natural total=0, elements, tag, subtag, bytes;
  LispObj header;

  while (start < end) {
    header = *start;
    tag = fulltag_of(header);
    
    if ((nodeheader_tag_p(tag)) ||
        (immheader_tag_p(tag))) {
      elements = header_element_count(header);
      if (nodeheader_tag_p(tag)) {
        start += ((elements+2) & ~1);
      } else {
        subtag = header_subtag(header);

#ifdef X8664
        switch(fulltag_of(header)) {
        case ivector_class_64_bit:
          bytes = 8 + (elements<<3);
          break;
        case ivector_class_32_bit:
          bytes = 8 + (elements<<2);
          break;
        case ivector_class_other_bit:
        default:
          if (subtag == subtag_bit_vector) {
            bytes = 8 + ((elements+7)>>3);
          } else if (subtag >= min_8_bit_ivector_subtag) {
            bytes = 8 + elements;
          } else {
            bytes = 8 + (elements<<1);
          }
        }
#endif
#ifdef X8632
          if (subtag <= max_32_bit_ivector_subtag) {
            bytes = 4 + (elements<<2);
          } else if (subtag <= max_8_bit_ivector_subtag) {
            bytes = 4 + elements;
          } else if (subtag <= max_16_bit_ivector_subtag) {
            bytes = 4 + (elements<<1);
          } else if (subtag == subtag_double_float_vector) {
            bytes = 8 + (elements<<3);
          } else {
            bytes = 4 + ((elements+7)>>3);
          }
#endif

        bytes = (bytes+dnode_size-1) & ~(dnode_size-1);
        total += bytes;
        start += (bytes >> node_shift);
      }
    } else {
      start += 2;
    }
  }
  return total;
}


/* 
  This assumes that it's getting called with a simple-{base,general}-string
  or code vector as an argument and that there's room for the object in the
  destination area.
*/


LispObj
purify_displaced_object(LispObj obj, area *dest, natural disp)
{
#ifdef X8664
  BytePtr 
    free = dest->active,
    *old = (BytePtr *) ptr_from_lispobj(untag(obj));
  LispObj 
    header = header_of(obj), 
    new;
  natural 
    subtag = header_subtag(header), 
    element_count = header_element_count(header),
    physbytes;

  switch(subtag) {
  case subtag_simple_base_string:
    physbytes = node_size + (element_count << 2);
    break;

#ifndef X86
  case subtag_code_vector:
    physbytes = node_size + (element_count << 2);
    break;
#endif

  default:
    Bug(NULL, "Can't purify object at 0x%08x", obj);
    return obj;
  }
  physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1);
  dest->active += physbytes;

  new = ptr_to_lispobj(free)+disp;

  memcpy(free, (BytePtr)old, physbytes);
  /* Leave a trail of breadcrumbs.  Or maybe just one breadcrumb. */
  /* Actually, it's best to always leave a trail, for two reasons.
     a) We may be walking the same heap that we're leaving forwaring
     pointers in, so we don't want garbage that we leave behind to
     look like a header.
     b) We'd like to be able to forward code-vector locatives, and
     it's easiest to do so if we leave a {forward_marker, dnode_locative}
     pair at every doubleword in the old vector.
     */
  while(physbytes) {
    *old++ = (BytePtr) forward_marker;
    *old++ = (BytePtr) free;
    free += dnode_size;
    physbytes -= dnode_size;
  }
  return new;
#endif
}

LispObj
purify_object(LispObj obj, area *dest)
{
  return purify_displaced_object(obj, dest, fulltag_of(obj));
}


#define FORWARD_ONLY 0
#define COPY_CODE (1<<0)
#define COPY_STRINGS (1<<1)


/*
  This may overestimate a bit, if the same symbol is accessible from multiple
  packages.
*/
natural
interned_pname_bytes_in_range(LispObj *start, LispObj *end)
{
  lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
  LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header;
  package *p;
  cons *c;
  natural elements, i, nbytes = 0;

#ifdef X8664
  while (fulltag_of(pkg_list) == fulltag_cons) {
    c = (cons *) ptr_from_lispobj(untag(pkg_list));
    p = (package *) ptr_from_lispobj(untag(c->car));
    pkg_list = c->cdr;
    c = (cons *) ptr_from_lispobj(untag(p->itab));
    htab = c->car;
    elements = header_element_count(header_of(htab));
    for (i = 1; i<= elements; i++) {
      obj = deref(htab,i);
      if (fulltag_of(obj) == fulltag_symbol) {
        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
        pname = rawsym->pname;

        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
          pname_header = header_of(pname);
          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
        }
      }
    }
    c = (cons *) ptr_from_lispobj(untag(p->etab));
    htab = c->car;
    elements = header_element_count(header_of(htab));
    for (i = 1; i<= elements; i++) {
      obj = deref(htab,i);
      if (fulltag_of(obj) == fulltag_symbol) {
        rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
        pname = rawsym->pname;

        if ((pname >= (LispObj)start) && (pname < (LispObj)end)) {
          pname_header = header_of(pname);
          nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15);
        }
      }
    }
  }
#endif
  return nbytes;
}

Boolean
copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy)
{
  LispObj obj = *ref, header, new;
  natural tag = fulltag_of(obj), header_tag, header_subtag;
  Boolean changed = false;

#ifdef X8664
  if ((tag == fulltag_misc) &&
      (((BytePtr)ptr_from_lispobj(obj)) > low) &&
      (((BytePtr)ptr_from_lispobj(obj)) < high)) {
    header = deref(obj, 0);
    if (header == forward_marker) { /* already copied */
      *ref = (untag(deref(obj,1)) + tag);
      changed = true;
    } else {
      header_tag = fulltag_of(header);
      if (immheader_tag_p(header_tag)) {
        header_subtag = header_subtag(header);
        if ((what_to_copy & COPY_STRINGS) && 
            ((header_subtag == subtag_simple_base_string))) {
          new = purify_object(obj, dest);
          *ref = new;
          changed = (new != obj);
        }
      }
    }
  }
#endif
  return changed;
}


void purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
{
  while (start < end) { 
    copy_ivector_reference(start, low, high, to, what);
    start++;
  }
}
   
void
purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what)
{
  LispObj header;
  unsigned tag;
  natural nwords;
  hash_table_vector_header *hashp;

  while (start < end) {
    header = *start;
    if (header == forward_marker) {
      start += 2;
    } else {
      tag = fulltag_of(header);
      if (immheader_tag_p(tag)) {
        start = (LispObj *)skip_over_ivector((natural)start, header);
      } else if (nodeheader_tag_p(tag)) {
        nwords = header_element_count(header);
        nwords += (1 - (nwords&1));
        if ((header_subtag(header) == subtag_hash_vector) &&
          ((((hash_table_vector_header *)start)->flags) & 
           nhash_track_keys_mask)) {
          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;

          hashp = (hash_table_vector_header *) start;
          start++;
          nwords -= skip;
          while(skip--) {
            copy_ivector_reference(start, low, high, to, what);
            start++;
          }
          /* "nwords" is odd at this point: there are (floor nwords 2)
             key/value pairs to look at, and then an extra word for
             alignment.  Process them two at a time, then bump "start"
             past the alignment word. */
          nwords >>= 1;
          while(nwords--) {
            if (copy_ivector_reference(start, low, high, to, what) && hashp) {
              hashp->flags |= nhash_key_moved_mask;
              hashp = NULL;
            }
            start++;
            copy_ivector_reference(start, low, high, to, what);
            start++;
          }
          *start++ = 0;
        } else {
          if (header_subtag(header) == subtag_function) {
#ifdef X8632
            int skip = (unsigned short)(start[1]);
#else
            int skip = (int)(start[1]);
#endif
            start += skip;
            nwords -= skip;
          }
          start++;
          while(nwords--) {
            copy_ivector_reference(start, low, high, to, what);
            start++;
          }
        }
      } else {
        /* Not a header, just a cons cell */
        copy_ivector_reference(start, low, high, to, what);
        start++;
        copy_ivector_reference(start, low, high, to, what);
        start++;
      }
    }
  }
}
        
/* Purify references from tstack areas */
void
purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
{
  LispObj
    *current,
    *next,
    *start = (LispObj *) (a->active),
    *end = start,
    *limit = (LispObj *) (a->high);

  for (current = start;
       end != limit;
       current = next) {
    next = (LispObj *) ptr_from_lispobj(*current);
    end = ((next >= start) && (next < limit)) ? next : limit;
    if (current[1] == 0) {
      purify_range(current+2, end, low, high, to, what);
    }
  }
}

/* Purify a vstack area */
void
purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what)
{
  LispObj
    *p = (LispObj *) a->active,
    *q = (LispObj *) a->high;
  
  purify_headerless_range(p, q, low, high, to, what);
}


void
purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what)
{
  natural *regs = (natural *) xpGPRvector(xp);


#ifdef X8664
  copy_ivector_reference(&(regs[Iarg_z]), low, high, to, what);
  copy_ivector_reference(&(regs[Iarg_y]), low, high, to, what);
  copy_ivector_reference(&(regs[Iarg_x]), low, high, to, what);
  copy_ivector_reference(&(regs[Isave3]), low, high, to, what);
  copy_ivector_reference(&(regs[Isave2]), low, high, to, what);
  copy_ivector_reference(&(regs[Isave1]), low, high, to, what);
  copy_ivector_reference(&(regs[Isave0]), low, high, to, what);
  copy_ivector_reference(&(regs[Ifn]), low, high, to, what);
  copy_ivector_reference(&(regs[Itemp0]), low, high, to, what);
  copy_ivector_reference(&(regs[Itemp1]), low, high, to, what);
  copy_ivector_reference(&(regs[Itemp2]), low, high, to, what);
#if 0
  purify_locref(&(regs[Iip]), low, high, to, what);
#endif
#else
#endif
}

void
purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
{
  natural n = tcr->tlb_limit;
  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);

  purify_range(start, end, low, high, to, what);
}

void
purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what)
{
  xframe_list *xframes;
  ExceptionInformation *xp;
  
  xp = tcr->gc_context;
  if (xp) {
    purify_xp(xp, low, high, to, what);
  }

  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
    purify_xp(xframes->curr, low, high, to, what);
  }
}


void
purify_areas(BytePtr low, BytePtr high, area *target, int what)
{
  area *next_area;
  area_code code;
      
  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
    switch (code) {
    case AREA_TSTACK:
      purify_tstack_area(next_area, low, high, target, what);
      break;
      
    case AREA_VSTACK:
      purify_vstack_area(next_area, low, high, target, what);
      break;
      
    case AREA_CSTACK:
#ifdef PPC
      purify_cstack_area(next_area, low, high, target, what);
#endif
      break;
      
    case AREA_STATIC:
    case AREA_DYNAMIC:
      purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what);
      break;
      
    default:
      break;
    }
  }
}

/*
  So far, this is mostly for save_application's benefit.
  We -should- be able to return to lisp code after doing this,
  however.

*/


int
purify(TCR *tcr, signed_natural param)
{
  extern area *extend_readonly_area(unsigned);
  area 
    *a = active_dynamic_area,
    *new_pure_area;

  TCR  *other_tcr;
  natural max_pure_size;
  OSErr err;
  BytePtr new_pure_start;

#ifdef X8664

  max_pure_size = interned_pname_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), 
                                         (LispObj *) a->active);
  new_pure_area = extend_readonly_area(max_pure_size);
  if (new_pure_area) {
    new_pure_start = new_pure_area->active;
    lisp_global(IN_GC) = (1<<fixnumshift);

    /* 
      First, loop thru *all-packages* and purify the pnames of all
      interned symbols.  Then walk every place that could reference
      a heap-allocated object (all_areas, the xframe_list) and
      purify code_vectors (and update the odd case of a shared
      reference to a pname.)
       
      Make the new_pure_area executable, just in case.

      Caller will typically GC again (and that should recover quite a bit of
      the dynamic heap.)
      */

    {
      lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES));
      LispObj pkg_list = rawsym->vcell, htab, obj;
      package *p;
      cons *c;
      natural elements, i;

      while (fulltag_of(pkg_list) == fulltag_cons) {
        c = (cons *) ptr_from_lispobj(untag(pkg_list));
        p = (package *) ptr_from_lispobj(untag(c->car));
        pkg_list = c->cdr;
        c = (cons *) ptr_from_lispobj(untag(p->itab));
        htab = c->car;
        elements = header_element_count(header_of(htab));
        for (i = 1; i<= elements; i++) {
          obj = deref(htab,i);
          if (fulltag_of(obj) == fulltag_symbol) {
            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
          }
        }
        c = (cons *) ptr_from_lispobj(untag(p->etab));
        htab = c->car;
        elements = header_element_count(header_of(htab));
        for (i = 1; i<= elements; i++) {
          obj = deref(htab,i);
          if (fulltag_of(obj) == fulltag_symbol) {
            rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj));
            copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS);
          }
        }
      }
    }
    
    purify_areas(a->low, a->active, new_pure_area, FORWARD_ONLY);
    
    other_tcr = tcr;
    do {
      purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
      purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY);
      other_tcr = other_tcr->next;
    } while (other_tcr != tcr);


    {
      natural puresize = (unsigned) (new_pure_area->active-new_pure_start);
      if (puresize != 0) {
        xMakeDataExecutable(new_pure_start, puresize);
  
      }
    }
    ProtectMemory(new_pure_area->low,
                  align_to_power_of_2(new_pure_area->active-new_pure_area->low,
                                      log2_page_size));
    lisp_global(IN_GC) = 0;
    just_purified_p = true;
    return 0;
  }
#endif
  return -1;
}


  
Boolean
impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta)
{
  LispObj q = *p;
  
  if (is_node_fulltag(fulltag_of(q)) &&
      (q >= low) && 
      (q < high)) {
    *p = (q+delta);
    return true;
  }
  return false;
}
  


void
impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta)
{
  natural *regs = (natural *) xpGPRvector(xp);


#ifdef X8664
  impurify_noderef(&(regs[Iarg_z]), low, high, delta);
  impurify_noderef(&(regs[Iarg_y]), low, high, delta);
  impurify_noderef(&(regs[Iarg_x]), low, high, delta);
  impurify_noderef(&(regs[Isave3]), low, high, delta);
  impurify_noderef(&(regs[Isave2]), low, high, delta);
  impurify_noderef(&(regs[Isave1]), low, high, delta);
  impurify_noderef(&(regs[Isave0]), low, high, delta);
  impurify_noderef(&(regs[Ifn]), low, high, delta);
  impurify_noderef(&(regs[Itemp0]), low, high, delta);
  impurify_noderef(&(regs[Itemp1]), low, high, delta);
#if 0
  impurify_locref(&(regs[Iip]), low, high, delta);
#endif
#else
#endif

}

void
impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
{
  while (start < end) {
    impurify_noderef(start, low, high, delta);
    start++;
  }
}


void
impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta)
{
#ifdef X8664

  LispObj header;
  unsigned tag;
  natural nwords;
  hash_table_vector_header *hashp;

  while (start < end) {
    header = *start;
    if (header == forward_marker) {
      start += 2;
    } else {
      tag = fulltag_of(header);
      if (immheader_tag_p(tag)) {
        start = (LispObj *)skip_over_ivector((natural)start, header);
      } else if (nodeheader_tag_p(tag)) {
        nwords = header_element_count(header);
        nwords += (1 - (nwords&1));
        if ((header_subtag(header) == subtag_hash_vector) &&
          ((((hash_table_vector_header *)start)->flags) & 
           nhash_track_keys_mask)) {
          natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1;

          hashp = (hash_table_vector_header *) start;
          start++;
          nwords -= skip;
          while(skip--) {
            impurify_noderef(start, low, high, delta);
            start++;
          }
          /* "nwords" is odd at this point: there are (floor nwords 2)
             key/value pairs to look at, and then an extra word for
             alignment.  Process them two at a time, then bump "start"
             past the alignment word. */
          nwords >>= 1;
          while(nwords--) {
            if (impurify_noderef(start, low, high, delta) && hashp) {
              hashp->flags |= nhash_key_moved_mask;
              hashp = NULL;
            }
            start++;
            impurify_noderef(start, low, high, delta);
            start++;
          }
          *start++ = 0;
        } else {
          if (header_subtag(header) == subtag_function) {
            int skip = (int)(start[1]);
            start += skip;
            nwords -= skip;
          }
          start++;
          while(nwords--) {
            impurify_noderef(start, low, high, delta);
            start++;
          }
        }
      } else {
        /* Not a header, just a cons cell */
        impurify_noderef(start, low, high, delta);
        start++;
        impurify_noderef(start, low, high, delta);
        start++;
      }
    }
  }
#endif
}




void
impurify_tcr_tlb(TCR *tcr,  LispObj low, LispObj high, int delta)
{
  unsigned n = tcr->tlb_limit;
  LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n);
  
  impurify_range(start, end, low, high, delta);
}

void
impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta)
{
  xframe_list *xframes;
  ExceptionInformation *xp;
  
  xp = tcr->gc_context;
  if (xp) {
    impurify_xp(xp, low, high, delta);
  }

  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
    impurify_xp(xframes->curr, low, high, delta);
  }
}

void
impurify_tstack_area(area *a, LispObj low, LispObj high, int delta)
{
  LispObj
    *current,
    *next,
    *start = (LispObj *) (a->active),
    *end = start,
    *limit = (LispObj *) (a->high);

  for (current = start;
       end != limit;
       current = next) {
    next = (LispObj *) ptr_from_lispobj(*current);
    end = ((next >= start) && (next < limit)) ? next : limit;
    if (current[1] == 0) {
      impurify_range(current+2, end, low, high, delta);
    }
  }
}
void
impurify_vstack_area(area *a, LispObj low, LispObj high, int delta)
{
  LispObj
    *p = (LispObj *) a->active,
    *q = (LispObj *) a->high;

  impurify_headerless_range(p, q, low, high, delta);
}


void
impurify_areas(LispObj low, LispObj high, int delta)
{
  area *next_area;
  area_code code;
      
  for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
    switch (code) {
    case AREA_TSTACK:
      impurify_tstack_area(next_area, low, high, delta);
      break;
      
    case AREA_VSTACK:
      impurify_vstack_area(next_area, low, high, delta);
      break;
      
    case AREA_CSTACK:
#ifdef PPC
      impurify_cstack_area(next_area, low, high, delta);
#endif
      break;
      
    case AREA_STATIC:
    case AREA_DYNAMIC:
      impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta);
      break;
      
    default:
      break;
    }
  }
}

int
impurify(TCR *tcr, signed_natural param)
{
  area *r = find_readonly_area();

  if (r) {
    area *a = active_dynamic_area;
    BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active,
      oldhigh = a->high, newhigh; 
    unsigned n = ro_limit - ro_base;
    int delta = oldfree-ro_base;
    TCR *other_tcr;

    if (n) {
      lisp_global(IN_GC) = 1;
      newhigh = (BytePtr) (align_to_power_of_2(oldfree+n,
                                               log2_heap_segment_size));
      if (newhigh > oldhigh) {
        grow_dynamic_area(newhigh-oldhigh);
      }
      a->active += n;
      bcopy(ro_base, oldfree, n);
      munmap((void *)ro_base, n);
      a->ndnodes = area_dnode(a, a->active);
      pure_space_active = r->active = r->low;
      r->ndnodes = 0;

      impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);

      other_tcr = tcr;
      do {
        impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
        impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta);
        other_tcr = other_tcr->next;
      } while (other_tcr != tcr);
      lisp_global(IN_GC) = 0;
    }
    return 0;
  }
  return -1;
}


void
adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
{
  LispObj p = *loc;
  
  if (area_dnode(p, base) < limit) {
    *loc = p+delta;
  }
}

/* like adjust_locref() above, but only changes the contents of LOC if it's
   a tagged lisp pointer */
void
adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta)
{
  LispObj p = *loc;
  int tag_n = fulltag_of(p);

  if (is_node_fulltag(tag_n)) {
    if (area_dnode(p, base) < limit) {
      *loc = p+delta;
    }
  }
}

/* 
   If *loc is a tagged pointer into the address range denoted by BASE and LIMIT,
   nuke it (set it to NIL.)
*/
void
nuke_noderef(LispObj *loc, LispObj base, LispObj limit)
{
  LispObj p = *loc;
  int tag_n = fulltag_of(p);

  if (is_node_fulltag(tag_n)) {
    if (area_dnode(p, base) < limit) {
      *loc = lisp_nil;
    }
  }
}


void
adjust_pointers_in_xp(ExceptionInformation *xp, 
                      LispObj base, 
                      LispObj limit, 
                      signed_natural delta) 
{
  natural *regs = (natural *) xpGPRvector(xp);

#ifdef X8664
  adjust_noderef((LispObj *) (&(regs[Iarg_z])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Iarg_y])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Iarg_x])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Isave3])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Isave2])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Isave1])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Isave0])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Ifn])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Itemp0])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Itemp1])),base,limit,delta);
  adjust_noderef((LispObj *) (&(regs[Itemp2])),base,limit,delta);
  adjust_locref((LispObj *) (&(xpPC(xp))),base,limit,delta);
#endif
}

void
nuke_pointers_in_xp(ExceptionInformation *xp, 
                      LispObj base, 
                      LispObj limit) 
{
  natural *regs = (natural *) xpGPRvector(xp);

#ifdef X8664
  nuke_noderef((LispObj *) (&(regs[Iarg_z])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Iarg_y])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Iarg_x])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Isave3])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Isave2])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Isave1])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Isave0])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Ifn])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Itemp0])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Itemp1])),base,limit);
  nuke_noderef((LispObj *) (&(regs[Itemp2])),base,limit);
#endif
}

void
adjust_pointers_in_headerless_range(LispObj *range_start,
                                    LispObj *range_end,
                                    LispObj base,
                                    LispObj limit,
                                    signed_natural delta)
{
  LispObj *p = range_start;

  while (p < range_end) {
    adjust_noderef(p, base, limit, delta);
    p++;
  }
}


void
adjust_pointers_in_range(LispObj *range_start,
                         LispObj *range_end,
                         LispObj base,
                         LispObj limit,
                         signed_natural delta)
{
  LispObj *p = range_start, node, new;
  int tag_n;
  natural nwords;
  hash_table_vector_header *hashp;

  while (p < range_end) {
    node = *p;
    tag_n = fulltag_of(node);
    if (immheader_tag_p(tag_n)) {
      p = (LispObj *) skip_over_ivector((natural) p, node);
    } else if (nodeheader_tag_p(tag_n)) {
      nwords = header_element_count(node);
      nwords += (1 - (nwords&1));
      if ((header_subtag(node) == subtag_hash_vector) &&
          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
        hashp = (hash_table_vector_header *) p;
        hashp->flags |= nhash_key_moved_mask;
      } else if (header_subtag(node) == subtag_function) {
        int skip = (int)(p[1]);
        p += skip;
        nwords -= skip;
      }
      p++;
      while (nwords--) {
        adjust_noderef(p, base, limit, delta);
        p++;
      }
    } else {
      /* just a cons */
      adjust_noderef(p, base, limit, delta);
      p++;
      adjust_noderef(p, base, limit, delta);
      p++;
    }
  }
}

void
nuke_pointers_in_headerless_range(LispObj *range_start,
                                  LispObj *range_end,
                                  LispObj base,
                                  LispObj limit)
{
  LispObj *p = range_start;

  while (p < range_end) {
    nuke_noderef(p, base, limit);
    p++;
  }
}


void
nuke_pointers_in_range(LispObj *range_start,
                         LispObj *range_end,
                         LispObj base,
                         LispObj limit)
{
  LispObj *p = range_start, node, new;
  int tag_n;
  natural nwords;

  while (p < range_end) {
    node = *p;
    tag_n = fulltag_of(node);
    if (immheader_tag_p(tag_n)) {
      p = (LispObj *) skip_over_ivector((natural) p, node);
    } else if (nodeheader_tag_p(tag_n)) {
      nwords = header_element_count(node);
      nwords += (1 - (nwords&1));
      if (header_subtag(node) == subtag_function) {
        int skip = (int)(p[1]);
        p += skip;
        nwords -= skip;
      }
      p++;
      while (nwords--) {
        nuke_noderef(p, base, limit);
        p++;
      }
    } else {
      /* just a cons */
      nuke_noderef(p, base, limit);
      p++;
      nuke_noderef(p, base, limit);
      p++;
    }
  }
}

void
adjust_pointers_in_tstack_area(area *a,
                               LispObj base,
                               LispObj limit,
                               LispObj delta)
{
  LispObj
    *current,
    *next,
    *start = (LispObj *) a->active,
    *end = start,
    *area_limit = (LispObj *) (a->high);

  for (current = start;
       end != area_limit;
       current = next) {
    next = ptr_from_lispobj(*current);
    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
    adjust_pointers_in_range(current+2, end, base, limit, delta);
  }
}

void
nuke_pointers_in_tstack_area(area *a,
                             LispObj base,
                             LispObj limit)
{
  LispObj
    *current,
    *next,
    *start = (LispObj *) a->active,
    *end = start,
    *area_limit = (LispObj *) (a->high);

  for (current = start;
       end != area_limit;
       current = next) {
    next = ptr_from_lispobj(*current);
    end = ((next >= start) && (next < area_limit)) ? next : area_limit;
    if (current[1] == 0) {
      nuke_pointers_in_range(current+2, end, base, limit);
    }
  }
}

void
adjust_pointers_in_vstack_area(area *a,
                               LispObj base,
                               LispObj limit,
                               LispObj delta)
{
  LispObj
    *p = (LispObj *) a->active,
    *q = (LispObj *) a->high;

  adjust_pointers_in_headerless_range(p, q, base, limit, delta);
}

void
nuke_pointers_in_vstack_area(area *a,
                             LispObj base,
                             LispObj limit)
{
  LispObj
    *p = (LispObj *) a->active,
    *q = (LispObj *) a->high;

  nuke_pointers_in_headerless_range(p, q, base, limit);
}

#ifdef PPC
void
adjust_pointers_in_cstack_area(area *a,
                               LispObj base,
                               LispObj limit,
                               LispObj delta)
{
  BytePtr
    current,
    next,
    area_limit = a->high,
    low = a->low;

  for (current = a->active; (current >= low) && (current < area_limit); current = next) {
    next = *((BytePtr *)current);
    if (next == NULL) break;
    if (((next - current) == sizeof(lisp_frame)) &&
        (((((lisp_frame *)current)->savefn) == 0) ||
         (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) {
      adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta);
      adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta);
    }
  }
}
#endif



void
adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta)
{
  TCR *tcr = current;
  xframe_list *xframes;
  LispObj *tlb_start, *tlb_end;
  ExceptionInformation *xp;

  do {
    xp = tcr->gc_context;
    if (xp) {
      adjust_pointers_in_xp(xp, base, limit, delta);
    }
    for (xframes = (xframe_list *) tcr->xframe;
         xframes;
         xframes = xframes->prev) {
      adjust_pointers_in_xp(xframes->curr, base, limit, delta);
    }
    adjust_pointers_in_range(tcr->tlb_pointer,
                             (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
                             base,
                             limit,
                             delta);
    tcr = tcr->next;
  } while (tcr != current);
}

void
nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit)
{
  TCR *tcr = current;
  xframe_list *xframes;
  LispObj *tlb_start, *tlb_end;
  ExceptionInformation *xp;

  do {
    xp = tcr->gc_context;
    if (xp) {
      nuke_pointers_in_xp(xp, base, limit);
    }
    for (xframes = (xframe_list *) tcr->xframe;
         xframes;
         xframes = xframes->prev) {
      nuke_pointers_in_xp(xframes->curr, base, limit);
    }
    nuke_pointers_in_range(tcr->tlb_pointer,
                           (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit),
                           base,
                           limit);
    tcr = tcr->next;
  } while (tcr != current);
}

void
adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta)
{
  /* These need to be special-cased, because xmacptrs are immediate
     objects that contain (in their "link" fields") tagged pointers
     to other xmacptrs */
  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next;

  while ((next = *prev) != (LispObj)NULL) {
    adjust_noderef(prev, base, limit, delta);
    if (delta < 0) {
      /* Assume that we've already moved things */
      next = *prev;
    }
    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
  }
}
    

void
adjust_pointers_in_dynamic_area(area *a, 
                                LispObj base, 
                                LispObj limit,
                                signed_natural delta)
{
  natural 
    nstatic = static_dnodes_for_area(a),
    nstatic_bitmap_words = nstatic >> bitmap_shift;
  LispObj 
    *low = (LispObj *) (a->low),
    *active = (LispObj *) (a->active),
    *dynamic_low = low + (2 * nstatic);

  adjust_pointers_in_range(dynamic_low, active, base, limit, delta);

  if (nstatic && (nstatic <= a->ndnodes)) {
    cons *pagelet_start = (cons *) a->low, *work;
    bitvector usedbits = tenured_area->static_used;
    natural used, i;
    
    while (nstatic_bitmap_words--) {
      used = *usedbits++;

      while (used) {
        i = count_leading_zeros(used);
        used &= ~(BIT0_MASK >> i);
        work = pagelet_start+i;
        adjust_noderef(&(work->cdr), base, limit, delta);
        adjust_noderef(&(work->car), base, limit, delta);
      }
      pagelet_start += nbits_in_word;
    }
  }
}

void
nuke_pointers_in_dynamic_area(area *a, 
                              LispObj base, 
                              LispObj limit)
{
  natural 
    nstatic = static_dnodes_for_area(a),
    nstatic_bitmap_words = nstatic >> bitmap_shift;
  LispObj 
    *low = (LispObj *) (a->low),
    *active = (LispObj *) (a->active),
    *dynamic_low = low + (2 * nstatic);

  nuke_pointers_in_range(dynamic_low, active, base, limit);

  if (nstatic && (nstatic <= a->ndnodes)) {
    cons *pagelet_start = (cons *) a->low, *work;
    bitvector usedbits = tenured_area->static_used;
    natural used, i;
    
    while (nstatic_bitmap_words--) {
      used = *usedbits++;

      while (used) {
        i = count_leading_zeros(used);
        used &= ~(BIT0_MASK >> i);
        work = pagelet_start+i;
        nuke_noderef(&(work->cdr), base, limit);
        nuke_noderef(&(work->car), base, limit);
      }
      pagelet_start += nbits_in_word;
    }
  }
}

    
void
adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta)
{
  area *next_area;
  area_code code;

  for (next_area = active_dynamic_area; 
       (code = next_area->code) != AREA_VOID;
       next_area = next_area->succ) {
    switch (code) {
    case AREA_TSTACK:
      adjust_pointers_in_tstack_area(next_area, base, limit, delta);
      break;
      
    case AREA_VSTACK:
      adjust_pointers_in_vstack_area(next_area, base, limit, delta);
      break;

    case AREA_CSTACK:
#ifndef X86
      adjust_pointers_in_cstack_area(next_area, base, limit, delta);
#endif
      break;

    case AREA_STATIC:
    case AREA_MANAGED_STATIC:
      adjust_pointers_in_range((LispObj *) (next_area->low),
                               (LispObj *) (next_area->active),
                               base,
                               limit,
                               delta);
      break;

    case AREA_DYNAMIC:
      adjust_pointers_in_dynamic_area(next_area, base, limit, delta);
      break;
    }
  }
  adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta);
  adjust_gcable_ptrs(base, limit, delta);
}

void
nuke_all_pointers(LispObj base, LispObj limit)
{
  area *next_area;
  area_code code;

  for (next_area = active_dynamic_area; 
       (code = next_area->code) != AREA_VOID;
       next_area = next_area->succ) {
    switch (code) {
    case AREA_TSTACK:
      nuke_pointers_in_tstack_area(next_area, base, limit);
      break;
      
    case AREA_VSTACK:
      nuke_pointers_in_vstack_area(next_area, base, limit);
      break;

    case AREA_CSTACK:
      /* There aren't any "nukable" pointers in a cstack area */
      break;

    case AREA_STATIC:
    case AREA_MANAGED_STATIC:
      nuke_pointers_in_range((LispObj *) (next_area->low),
                               (LispObj *) (next_area->active),
                               base,
                               limit);
      break;

    case AREA_DYNAMIC:
      nuke_pointers_in_dynamic_area(next_area, base, limit);
      break;
    }
  }
  nuke_pointers_in_tcrs(get_tcr(false), base, limit);
}

#ifndef MREMAP_MAYMOVE
#define MREMAP_MAYMOVE 1
#endif

#if defined(FREEBSD) || defined(SOLARIS)
void *
freebsd_mremap(void *old_address, 
               size_t old_size, 
               size_t new_size, 
               unsigned long flags)
{
  return old_address;
}
#define mremap freebsd_mremap

#endif

#ifdef DARWIN
void *
darwin_mremap(void *old_address, 
              size_t old_size, 
              size_t new_size, 
              unsigned long flags)
{
  void *end = (void *) ((char *)old_address+old_size);

  if (old_size == new_size) {
    return old_address;
  }
  if (new_size < old_size) {
    munmap(end, old_size-new_size);
    return old_address;
  }
  {
    void * new_address = mmap(NULL,
                              new_size,
                              PROT_READ|PROT_WRITE,
                              MAP_PRIVATE | MAP_ANON,
                              -1,
                              0);
    if (new_address !=  MAP_FAILED) {
      vm_copy(mach_task_self(),
              (vm_address_t)old_address,
              old_size,
              (vm_address_t)new_address);
      munmap(old_address, old_size);
    }
    return new_address;
  }
}

#define mremap darwin_mremap
#endif

Boolean
resize_used_bitvector(natural new_dnodes, bitvector *newbits)
{
  natural
    old_dnodes = tenured_area->static_dnodes,
    old_page_aligned_size =
    (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3),
                         log2_page_size)),
    new_page_aligned_size =
    (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3),
                         log2_page_size));
  bitvector old_used = tenured_area->static_used, new_used = NULL;

  if (old_page_aligned_size == new_page_aligned_size) {
    *newbits = old_used;
    return true;
  }

  if (old_used == NULL) {
    new_used = (bitvector)mmap(NULL,
                               new_page_aligned_size,
                               PROT_READ|PROT_WRITE,
                               MAP_PRIVATE | MAP_ANON,
                               -1,
                               0);
    if (new_used == MAP_FAILED) {
      *newbits = NULL;
      return false;
    } else {
      *newbits = new_used;
      return true;
    }
  }
  if (new_page_aligned_size == 0) {
    munmap((void *)old_used, old_page_aligned_size);
    *newbits = NULL;
    return true;
  }
    
  /* Have to try to remap the old bitmap.  That's implementation-dependent,
     and (naturally) Mach sucks, but no one understands how.
  */
  new_used = mremap(old_used, 
                    old_page_aligned_size, 
                    new_page_aligned_size, 
                    MREMAP_MAYMOVE);
  if (new_used == MAP_FAILED) {
    *newbits = NULL;
    return false;
  }
  *newbits = new_used;
  return true;
}

  
int
grow_hons_area(signed_natural delta_in_bytes)
{
  bitvector new_used;
  area *ada = active_dynamic_area;
  natural 
    delta_in_dnodes = delta_in_bytes >> dnode_shift,
    current_static_dnodes = tenured_area->static_dnodes,
    new_static_dnodes;
    
  delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word);
  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
  delta_in_bytes = delta_in_dnodes << dnode_shift;
  if (grow_dynamic_area((natural) delta_in_bytes)) {
    LispObj 
      base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)),
      oldactive = (LispObj) ada->active,
      limit = area_dnode(oldactive, base);
    if (!resize_used_bitvector(new_static_dnodes, &new_used)) {
      shrink_dynamic_area(delta_in_bytes);
      return -1;
    }
    tenured_area->static_used = new_used;
    adjust_all_pointers(base, limit, delta_in_bytes);
    memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base);
    ada->ndnodes = area_dnode(ada->high, ada->low);
    ada->active += delta_in_bytes;
    {
      LispObj *p;
      natural i;
      for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0;
           i< delta_in_dnodes;
           i++ ) {
        *p++ = undefined;
        *p++ = undefined;
      }
      tenured_area->static_dnodes += delta_in_dnodes;
          
    }
    return 0;
  }
  return -1;
}

int 
shrink_hons_area(signed_natural delta_in_bytes)
{
  area *ada = active_dynamic_area;
  signed_natural 
    delta_in_dnodes = delta_in_bytes >> dnode_shift;
  natural 
    current_static_dnodes = tenured_area->static_dnodes,
    new_static_dnodes;
  LispObj base, limit, oldactive;
  bitvector newbits;

    
  delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word);
  new_static_dnodes = current_static_dnodes+delta_in_dnodes;
  delta_in_bytes = delta_in_dnodes << dnode_shift;
  oldactive = (LispObj) (ada->active);

  resize_used_bitvector(new_static_dnodes, &newbits);
  tenured_area->static_used = newbits; /* redundant */

  memmove(ada->low+(new_static_dnodes << dnode_shift),
          ada->low+(current_static_dnodes << dnode_shift),
          oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift)));
  tenured_area->static_dnodes = new_static_dnodes;
  ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */
  shrink_dynamic_area(-delta_in_bytes);

  base = (LispObj) (tenured_area->low + 
                    (new_static_dnodes << dnode_shift));
  limit = area_dnode(tenured_area->low + 
                     (current_static_dnodes << dnode_shift), base);
  nuke_all_pointers(base, limit);

  base = (LispObj) (tenured_area->low + 
                    (current_static_dnodes << dnode_shift));
  limit = area_dnode(oldactive, base);
  adjust_all_pointers(base, limit, delta_in_bytes);

  xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift),
                      ada->active-(tenured_area->low+(tenured_area->static_dnodes<<dnode_shift)));
  return 0;
}

int
change_hons_area_size(TCR *tcr, signed_natural delta_in_bytes)
{
  if (delta_in_bytes > 0) {
    return grow_hons_area(delta_in_bytes);
  }
  if (delta_in_bytes < 0) {
    return shrink_hons_area(delta_in_bytes);
  }
  return 0;
}