/* New incremental garbage collector for XEmacs.
   Copyright (C) 2005 Marcus Crestani.
   Copyright (C) 2010 Ben Wing.

This file is part of XEmacs.

XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.

XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* Synched up with: Not in FSF. */

/* 
   Garbage Collectors in XEmacs

   Currently, XEmacs comes with two garbage collectors:

   - The "old garbage collector": a simple mark and sweep collector,
     its implementation is mainly spread out over gc.c and alloc.c.
     It is used by the default configuration or if you configure
     `--with-newgc=no'.

   - The "new garbage collector": an incremental mark and sweep collector,
     its implementation is in gc.c.  It is used if you configure
     `--with-newgc'.  It comes with a new allocator, see mc-alloc.c, and
     with the KKCC mark algorith, see below.

   Additionally, the old garbage collectors comes with two mark algorithms:

   - The "recursive mark algorithm" marks live objects by recursively
     calling mark_* functions on live objects.  It is the default mark 
     algorithm of the old garbage collector.

   - The "KKCC mark algorithm" uses an explicit stack that to keep
     track of the current progress of traversal and uses memory layout
     descriptions (that are also used by the portable dumper) instead
     of the mark_* functions.  The old garbage collector uses it if
     you configure `--with-kkcc'.  It is the default and only mark
     algorithm of the new garbage collector.


   The New Incremental Garbage Collector

   An incremental garbage collector keeps garbage collection pause
   times short by interleaving small amounts of collection work with
   program execution, it does that by instrumenting write barrier
   algorithms that essentially allow interrupting the mark phase.


   Write Barrier

   A write barrier is the most important prerequisite for fancy
   garbage collection techniques.  We implement a "Virtual Dirty Bit
   (short: vdb) Write Barrier" that makes uses of the operating
   system's memory-protection mechanisms: The write barrier
   write-protects memory pages containing heap objects.  If the
   mutator tries to modify these objects by writing into the
   write-protected page, the operating system generates a fault.  The
   write barrier catches this fault, reads out the error-causing
   address and can thus identify the updated object and page.

   Not all environments and operating systems provide the mechanism to
   write-protect memory, catch resulting write faults, and read out
   the faulting address.  But luckily, most of today's operating
   systems provide the features needed for the write-barrier
   implementation.  Currently, XEmacs includes write-barrier
   implementations for the following platforms:

   - POSIX-compliant platforms like up-to-date UNIX, Linux, Solaris,
     etc. use the system call `mprotect' for memory protection,
     `sigaction' for signal handling and get the faulting address from
     `struct siginfo'.  See file vdb-posix.c.

  - Mach-based systems like Mac OS X use "Mach Exception Handlers".
    See file vdb-mach.c.

  - Windows systems like native Windows and Cygwin use Microsoft's
    so-called "Structured Exception Handling".  See file vdb-win32.c.
 
  The configure script determines which write barrier implementation
  to use for a system.  If no write barrier implementation is working
  on that system, a fall-back "fake" implementation is used: This
  implementation simply turns of the incremental write barrier at
  runtime and does not allow any incremental collection (see
  vdb-fake.c).  The garbage collector then acts like a traditional
  mark-and-sweep garbage collector.  Generally, the incremental
  garbage collector can be turned of at runtime by the user or by
  applications, see below.
   
   
  Memory Protection and Object Layout

  Implementations of a memory-protection mechanism may restrict the
  size and the alignment of the memory region to be on page-size
  boundaries.  All objects subject to be covered by the write barrier
  have to be allocated on logical memory pages, so that they meet the
  requirement to be write-protected.  The new allocator mc-alloc is
  aware of a system page size---it allocates all Lisp objects on
  logical memory pages and is therefore defaulted to on when the new
  garbage collector is enabled.

  Unfortunately, the Lisp object layout that works with the old
  collector leads to holes in the write barrier: Not all data
  structures containing pointers to Lisp objects are allocated on the
  Lisp heap.  Some Lisp objects do not carry all their information in
  the object itself.  External parts are kept in separately allocated
  memory blocks that are not managed by the new Lisp allocator.
  Examples for these objects are hash tables and dynamic arrays, two
  objects that can dynamically grow and shrink.  The separate memory
  blocks are not guaranteed to reside on page boundaries, and thus
  cannot be watched by the write barrier.

  Moreover, the separate parts can contain live pointers to other Lisp
  objects.  These pointers are not covered by the write barrier and
  modifications by the client during garbage collection do escape.  In
  this case, the client changes the connectivity of the reachability
  graph behind the collector's back, which eventually leads to
  erroneous collection of live objects.  To solve this problem, I
  transformed the separately allocated parts to fully qualified Lisp
  objects that are managed by the allocator and thus are covered by
  the write barrier.  This also removes a lot of special allocation
  and removal code for the out-sourced parts.  Generally, allocating
  all data structures that contain pointers to Lisp objects on one
  heap makes the whole memory layout more consistent.


  Debugging

  The virtual-dirty-bit write barrier provokes signals on purpose,
  namely SIGSEGV and SIGBUS.  When debugging XEmacs with this write
  barrier running, the debugger always breaks whenever a signal
  occurs.  This behavior is generally desired: A debugger has to break
  on signals, to allow the user to examine the cause of the
  signal---especially for illegal memory access, which is a common
  programming error.  But the debugger should not break for signals
  caused by the write barrier.  Therefore, most debuggers provide the
  ability to turn of their fault handling for specific signals.  The
  configure script generates the debugger's settings .gdbinit and
  .dbxrc, adding code to turn of signal handling for SIGSEGV and
  SIGBUS, if the new garbage collector is used.

  But what happens if a bug in XEmacs causes an illegal memory access?
  To maintain basic debugging abilities, we use another signal: First,
  the write-barrier signal handler has to determine if the current
  error situation is caused by the write-barrier memory protection or
  not.  Therefore, the signal handler checks if the faulting address
  has been write-protected before.  If it has not, the fault is caused
  by a bug; the debugger has to break in this situation.  To achieve
  this, the signal handler raises SIGABRT to abort the program.  Since
  SIGABRT is not masked out by the debugger, XEmacs aborts and allows
  the user to examine the problem.


  Incremental Garbage Collection

  The new garbage collector is still a mark-and-sweep collector, but
  now the mark phase no longer runs in one atomic action, it is
  interleaved with program execution.  The incremental garbage
  collector needs an explicit mark stack to store the state of the
  incremental traversal: the KKCC mark algorithm is a prerequisite and
  is enabled by default when the new garbage collector is on.

  Garbage collection is invoked as before: After `gc-cons-threshold'
  bytes have been allocated since the last garbage collection (or
  after `gc-cons-percentage' percentage of the total amount of memory
  used for Lisp data has been allocated since the last garbage
  collection) a collection starts.  After some initialization, the
  marking begins.

  The variable `gc-incremental-traversal-threshold' contains how many
  steps of incremental work have to be executed in one incremental
  traversal cycle.  After that many steps have been made, the mark
  phase is interrupted and the client resumes.  Now, the Lisp memory
  is write-protected and the write barrier records modified objects.
  Incremental traversal is resumed after
  `gc-cons-incremental-threshold' bytes have been allocated since the
  interruption of garbage collection.  Then, the objects recorded by
  the write-barrier have to be re-examined by the traversal, i.e. they
  are re-pushed onto the mark stack and processed again.  Once the
  mark stack is empty, the traversal is done.

  A full incremental collection is slightly slower than a full garbage
  collection before: There is an overhead for storing pointers into
  objects when the write barrier is running, and an overhead for
  repeated traversal of modified objects.  However, the new
  incremental garbage collector reduces client pause times to
  one-third, so even when a garbage collection is running, XEmacs
  stays reactive.


  Tricolor Marking: White, Black, and Grey Mark Bits

  Garbage collection traverses the graph of reachable objects and
  colors them. The objects subject to garbage collection are white at
  the beginning. By the end of the collection, those that will be
  retained are colored black. When there are no reachable objects left
  to blacken, the traversal of live data structures is finished. In
  traditional mark-and-sweep collectors, this black and white coloring
  is sufficient.

  In an incremental collector, the intermediate state of the traversal
  is im- portant because of ongoing mutator activity: the mutator
  cannot be allowed to change things in such way that the collector
  will fail to find all reachable objects. To understand and prevent
  such interactions between the mutator and the collector, it is
  useful to introduce a third color, grey.

  Grey objects have been reached by the traversal, but its descendants
  may not have been. White objects are changed to grey when they are
  reached by the traversal. Grey objects mark the current state of the
  traversal: traversal pro- ceeds by processing the grey objects. The
  KKCC mark stack holds all the currently grey-colored objects.
  Processing a grey object means following its outgoing pointers, and
  coloring it black afterwards.

  Intuitively, the traversal proceeds in a wavefront of grey objects
  that separates the unreached objects, which are colored white, from
  the already processed black objects.

  The allocator takes care of storing the mark bits: The mark bits are
  kept in a tree like structure, for details see mc-alloc.c.


  Internal States of the Incremental Garbage Collector

  To keep track of its current state, the collector holds it's current
  phase in the global `gc_state' variable.  A collector phase is one
  of the following:

  NONE  No incremental or full collection is currently running.

  INIT_GC  The collector prepares for a new collection, e.g. sets some
    global variables.

  PUSH_ROOT_SET  The collector pushes the root set on the mark stack 
    to start the traversal of live objects.

  MARK   The traversal of live objects colors the reachable objects
    white, grey, or black, according to their lifeness.  The mark
    phase can be interrupted by the incremental collection algorithm:
    Before the client (i.e. the non collector part of XEmacs) resumes,
    the write barrier has to be installed so that the collector knows
    what objects get modified during the collector's pause.
    Installing a write barrier means protecting pages that only
    contain black objects and recording write access to these objects.
    Pages with white or grey objects do not need to be protected,
    since these pages are due to marking anyways when the collector
    resumes.  Once the collector resumes, it has to re-scan all
    objects that have been modified during the collector pause and
    have been caught by the write barrier.  The mark phase is done when
    there are no more grey objects on the heap, i.e. the KKCC mark stack
    is empty.

  REPUSH_ROOT_SET  After the mark phase is done, the collector has to 
    traverse the root set pointers again, since modifications to the
    objects in the root set can not all be covered by the write barrier
    (e.g. root set objects that are on the call stack).  Therefore, the
    collector has to traverse the root set again without interruption.

  FINISH_MARK  After the mark phase is finished, some objects with
    special liveness semantics have to be treated separately, e.g.
    ephemerons and the various flavors of weak objects.

  FINALIZE  The collector registers all objects that have finalizers
    for finalization.  Finalizations happens asynchronously sometimes
    after the collection has finished.

  SWEEP  The allocator scans the entire heap and frees all white marked
    objects. The freed memory is recycled and can be re-used for future
    allocations. The sweep phase is carried out atomically.

  FINISH_GC  The collector cleans up after the garbage collection by
    resetting some global variables.


  Lisp Interface

  The new garbage collector can be accessed directly from Emacs Lisp.
  Basically, two functions invoke the garbage collector:

  (gc-full) starts a full garbage collection.  If an incremental
    garbage collection is already running, it is finished without
    further interruption.  This function guarantees that unused
    objects have been freed when it returns.

  (gc-incremental) starts an incremental garbage collection.  If an
    incremental garbage collection is already running, the next cycle
    of incremental traversal is started.  The garbage collection is
    finished if the traversal completes.  Note that this function does
    not necessarily free any memory.  It only guarantees that the
    traversal of the heap makes progress.

  The old garbage collector uses the function (garbage-collect) to
  invoke a garbage collection.  This function is still in use by some
  applications that explicitly want to invoke a garbage collection.
  Since these applications may expect that unused memory has really
  been freed when (garbage-collect) returns, it maps to (gc-full).

  The new garbage collector is highly customizable during runtime; it
  can even be switched back to the traditional mark-and-sweep garbage
  collector: The variable allow-incremental-gc controls whether
  garbage collections may be interrupted or if they have to be carried
  out in one atomic action.  Setting allow-incremental-gc to nil
  prevents incremental garbage collection, and the garbage collector
  then only does full collects, even if (gc-incremental) is called.
  Non-nil allows incremental garbage collection.

  This way applications can freely decide what garbage collection
  algorithm is best for the upcoming memory usage.  How frequently a
  garbage collection occurs and how much traversal work is done in one
  incremental cycle can also be modified during runtime.  See

    M-x customize RET alloc RET

  for an overview of all settings.


  More Information

  More details can be found in
  http://crestani.de/xemacs/pdf/thesis-newgc.pdf .

*/

#include <config.h>
#include "lisp.h"

#include "backtrace.h"
#include "buffer.h"
#include "bytecode.h"
#include "chartab.h"
#include "console-stream.h"
#include "device.h"
#include "elhash.h"
#include "events.h"
#include "extents-impl.h"
#include "file-coding.h"
#include "frame-impl.h"
#include "gc.h"
#include "glyphs.h"
#include "opaque.h"
#include "lrecord.h"
#include "lstream.h"
#include "process.h"
#include "profile.h"
#include "redisplay.h"
#include "specifier.h"
#include "sysfile.h"
#include "sysdep.h"
#include "window.h"
#include "vdb.h"


/* Number of bytes of consing since gc before a full gc should happen. */
#define GC_CONS_THRESHOLD                  2000000

/* Number of bytes of consing since gc before another cycle of the gc
   should happen in incremental mode. */
#define GC_CONS_INCREMENTAL_THRESHOLD       200000

/* Number of elements marked in one cycle of incremental GC. */
#define GC_INCREMENTAL_TRAVERSAL_THRESHOLD  100000

/* Number of bytes of consing done since the last GC. */
EMACS_INT consing_since_gc;

/* Number of bytes of consing done since startup. */
EMACS_UINT total_consing;

/* Number of bytes of current allocated heap objects. */
EMACS_INT total_gc_usage;

/* If the above is set. */
int total_gc_usage_set;

/* Number of bytes of consing since gc before another gc should be done. */
EMACS_INT gc_cons_threshold;

/* Nonzero during gc */
int gc_in_progress;

/* Percentage of consing of total data size before another GC. */
EMACS_INT gc_cons_percentage;

#ifdef NEW_GC
/* Number of bytes of consing since gc before another cycle of the gc
   should be done in incremental mode. */
EMACS_INT gc_cons_incremental_threshold;

/* Number of elements marked in one cycle of incremental GC. */
EMACS_INT gc_incremental_traversal_threshold;

/* Nonzero during write barrier */
int write_barrier_enabled;
#endif /* NEW_GC */



#ifdef NEW_GC
/************************************************************************/
/*		   Incremental State and Statistics   			*/
/************************************************************************/

enum gc_phase
{
  NONE,
  INIT_GC,
  PUSH_ROOT_SET,
  MARK,
  REPUSH_ROOT_SET,
  FINISH_MARK,
  FINALIZE,
  SWEEP,
  FINISH_GC
};

#ifndef ERROR_CHECK_GC
typedef struct gc_state_type
{
  enum gc_phase phase;
} gc_state_type;
#else /* ERROR_CHECK_GC */
enum gc_stat_id
{
  GC_STAT_TOTAL,
  GC_STAT_IN_LAST_GC,
  GC_STAT_IN_THIS_GC,
  GC_STAT_IN_LAST_CYCLE,
  GC_STAT_IN_THIS_CYCLE,
  GC_STAT_COUNT /* has to be last */
};

typedef struct gc_state_type
{
  enum gc_phase phase;
  double n_gc[GC_STAT_COUNT];
  double n_cycles[GC_STAT_COUNT];
  double enqueued[GC_STAT_COUNT];
  double dequeued[GC_STAT_COUNT];
  double repushed[GC_STAT_COUNT];
  double enqueued2[GC_STAT_COUNT];
  double dequeued2[GC_STAT_COUNT];
  double finalized[GC_STAT_COUNT];
  double freed[GC_STAT_COUNT];
} gc_state_type;
#endif /* ERROR_CHECK_GC */

gc_state_type gc_state;

#define GC_PHASE gc_state.phase
#define GC_SET_PHASE(p) GC_PHASE = p

#ifdef ERROR_CHECK_GC
# define GC_STAT_START_NEW_GC gc_stat_start_new_gc ()
# define GC_STAT_RESUME_GC gc_stat_resume_gc ()

#define GC_STAT_TICK(STAT)			\
  gc_state.STAT[GC_STAT_TOTAL]++;		\
  gc_state.STAT[GC_STAT_IN_THIS_GC]++;	\
  gc_state.STAT[GC_STAT_IN_THIS_CYCLE]++

# define GC_STAT_ENQUEUED			\
  if (GC_PHASE == REPUSH_ROOT_SET)		\
    {						\
      GC_STAT_TICK (enqueued2);			\
    }						\
  else						\
    {						\
      GC_STAT_TICK (enqueued);			\
    } 

# define GC_STAT_DEQUEUED			\
  if (gc_state.phase == REPUSH_ROOT_SET)	\
    {						\
      GC_STAT_TICK (dequeued2);			\
    }						\
  else						\
    {						\
      GC_STAT_TICK (dequeued);			\
    } 
# define GC_STAT_REPUSHED GC_STAT_TICK (repushed)

#define GC_STAT_RESUME(stat)			\
  gc_state.stat[GC_STAT_IN_LAST_CYCLE] =	\
    gc_state.stat[GC_STAT_IN_THIS_CYCLE];	\
  gc_state.stat[GC_STAT_IN_THIS_CYCLE] = 0

#define GC_STAT_RESTART(stat)			\
  gc_state.stat[GC_STAT_IN_LAST_GC] =		\
    gc_state.stat[GC_STAT_IN_THIS_GC];	\
  gc_state.stat[GC_STAT_IN_THIS_GC] = 0;	\
  GC_STAT_RESUME (stat)

static void
gc_stat_start_new_gc (void)
{
  gc_state.n_gc[GC_STAT_TOTAL]++;
  gc_state.n_cycles[GC_STAT_TOTAL]++;
  gc_state.n_cycles[GC_STAT_IN_LAST_GC] = gc_state.n_cycles[GC_STAT_IN_THIS_GC];
  gc_state.n_cycles[GC_STAT_IN_THIS_GC] = 1;
  
  GC_STAT_RESTART (enqueued);
  GC_STAT_RESTART (dequeued);
  GC_STAT_RESTART (repushed);
  GC_STAT_RESTART (finalized);
  GC_STAT_RESTART (enqueued2);
  GC_STAT_RESTART (dequeued2);
  GC_STAT_RESTART (freed);
} 

static void
gc_stat_resume_gc (void)
{
  gc_state.n_cycles[GC_STAT_TOTAL]++;
  gc_state.n_cycles[GC_STAT_IN_THIS_GC]++;
  GC_STAT_RESUME (enqueued);
  GC_STAT_RESUME (dequeued);
  GC_STAT_RESUME (repushed);
  GC_STAT_RESUME (finalized);
  GC_STAT_RESUME (enqueued2);
  GC_STAT_RESUME (dequeued2);
  GC_STAT_RESUME (freed);
}

void
gc_stat_finalized (void)
{
  GC_STAT_TICK (finalized);
}

void
gc_stat_freed (void)
{
  GC_STAT_TICK (freed);
}

DEFUN("gc-stats", Fgc_stats, 0, 0 ,"", /*
Return statistics about garbage collection cycles in a property list.
*/
      ())
{
  Lisp_Object pl = Qnil;
#define PL(name,value) \
  pl = cons3 (intern (name), make_float (gc_state.value), pl)

  PL ("freed-in-this-cycle", freed[GC_STAT_IN_THIS_CYCLE]);
  PL ("freed-in-this-gc", freed[GC_STAT_IN_THIS_GC]);
  PL ("freed-in-last-cycle", freed[GC_STAT_IN_LAST_CYCLE]);
  PL ("freed-in-last-gc", freed[GC_STAT_IN_LAST_GC]);
  PL ("freed-total", freed[GC_STAT_TOTAL]);
  PL ("finalized-in-this-cycle", finalized[GC_STAT_IN_THIS_CYCLE]);
  PL ("finalized-in-this-gc", finalized[GC_STAT_IN_THIS_GC]);
  PL ("finalized-in-last-cycle", finalized[GC_STAT_IN_LAST_CYCLE]);
  PL ("finalized-in-last-gc", finalized[GC_STAT_IN_LAST_GC]);
  PL ("finalized-total", finalized[GC_STAT_TOTAL]);
  PL ("repushed-in-this-cycle", repushed[GC_STAT_IN_THIS_CYCLE]);
  PL ("repushed-in-this-gc", repushed[GC_STAT_IN_THIS_GC]);
  PL ("repushed-in-last-cycle", repushed[GC_STAT_IN_LAST_CYCLE]);
  PL ("repushed-in-last-gc", repushed[GC_STAT_IN_LAST_GC]);
  PL ("repushed-total", repushed[GC_STAT_TOTAL]);
  PL ("dequeued2-in-this-cycle", dequeued2[GC_STAT_IN_THIS_CYCLE]);
  PL ("dequeued2-in-this-gc", dequeued2[GC_STAT_IN_THIS_GC]);
  PL ("dequeued2-in-last-cycle", dequeued2[GC_STAT_IN_LAST_CYCLE]);
  PL ("dequeued2-in-last-gc", dequeued2[GC_STAT_IN_LAST_GC]);
  PL ("dequeued2-total", dequeued2[GC_STAT_TOTAL]);
  PL ("enqueued2-in-this-cycle", enqueued2[GC_STAT_IN_THIS_CYCLE]);
  PL ("enqueued2-in-this-gc", enqueued2[GC_STAT_IN_THIS_GC]);
  PL ("enqueued2-in-last-cycle", enqueued2[GC_STAT_IN_LAST_CYCLE]);
  PL ("enqueued2-in-last-gc", enqueued2[GC_STAT_IN_LAST_GC]);
  PL ("enqueued2-total", enqueued2[GC_STAT_TOTAL]);
  PL ("dequeued-in-this-cycle", dequeued[GC_STAT_IN_THIS_CYCLE]);
  PL ("dequeued-in-this-gc", dequeued[GC_STAT_IN_THIS_GC]);
  PL ("dequeued-in-last-cycle", dequeued[GC_STAT_IN_LAST_CYCLE]);
  PL ("dequeued-in-last-gc", dequeued[GC_STAT_IN_LAST_GC]);
  PL ("dequeued-total", dequeued[GC_STAT_TOTAL]);
  PL ("enqueued-in-this-cycle", enqueued[GC_STAT_IN_THIS_CYCLE]);
  PL ("enqueued-in-this-gc", enqueued[GC_STAT_IN_THIS_GC]);
  PL ("enqueued-in-last-cycle", enqueued[GC_STAT_IN_LAST_CYCLE]);
  PL ("enqueued-in-last-gc", enqueued[GC_STAT_IN_LAST_GC]);
  PL ("enqueued-total", enqueued[GC_STAT_TOTAL]);
  PL ("n-cycles-in-this-gc", n_cycles[GC_STAT_IN_THIS_GC]);
  PL ("n-cycles-in-last-gc", n_cycles[GC_STAT_IN_LAST_GC]);
  PL ("n-cycles-total", n_cycles[GC_STAT_TOTAL]);
  PL ("n-gc-total", n_gc[GC_STAT_TOTAL]);
  PL ("phase", phase);
  return pl;
}
#else /* not ERROR_CHECK_GC */
# define GC_STAT_START_NEW_GC
# define GC_STAT_RESUME_GC
# define GC_STAT_ENQUEUED
# define GC_STAT_DEQUEUED
# define GC_STAT_REPUSHED
# define GC_STAT_REMOVED
#endif /* not ERROR_CHECK_GC */
#endif /* NEW_GC */


/************************************************************************/
/*		Recompute need to garbage collect			*/
/************************************************************************/

int need_to_garbage_collect;

#ifdef ERROR_CHECK_GC
int always_gc = 0;    		/* Debugging hack; equivalent to
				   (setq gc-cons-thresold -1) */
#else
#define always_gc 0
#endif

/* True if it's time to garbage collect now. */
void
recompute_need_to_garbage_collect (void)
{
  if (always_gc)
    need_to_garbage_collect = 1;
  else
    need_to_garbage_collect = 
#ifdef NEW_GC
      write_barrier_enabled ? 
      (consing_since_gc > gc_cons_incremental_threshold) :
#endif /* NEW_GC */
      (consing_since_gc > gc_cons_threshold
       &&
#if 0 /* #### implement this better */
       ((double)consing_since_gc) / total_data_usage()) >=
      ((double)gc_cons_percentage / 100)
#else
       (!total_gc_usage_set ||
	((double)consing_since_gc / total_gc_usage) >=
	((double)gc_cons_percentage / 100))
#endif
       );
  recompute_funcall_allocation_flag ();
}



/************************************************************************/
/*			      Mark Phase       				*/
/************************************************************************/

static const struct memory_description lisp_object_description_1[] = {
  { XD_LISP_OBJECT, 0 },
  { XD_END }
};

const struct sized_memory_description lisp_object_description = {
  sizeof (Lisp_Object),
  lisp_object_description_1
};

#if defined (USE_KKCC) || defined (PDUMP)

/* This function extracts the value of a count variable described somewhere 
   else in the description. It is converted corresponding to the type */ 
EMACS_INT
lispdesc_indirect_count_1 (EMACS_INT code,
			   const struct memory_description *idesc,
			   const void *idata)
{
  EMACS_INT count;
  const void *irdata;

  int line = XD_INDIRECT_VAL (code);
  int delta = XD_INDIRECT_DELTA (code);

  irdata = ((char *) idata) +
    lispdesc_indirect_count (idesc[line].offset, idesc, idata);
  switch (idesc[line].type)
    {
    case XD_BYTECOUNT:
      count = * (Bytecount *) irdata;
      break;
    case XD_ELEMCOUNT:
      count = * (Elemcount *) irdata;
      break;
    case XD_HASHCODE:
      count = * (Hashcode *) irdata;
      break;
    case XD_INT:
      count = * (int *) irdata;
      break;
    case XD_LONG:
      count = * (long *) irdata;
      break;
    default:
      stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n",
		  idesc[line].type, line, (long) code);
#if defined (USE_KKCC) && defined (DEBUG_XEMACS)
      if (gc_in_progress)
	kkcc_detailed_backtrace ();
#endif
#ifdef PDUMP
      if (in_pdump)
	pdump_backtrace ();
#endif
      count = 0; /* warning suppression */
      ABORT ();
    }
  count += delta;
  return count;
}

/* SDESC is a "description map" (basically, a list of offsets used for
   successive indirections) and OBJ is the first object to indirect off of.
   Return the description ultimately found. */

const struct sized_memory_description *
lispdesc_indirect_description_1 (const void *obj,
				 const struct sized_memory_description *sdesc)
{
  int pos;

  for (pos = 0; sdesc[pos].size >= 0; pos++)
    obj = * (const void **) ((const char *) obj + sdesc[pos].size);

  return (const struct sized_memory_description *) obj;
}

/* Compute the size of the data at RDATA, described by a single entry
   DESC1 in a description array.  OBJ and DESC are used for
   XD_INDIRECT references. */

static Bytecount
lispdesc_one_description_line_size (void *rdata,
				    const struct memory_description *desc1,
				    const void *obj,
				    const struct memory_description *desc)
{
 union_switcheroo:
  switch (desc1->type)
    {
    case XD_LISP_OBJECT_ARRAY:
      {
	EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
	return (val * sizeof (Lisp_Object));
      }
    case XD_LISP_OBJECT:
    case XD_LO_LINK:
      return sizeof (Lisp_Object);
    case XD_OPAQUE_PTR:
      return sizeof (void *);
#ifdef NEW_GC
    case XD_INLINE_LISP_OBJECT_BLOCK_PTR:
#endif /* NEW_GC */
    case XD_BLOCK_PTR:
      {
	EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
	return val * sizeof (void *);
      }
    case XD_BLOCK_ARRAY:
      {
	EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
	    
	return (val *
		lispdesc_block_size
		(rdata,
		 lispdesc_indirect_description (obj, desc1->data2.descr)));
      }
    case XD_OPAQUE_DATA_PTR:
      return sizeof (void *);
    case XD_UNION_DYNAMIC_SIZE:
      {
	/* If an explicit size was given in the first-level structure
	   description, use it; else compute size based on current union
	   constant. */
	const struct sized_memory_description *sdesc =
	  lispdesc_indirect_description (obj, desc1->data2.descr);
	if (sdesc->size)
	  return sdesc->size;
	else
	  {
	    desc1 = lispdesc_process_xd_union (desc1, desc, obj);
	    if (desc1)
	      goto union_switcheroo;
	    break;
	  }
      }
    case XD_UNION:
      {
	/* If an explicit size was given in the first-level structure
	   description, use it; else compute size based on maximum of all
	   possible structures. */
	const struct sized_memory_description *sdesc =
	  lispdesc_indirect_description (obj, desc1->data2.descr);
	if (sdesc->size)
	  return sdesc->size;
	else
	  {
	    int count;
	    Bytecount max_size = -1, size;

	    desc1 = sdesc->description;

	    for (count = 0; desc1[count].type != XD_END; count++)
	      {
		size = lispdesc_one_description_line_size (rdata,
							   &desc1[count],
							   obj, desc);
		if (size > max_size)
		  max_size = size;
	      }
	    return max_size;
	  }
      }
    case XD_ASCII_STRING:
      return sizeof (void *);
    case XD_DOC_STRING:
      return sizeof (void *);
    case XD_INT_RESET:
      return sizeof (int);
    case XD_BYTECOUNT:
      return sizeof (Bytecount);
    case XD_ELEMCOUNT:
      return sizeof (Elemcount);
    case XD_HASHCODE:
      return sizeof (Hashcode);
    case XD_INT:
      return sizeof (int);
    case XD_LONG:
      return sizeof (long);
    default:
      stderr_out ("Unsupported dump type : %d\n", desc1->type);
      ABORT ();
    }

  return 0;
}


/* Return the size of the memory block (NOT necessarily a structure!) 
   described by SDESC and pointed to by OBJ.  If SDESC records an
   explicit size (i.e. non-zero), it is simply returned; otherwise,
   the size is calculated by the maximum offset and the size of the
   object at that offset, rounded up to the maximum alignment.  In
   this case, we may need the object, for example when retrieving an
   "indirect count" of an inlined array (the count is not constant,
   but is specified by one of the elements of the memory block). (It
   is generally not a problem if we return an overly large size -- we
   will simply end up reserving more space than necessary; but if the
   size is too small we could be in serious trouble, in particular
   with nested inlined structures, where there may be alignment
   padding in the middle of a block. #### In fact there is an (at
   least theoretical) problem with an overly large size -- we may
   trigger a protection fault when reading from invalid memory.  We
   need to handle this -- perhaps in a stupid but dependable way,
   i.e. by trapping SIGSEGV and SIGBUS.) */

Bytecount
lispdesc_block_size_1 (const void *obj, Bytecount size,
		       const struct memory_description *desc)
{
  EMACS_INT max_offset = -1;
  int max_offset_pos = -1;
  int pos;

  if (size)
    return size;

  for (pos = 0; desc[pos].type != XD_END; pos++)
    {
      EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj);
      if (offset == max_offset)
	{
#if 0
	  /* This can legitimately happen with gap arrays -- if there are
	     no elements in the array, and the gap size is 0, then both
	     parts of the array will be of size 0 and in the same place. */
	  stderr_out ("Two relocatable elements at same offset?\n");
	  ABORT ();
#endif
	}
      else if (offset > max_offset)
	{
	  max_offset = offset;
	  max_offset_pos = pos;
	}
    }

  if (max_offset_pos < 0)
    return 0;

  {
    Bytecount size_at_max;
    size_at_max =
      lispdesc_one_description_line_size ((char *) obj + max_offset,
					  &desc[max_offset_pos], obj, desc);

    /* We have no way of knowing the required alignment for this structure,
       so just make it maximally aligned. */
    return MAX_ALIGN_SIZE (max_offset + size_at_max);
  }
}
#endif /* defined (USE_KKCC) || defined (PDUMP) */

#ifdef NEW_GC
#define GC_CHECK_NOT_FREE(lheader)			\
      gc_checking_assert (! LRECORD_FREE_P (lheader));
#else /* not NEW_GC */
#define GC_CHECK_NOT_FREE(lheader)					\
      gc_checking_assert (! LRECORD_FREE_P (lheader));			\
      gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->frob_block_p || \
			  ! (lheader)->free)
#endif /* not NEW_GC */

#ifdef USE_KKCC
/* The following functions implement the new mark algorithm. 
   They mark objects according to their descriptions.  They 
   are modeled on the corresponding pdumper procedures. */

#if 0
# define KKCC_STACK_AS_QUEUE 1
#endif

#ifdef DEBUG_XEMACS
/* The backtrace for the KKCC mark functions. */
#define KKCC_INIT_BT_STACK_SIZE 4096

typedef struct
{
  void *obj;
  const struct memory_description *desc;
  int pos;
  int is_lisp;
} kkcc_bt_stack_entry;

static kkcc_bt_stack_entry *kkcc_bt;
static int kkcc_bt_stack_size;
static int kkcc_bt_depth = 0;

static void
kkcc_bt_init (void)
{
  kkcc_bt_depth = 0;
  kkcc_bt_stack_size = KKCC_INIT_BT_STACK_SIZE;
  kkcc_bt = (kkcc_bt_stack_entry *)
    xmalloc_and_zero (kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry));
  if (!kkcc_bt)
    {
      stderr_out ("KKCC backtrace stack init failed for size %d\n",
		  kkcc_bt_stack_size);
      ABORT ();
    }
}

/* Workhorse backtrace function.  Not static because may potentially be
   called from a debugger. */

void kkcc_backtrace_1 (int size, int detailed);
void
kkcc_backtrace_1 (int size, int detailed)
{
  int i;
  stderr_out ("KKCC mark stack backtrace :\n");
  for (i = kkcc_bt_depth - 1; i >= kkcc_bt_depth - size && i >= 0; i--)
    {
      Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj);
      stderr_out (" [%d] ", i);
      if (!kkcc_bt[i].is_lisp)
	stderr_out ("non Lisp Object");
      else if (!LRECORDP (obj))
	stderr_out ("Lisp Object, non-record");
      else if (XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type
	       || (!XRECORD_LHEADER_IMPLEMENTATION (obj)))
	stderr_out ("WARNING! Bad Lisp Object type %d",
		    XRECORD_LHEADER (obj)->type);
      else
	stderr_out ("%s", XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
      if (detailed && kkcc_bt[i].is_lisp)
	{
	  stderr_out (" ");
	  debug_print (obj);
	}
      stderr_out (" (addr: %p, desc: %p, ",
		  (void *) kkcc_bt[i].obj,
		  (void *) kkcc_bt[i].desc);
      if (kkcc_bt[i].pos >= 0)
	stderr_out ("pos: %d)\n", kkcc_bt[i].pos);
      else
	if (kkcc_bt[i].pos == -1)
	  stderr_out ("root set)\n");
	else if (kkcc_bt[i].pos == -2)
	  stderr_out ("dirty object)\n");
    }
}

/* Various front ends onto kkcc_backtrace_1(), meant to be called from
   a debugger.

   The variants are:

   normal vs _full(): Normal displays up to the topmost 100 items on the
   stack, whereas full displays all items (even if there are thousands)

   _detailed_() vs _short_(): Detailed here means print out the actual
   Lisp objects on the stack using debug_print() in addition to their type,
   whereas short means only show the type
*/

void
kkcc_detailed_backtrace (void)
{
  kkcc_backtrace_1 (100, 1);
}

void kkcc_short_backtrace (void);
void
kkcc_short_backtrace (void)
{
  kkcc_backtrace_1 (100, 0);
}

void kkcc_detailed_backtrace_full (void);
void
kkcc_detailed_backtrace_full (void)
{
  kkcc_backtrace_1 (kkcc_bt_depth, 1);
}

void kkcc_short_backtrace_full (void);
void
kkcc_short_backtrace_full (void)
{
  kkcc_backtrace_1 (kkcc_bt_depth, 0);
}

/* Short versions for ease in calling from a debugger */

void kbt (void);
void
kbt (void)
{
  kkcc_detailed_backtrace ();
}

void kbts (void);
void
kbts (void)
{
  kkcc_short_backtrace ();
}

void kbtf (void);
void
kbtf (void)
{
  kkcc_detailed_backtrace_full ();
}

void kbtsf (void);
void
kbtsf (void)
{
  kkcc_short_backtrace_full ();
}

static void
kkcc_bt_stack_realloc (void)
{
  kkcc_bt_stack_size *= 2;
  kkcc_bt = (kkcc_bt_stack_entry *)
    xrealloc (kkcc_bt, kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry));
  if (!kkcc_bt)
    {
      stderr_out ("KKCC backtrace stack realloc failed for size %d\n", 
		  kkcc_bt_stack_size);
      ABORT ();
    }
}

static void
kkcc_bt_free (void)
{
  xfree_1 (kkcc_bt);
  kkcc_bt = 0;
  kkcc_bt_stack_size = 0;
}

static void
kkcc_bt_push (void *obj, const struct memory_description *desc,
	      int is_lisp DECLARE_KKCC_DEBUG_ARGS)
{
  kkcc_bt_depth = level;
  kkcc_bt[kkcc_bt_depth].obj = obj;
  kkcc_bt[kkcc_bt_depth].desc = desc;
  kkcc_bt[kkcc_bt_depth].pos = pos;
  kkcc_bt[kkcc_bt_depth].is_lisp = is_lisp;
  kkcc_bt_depth++;
  if (kkcc_bt_depth >= kkcc_bt_stack_size)
    kkcc_bt_stack_realloc ();
}

#else /* not DEBUG_XEMACS */
#define kkcc_bt_init()
#define kkcc_bt_push(obj, desc)
#endif /* not DEBUG_XEMACS */

/* Object memory descriptions are in the lrecord_implementation structure.
   But copying them to a parallel array is much more cache-friendly. */
const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)];

/* the initial stack size in kkcc_gc_stack_entries */
#define KKCC_INIT_GC_STACK_SIZE 16384

typedef struct
{
  void *data;
  const struct memory_description *desc;
#ifdef DEBUG_XEMACS
  int level;
  int pos;
  int is_lisp;
#endif
} kkcc_gc_stack_entry;


static kkcc_gc_stack_entry *kkcc_gc_stack_ptr;
static int kkcc_gc_stack_front;
static int kkcc_gc_stack_rear;
static int kkcc_gc_stack_size;

#define KKCC_INC(i) ((i + 1) % kkcc_gc_stack_size)
#define KKCC_INC2(i) ((i + 2) % kkcc_gc_stack_size)

#define KKCC_GC_STACK_FULL (KKCC_INC2 (kkcc_gc_stack_rear) == kkcc_gc_stack_front)
#define KKCC_GC_STACK_EMPTY (KKCC_INC (kkcc_gc_stack_rear) == kkcc_gc_stack_front)

static void
kkcc_gc_stack_init (void)
{
  kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE;
  kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *)
    xmalloc_and_zero (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry));
  if (!kkcc_gc_stack_ptr) 
    {
      stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size);
      ABORT ();
    }
  kkcc_gc_stack_front = 0;
  kkcc_gc_stack_rear = kkcc_gc_stack_size - 1;
}

static void
kkcc_gc_stack_free (void)
{
  xfree_1 (kkcc_gc_stack_ptr);
  kkcc_gc_stack_ptr = 0;
  kkcc_gc_stack_front = 0;
  kkcc_gc_stack_rear = 0;
  kkcc_gc_stack_size = 0;
}

static void
kkcc_gc_stack_realloc (void)
{
  kkcc_gc_stack_entry *old_ptr = kkcc_gc_stack_ptr;
  int old_size = kkcc_gc_stack_size;
  kkcc_gc_stack_size *= 2;
  kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *)
    xmalloc_and_zero (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry));
  if (!kkcc_gc_stack_ptr)
    {
      stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size);
      ABORT ();
    }
  if (kkcc_gc_stack_rear >= kkcc_gc_stack_front)
    {
      int number_elements = kkcc_gc_stack_rear - kkcc_gc_stack_front + 1;
      memcpy (kkcc_gc_stack_ptr, &old_ptr[kkcc_gc_stack_front], 
	      number_elements * sizeof (kkcc_gc_stack_entry));
      kkcc_gc_stack_front = 0;
      kkcc_gc_stack_rear = number_elements - 1;
    }
  else
    {
      int number_elements = old_size - kkcc_gc_stack_front;
      memcpy (kkcc_gc_stack_ptr, &old_ptr[kkcc_gc_stack_front],
	      number_elements * sizeof (kkcc_gc_stack_entry));
      memcpy (&kkcc_gc_stack_ptr[number_elements], &old_ptr[0],
	      (kkcc_gc_stack_rear + 1) * sizeof (kkcc_gc_stack_entry));
      kkcc_gc_stack_front = 0;
      kkcc_gc_stack_rear = kkcc_gc_stack_rear + number_elements;
    }
  xfree_1 (old_ptr);
}

static void
kkcc_gc_stack_push (void *data, const struct memory_description *desc
		    DECLARE_KKCC_DEBUG_ARGS)
{
#ifdef NEW_GC
  GC_STAT_ENQUEUED;
#endif /* NEW_GC */
  if (KKCC_GC_STACK_FULL)
      kkcc_gc_stack_realloc();
  kkcc_gc_stack_rear = KKCC_INC (kkcc_gc_stack_rear);
  kkcc_gc_stack_ptr[kkcc_gc_stack_rear].data = data;
  kkcc_gc_stack_ptr[kkcc_gc_stack_rear].desc = desc;
#ifdef DEBUG_XEMACS
  kkcc_gc_stack_ptr[kkcc_gc_stack_rear].level = level;
  kkcc_gc_stack_ptr[kkcc_gc_stack_rear].pos = pos;
#endif
}

#ifdef DEBUG_XEMACS

static inline void
kkcc_gc_stack_push_0 (void *data, const struct memory_description *desc,
		      int is_lisp DECLARE_KKCC_DEBUG_ARGS)
{
  kkcc_gc_stack_push (data, desc KKCC_DEBUG_ARGS);
  kkcc_gc_stack_ptr[kkcc_gc_stack_rear].is_lisp = is_lisp;
}

static inline void
kkcc_gc_stack_push_lisp (void *data, const struct memory_description *desc
			 DECLARE_KKCC_DEBUG_ARGS)
{
  kkcc_gc_stack_push_0 (data, desc, 1 KKCC_DEBUG_ARGS);
}

static inline void
kkcc_gc_stack_push_nonlisp (void *data, const struct memory_description *desc
			    DECLARE_KKCC_DEBUG_ARGS)
{
  kkcc_gc_stack_push_0 (data, desc, 0 KKCC_DEBUG_ARGS);
}

#else /* not DEBUG_XEMACS */

static inline void
kkcc_gc_stack_push_lisp (void *data, const struct memory_description *desc)
{
  kkcc_gc_stack_push (data, desc);
}

static inline void
kkcc_gc_stack_push_nonlisp (void *data, const struct memory_description *desc)
{
  kkcc_gc_stack_push (data, desc);
}

#endif /* (not) DEBUG_XEMACS */

static kkcc_gc_stack_entry *
kkcc_gc_stack_pop (void)
{
  if (KKCC_GC_STACK_EMPTY)
    return 0;
#ifdef NEW_GC
  GC_STAT_DEQUEUED;
#endif /* NEW_GC */
#ifndef KKCC_STACK_AS_QUEUE
  /* stack behaviour */
  return &kkcc_gc_stack_ptr[kkcc_gc_stack_rear--];
#else
  /* queue behaviour */
  {
    int old_front = kkcc_gc_stack_front;
    kkcc_gc_stack_front = KKCC_INC (kkcc_gc_stack_front);
    return &kkcc_gc_stack_ptr[old_front];
  }
#endif
}

void
kkcc_gc_stack_push_lisp_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS)
{
  if (XTYPE (obj) == Lisp_Type_Record)
    {
      struct lrecord_header *lheader = XRECORD_LHEADER (obj);
      const struct memory_description *desc;
      GC_CHECK_LHEADER_INVARIANTS (lheader);
      desc = RECORD_DESCRIPTION (lheader);
      if (! MARKED_RECORD_HEADER_P (lheader)) 
	{
#ifdef NEW_GC
	  MARK_GREY (lheader);
#else /* not NEW_GC */
	  MARK_RECORD_HEADER (lheader);
#endif /* not NEW_GC */
	  kkcc_gc_stack_push_lisp ((void *) lheader, desc KKCC_DEBUG_ARGS);
	}
    }
}

#ifdef NEW_GC

void
kkcc_gc_stack_repush_dirty_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS)
{
  if (XTYPE (obj) == Lisp_Type_Record)
    {
      struct lrecord_header *lheader = XRECORD_LHEADER (obj);
      const struct memory_description *desc;
      GC_STAT_REPUSHED;
      GC_CHECK_LHEADER_INVARIANTS (lheader);
      desc = RECORD_DESCRIPTION (lheader);
      MARK_GREY (lheader);
      kkcc_gc_stack_push_lisp ((void*) lheader, desc KKCC_DEBUG_ARGS);
    }
}
#endif /* NEW_GC */

#ifdef ERROR_CHECK_GC
#define KKCC_DO_CHECK_FREE(obj, allow_free)			\
do								\
{								\
  if (!allow_free && XTYPE (obj) == Lisp_Type_Record)		\
    {								\
      struct lrecord_header *lheader = XRECORD_LHEADER (obj);	\
      GC_CHECK_NOT_FREE (lheader);				\
    }								\
} while (0)
#else
#define KKCC_DO_CHECK_FREE(obj, allow_free) DO_NOTHING
#endif

static inline void
mark_object_maybe_checking_free (Lisp_Object obj, int allow_free
				 DECLARE_KKCC_DEBUG_ARGS)
{
  KKCC_DO_CHECK_FREE (obj, allow_free);
  kkcc_gc_stack_push_lisp_object (obj KKCC_DEBUG_ARGS);
}

/* This function loops all elements of a struct pointer and calls 
   mark_with_description with each element. */
static void
mark_struct_contents (const void *data,
		      const struct sized_memory_description *sdesc,
		      int count DECLARE_KKCC_DEBUG_ARGS)
{
  int i;
  Bytecount elsize;
  elsize = lispdesc_block_size (data, sdesc);

  for (i = 0; i < count; i++)
    {
      kkcc_gc_stack_push_nonlisp (((char *) data) + elsize * i,
				  sdesc->description
				  KKCC_DEBUG_ARGS);
    }
}

#ifdef NEW_GC
/* This function loops all elements of a struct pointer and calls 
   mark_with_description with each element. */
static void
mark_lisp_object_block_contents (const void *data,
				 const struct sized_memory_description *sdesc,
				 int count DECLARE_KKCC_DEBUG_ARGS)
{
  int i;
  Bytecount elsize;
  elsize = lispdesc_block_size (data, sdesc);

  for (i = 0; i < count; i++)
    {
      const Lisp_Object obj = wrap_pointer_1 (((char *) data) + elsize * i);
      if (XTYPE (obj) == Lisp_Type_Record)
	{
	  struct lrecord_header *lheader = XRECORD_LHEADER (obj);
	  const struct memory_description *desc;
	  GC_CHECK_LHEADER_INVARIANTS (lheader);
	  desc = sdesc->description;
	  if (! MARKED_RECORD_HEADER_P (lheader)) 
	    {
	      MARK_GREY (lheader);
	      kkcc_gc_stack_push_lisp ((void *) lheader, desc KKCC_DEBUG_ARGS);
	    }
	}
    }
}

#endif /* not NEW_GC */

/* This function implements the KKCC mark algorithm.
   Instead of calling mark_object, all the alive Lisp_Objects are pushed
   on the kkcc_gc_stack. This function processes all elements on the stack
   according to their descriptions. */
static void
kkcc_marking (int USED_IF_NEW_GC (cnt))
{
  kkcc_gc_stack_entry *stack_entry = 0;
  void *data = 0;
  const struct memory_description *desc = 0;
  int pos;
#ifdef NEW_GC
  int obj_count = cnt;
#endif /* NEW_GC */
#ifdef DEBUG_XEMACS
  int level = 0;
#endif
  
  while ((stack_entry = kkcc_gc_stack_pop ()) != 0)
    {
      data = stack_entry->data;
      desc = stack_entry->desc;
#ifdef DEBUG_XEMACS
      level = stack_entry->level + 1;
      kkcc_bt_push (data, desc, stack_entry->is_lisp, stack_entry->level,
		    stack_entry->pos);
#else
      kkcc_bt_push (data, desc);
#endif

#ifdef NEW_GC
      /* Mark black if object is currently grey.  This first checks,
	 if the object is really allocated on the mc-heap.  If it is,
	 it can be marked black; if it is not, it cannot be marked. */
      maybe_mark_black (data);
#endif /* NEW_GC */

      if (!data) continue;

      gc_checking_assert (data);
      gc_checking_assert (desc);

      for (pos = 0; desc[pos].type != XD_END; pos++)
	{
	  const struct memory_description *desc1 = &desc[pos];
	  const void *rdata =
	    (const char *) data + lispdesc_indirect_count (desc1->offset,
							   desc, data);
	union_switcheroo:
	  
	  /* If the flag says don't mark, then don't mark. */
	  if ((desc1->flags) & XD_FLAG_NO_KKCC)
	    continue;

	  switch (desc1->type)
	    {
	    case XD_BYTECOUNT:
	    case XD_ELEMCOUNT:
	    case XD_HASHCODE:
	    case XD_INT:
	    case XD_LONG:
	    case XD_INT_RESET:
	    case XD_LO_LINK:
	    case XD_OPAQUE_PTR:
	    case XD_OPAQUE_DATA_PTR:
	    case XD_ASCII_STRING:
	    case XD_DOC_STRING:
	      break;
	    case XD_LISP_OBJECT: 
	      {
		const Lisp_Object *stored_obj = (const Lisp_Object *) rdata;

		/* Because of the way that tagged objects work (pointers and
		   Lisp_Objects have the same representation), XD_LISP_OBJECT
		   can be used for untagged pointers.  They might be NULL,
		   though. */
		if (EQ (*stored_obj, Qnull_pointer))
		  break;
#ifdef NEW_GC
		mark_object_maybe_checking_free (*stored_obj, 0
						 KKCC_DEBUG_ARGS);
#else /* not NEW_GC */
		mark_object_maybe_checking_free
		  (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT
		   KKCC_DEBUG_ARGS);
#endif /* not NEW_GC */
		break;
	      }
	    case XD_LISP_OBJECT_ARRAY:
	      {
		int i;
		EMACS_INT count =
		  lispdesc_indirect_count (desc1->data1, desc, data);
	
		for (i = 0; i < count; i++)
		  {
		    const Lisp_Object *stored_obj =
		      (const Lisp_Object *) rdata + i;

		    if (EQ (*stored_obj, Qnull_pointer))
		      break;
#ifdef NEW_GC
		    mark_object_maybe_checking_free 
		      (*stored_obj, 0 KKCC_DEBUG_ARGS);
#else /* not NEW_GC */
		    mark_object_maybe_checking_free
		      (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT
		       KKCC_DEBUG_ARGS);
#endif /* not NEW_GC */
		  }
		break;
	      }
#ifdef NEW_GC
	    case XD_INLINE_LISP_OBJECT_BLOCK_PTR:
	      {
		EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
							   data);
		const struct sized_memory_description *sdesc =
		  lispdesc_indirect_description (data, desc1->data2.descr);
		const char *dobj = * (const char **) rdata;
		if (dobj)
		  mark_lisp_object_block_contents 
		    (dobj, sdesc, count KKCC_DEBUG_ARGS);
		break;
	      }
#endif /* NEW_GC */
	    case XD_BLOCK_PTR:
	      {
		EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
							   data);
		const struct sized_memory_description *sdesc =
		  lispdesc_indirect_description (data, desc1->data2.descr);
		const char *dobj = * (const char **) rdata;
		if (dobj)
		  mark_struct_contents (dobj, sdesc, count KKCC_DEBUG_ARGS);
		break;
	      }
	    case XD_BLOCK_ARRAY:
	      {
		EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
							   data);
		const struct sized_memory_description *sdesc =
		  lispdesc_indirect_description (data, desc1->data2.descr);
		      
		mark_struct_contents (rdata, sdesc, count KKCC_DEBUG_ARGS);
		break;
	      }
	    case XD_UNION:
	    case XD_UNION_DYNAMIC_SIZE:
	      desc1 = lispdesc_process_xd_union (desc1, desc, data);
	      if (desc1)
		goto union_switcheroo;
	      break;
		    
	    default:
	      stderr_out ("Unsupported description type : %d\n", desc1->type);
	      kkcc_detailed_backtrace ();
	      ABORT ();
	    }
	}

#ifdef NEW_GC
      if (cnt) 
	if (!--obj_count)
	  break;
#endif /* NEW_GC */
    }
}
#endif /* USE_KKCC */

/* I hate duplicating all this crap! */
int
marked_p (Lisp_Object obj)
{
  /* Checks we used to perform. */
  /* if (EQ (obj, Qnull_pointer)) return 1; */
  /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
  /* if (PURIFIED (XPNTR (obj))) return 1; */

  if (XTYPE (obj) == Lisp_Type_Record)
    {
      struct lrecord_header *lheader = XRECORD_LHEADER (obj);

      GC_CHECK_LHEADER_INVARIANTS (lheader);

      return MARKED_RECORD_HEADER_P (lheader);
    }
  return 1;
}


/* Mark reference to a Lisp_Object.  If the object referred to has not been
   seen yet, recursively mark all the references contained in it. */
void
mark_object (
#ifdef USE_KKCC
	     Lisp_Object UNUSED (obj)
#else
	     Lisp_Object obj
#endif
	     )
{
#ifdef USE_KKCC
  /* this code should never be reached when configured for KKCC */
  stderr_out ("KKCC: Invalid mark_object call.\n");
  stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n");
  ABORT ();
#else /* not USE_KKCC */

 tail_recurse:

  /* Checks we used to perform */
  /* if (EQ (obj, Qnull_pointer)) return; */
  /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
  /* if (PURIFIED (XPNTR (obj))) return; */

  if (XTYPE (obj) == Lisp_Type_Record)
    {
      struct lrecord_header *lheader = XRECORD_LHEADER (obj);

      GC_CHECK_LHEADER_INVARIANTS (lheader);

      /* We handle this separately, above, so we can mark free objects */
      GC_CHECK_NOT_FREE (lheader);

      /* All c_readonly objects have their mark bit set,
	 so that we only need to check the mark bit here. */
      if (! MARKED_RECORD_HEADER_P (lheader))
	{
	  MARK_RECORD_HEADER (lheader);

	  if (RECORD_MARKER (lheader))
	    {
	      obj = RECORD_MARKER (lheader) (obj);
	      if (!NILP (obj)) goto tail_recurse;
	    }
	}
    }
#endif /* not KKCC */
}


/************************************************************************/
/*			       Hooks         				*/
/************************************************************************/

/* Nonzero when calling certain hooks or doing other things where a GC
   would be bad. It prevents infinite recursive calls to gc. */
int gc_currently_forbidden;

int
begin_gc_forbidden (void)
{
  return internal_bind_int (&gc_currently_forbidden, 1);
}

void
end_gc_forbidden (int count)
{
  unbind_to (count);
}

/* Hooks. */
Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
Lisp_Object Vpost_gc_hook, Qpost_gc_hook;

/* Maybe we want to use this when doing a "panic" gc after memory_full()? */
static int gc_hooks_inhibited;

struct post_gc_action
{
  void (*fun) (void *);
  void *arg;
};

typedef struct post_gc_action post_gc_action;

typedef struct
{
  Dynarr_declare (post_gc_action);
} post_gc_action_dynarr;

static post_gc_action_dynarr *post_gc_actions;

/* Register an action to be called at the end of GC.
   gc_in_progress is 0 when this is called.
   This is used when it is discovered that an action needs to be taken,
   but it's during GC, so it's not safe. (e.g. in a finalize method.)

   As a general rule, do not use Lisp objects here.
   And NEVER signal an error.
*/

void
register_post_gc_action (void (*fun) (void *), void *arg)
{
  post_gc_action action;

  if (!post_gc_actions)
    post_gc_actions = Dynarr_new (post_gc_action);

  action.fun = fun;
  action.arg = arg;

  Dynarr_add (post_gc_actions, action);
}

static void
run_post_gc_actions (void)
{
  int i;

  if (post_gc_actions)
    {
      for (i = 0; i < Dynarr_length (post_gc_actions); i++)
	{
	  post_gc_action action = Dynarr_at (post_gc_actions, i);
	  (action.fun) (action.arg);
	}

      Dynarr_reset (post_gc_actions);
    }
}

#ifdef NEW_GC
/* Asynchronous finalization. */
typedef struct finalize_elem
{
  Lisp_Object obj;
  struct finalize_elem *next;
} finalize_elem;

finalize_elem *Vall_finalizable_objs;
Lisp_Object Vfinalizers_to_run;

void
add_finalizable_obj (Lisp_Object obj)
{
  finalize_elem *next = Vall_finalizable_objs;
  Vall_finalizable_objs =
    (finalize_elem *) xmalloc_and_zero (sizeof (finalize_elem));
  Vall_finalizable_objs->obj = obj;
  Vall_finalizable_objs->next = next;
}

void
register_for_finalization (void)
{
  finalize_elem *rest = Vall_finalizable_objs;

  if (!rest) 
    return;

  while (!marked_p (rest->obj))
    {
      finalize_elem *temp = rest;
      Vfinalizers_to_run = Fcons (rest->obj, Vfinalizers_to_run);
      Vall_finalizable_objs = rest->next;
      xfree (temp);
      rest = Vall_finalizable_objs;
    }

  while (rest->next)
    {
      if (LRECORDP (rest->next->obj)
	  && !marked_p (rest->next->obj))
	{
	  finalize_elem *temp = rest->next;
	  Vfinalizers_to_run = Fcons (rest->next->obj, Vfinalizers_to_run);
	  rest->next = rest->next->next;
	  xfree (temp);
	}
      else
	{
	  rest = rest->next;
	}
    }
  /* Keep objects alive that need to be finalized by marking
     Vfinalizers_to_run transitively. */
  kkcc_gc_stack_push_lisp_object_0 (Vfinalizers_to_run);
  kkcc_marking (0);
}

void
run_finalizers (void)
{
  Lisp_Object rest;
  for (rest = Vfinalizers_to_run; !NILP (rest); rest = XCDR (rest))
    {
      MC_ALLOC_CALL_FINALIZER (XPNTR (XCAR (rest)));
    }
  Vfinalizers_to_run = Qnil;
}
#endif /* not NEW_GC */


/************************************************************************/
/*			    Garbage Collection				*/
/************************************************************************/

/* Enable/disable incremental garbage collection during runtime. */
int allow_incremental_gc;

/* For profiling. */
static Lisp_Object QSin_garbage_collection;

/* Nonzero means display messages at beginning and end of GC.  */
int garbage_collection_messages;

/* "Garbage collecting" */
Lisp_Object Vgc_message;
Lisp_Object Vgc_pointer_glyph;
static const Ascbyte gc_default_message[] = "Garbage collecting";
Lisp_Object Qgarbage_collecting;

/* "Locals" during GC. */
struct frame *f;
int speccount;
int cursor_changed;
Lisp_Object pre_gc_cursor;

/* PROFILE_DECLARE */
int do_backtrace;
struct backtrace backtrace;

/* Maximum amount of C stack to save when a GC happens.  */
#ifndef MAX_SAVE_STACK
#define MAX_SAVE_STACK 0 /* 16000 */
#endif

static void
show_gc_cursor_and_message (void) 
{
  /* Now show the GC cursor/message. */
  pre_gc_cursor = Qnil;
  cursor_changed = 0;

  /* We used to call selected_frame() here.

     The following functions cannot be called inside GC
     so we move to after the above tests. */
  {
    Lisp_Object frame;
    Lisp_Object device = Fselected_device (Qnil);
    if (NILP (device)) /* Could happen during startup, eg. if always_gc */
      return;
    frame = Fselected_frame (device);
    if (NILP (frame))
      invalid_state ("No frames exist on device", device);
    f = XFRAME (frame);
  }

  if (!noninteractive)
    {
      if (FRAME_WIN_P (f))
	{
	  Lisp_Object frame = wrap_frame (f);
	  Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
						     FRAME_SELECTED_WINDOW (f),
						     ERROR_ME_NOT, 1);
	  pre_gc_cursor = f->pointer;
	  if (POINTER_IMAGE_INSTANCEP (cursor)
	      /* don't change if we don't know how to change back. */
	      && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
	    {
	      cursor_changed = 1;
	      Fset_frame_pointer (frame, cursor);
	    }
	}

      /* Don't print messages to the stream device. */
      if (!cursor_changed && !FRAME_STREAM_P (f))
	{
	  if (garbage_collection_messages)
	    {
	      Lisp_Object args[2], whole_msg;
	      args[0] = (STRINGP (Vgc_message) ? Vgc_message :
			 build_msg_string (gc_default_message));
	      args[1] = build_ascstring ("...");
	      whole_msg = Fconcat (2, args);
	      echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1,
				 Qgarbage_collecting);
	    }
	}
    }
}

static void
remove_gc_cursor_and_message (void)
{
  /* Now remove the GC cursor/message */
  if (!noninteractive)
    {
      if (cursor_changed)
	Fset_frame_pointer (wrap_frame (f), pre_gc_cursor);
      else if (!FRAME_STREAM_P (f))
	{
	  /* Show "...done" only if the echo area would otherwise be empty. */
	  if (NILP (clear_echo_area (selected_frame (),
				     Qgarbage_collecting, 0)))
	    {
	      if (garbage_collection_messages)
		{
		  Lisp_Object args[2], whole_msg;
		  args[0] = (STRINGP (Vgc_message) ? Vgc_message :
			     build_msg_string (gc_default_message));
		  args[1] = build_msg_string ("... done");
		  whole_msg = Fconcat (2, args);
		  echo_area_message (selected_frame (), (Ibyte *) 0,
				     whole_msg, 0, -1,
				     Qgarbage_collecting);
		}
	    }
	}
    }
}

static void
gc_prepare (void)
{
#if MAX_SAVE_STACK > 0
  char stack_top_variable;
  extern char *stack_bottom;
#endif

#ifdef NEW_GC
  GC_STAT_START_NEW_GC;
  GC_SET_PHASE (INIT_GC);
#endif /* NEW_GC */

  do_backtrace = profiling_active || backtrace_with_internal_sections;

  assert (!gc_in_progress);
  assert (!in_display || gc_currently_forbidden);

  PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection);

  need_to_signal_post_gc = 0;
  recompute_funcall_allocation_flag ();

  if (!gc_hooks_inhibited)
    run_hook_trapping_problems
      (Qgarbage_collecting, Qpre_gc_hook,
       INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);

  /***** Now we actually start the garbage collection. */

  gc_in_progress = 1;
#ifndef NEW_GC
  inhibit_non_essential_conversion_operations++;
#endif /* not NEW_GC */

#if MAX_SAVE_STACK > 0

  /* Save a copy of the contents of the stack, for debugging.  */
  if (!purify_flag)
    {
      /* Static buffer in which we save a copy of the C stack at each GC.  */
      static char *stack_copy;
      static Bytecount stack_copy_size;

      ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
      Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
      if (stack_size < MAX_SAVE_STACK)
	{
	  if (stack_copy_size < stack_size)
	    {
	      stack_copy = (char *) xrealloc (stack_copy, stack_size);
	      stack_copy_size = stack_size;
	    }

	  memcpy (stack_copy,
		  stack_diff > 0 ? stack_bottom : &stack_top_variable,
		  stack_size);
	}
    }
#endif /* MAX_SAVE_STACK > 0 */

  /* Do some totally ad-hoc resource clearing. */
  /* #### generalize this? */
  clear_event_resource ();
  cleanup_specifiers ();
  cleanup_buffer_undo_lists ();
}

static void
gc_mark_root_set (
#ifdef NEW_GC
		  enum gc_phase phase
#else /* not NEW_GC */
		  void
#endif /* not NEW_GC */
		  )
{
#ifdef NEW_GC
  GC_SET_PHASE (phase);
#endif /* NEW_GC */

  /* Mark all the special slots that serve as the roots of accessibility. */

#ifdef USE_KKCC
# define mark_object(obj) kkcc_gc_stack_push_lisp_object_0 (obj)
#endif /* USE_KKCC */

  { /* staticpro() */
    Lisp_Object **p = Dynarr_begin (staticpros);
    Elemcount len = Dynarr_length (staticpros);
    Elemcount count;
    for (count = 0; count < len; count++, p++)
      /* Need to check if the pointer in the staticpro array is not
	 NULL. A gc can occur after variable is added to the staticpro
	 array and _before_ it is correctly initialized. In this case
	 its value is NULL, which we have to catch here. */
      if (*p)
	mark_object (**p);
  }

  { /* staticpro_nodump() */
    Lisp_Object **p = Dynarr_begin (staticpros_nodump);
    Elemcount len = Dynarr_length (staticpros_nodump);
    Elemcount count;
    for (count = 0; count < len; count++, p++)
      /* Need to check if the pointer in the staticpro array is not
	 NULL. A gc can occur after variable is added to the staticpro
	 array and _before_ it is correctly initialized. In this case
	 its value is NULL, which we have to catch here. */
      if (*p)
	mark_object (**p);
  }

#ifdef NEW_GC
  { /* mcpro () */
    Lisp_Object *p = Dynarr_begin (mcpros);
    Elemcount len = Dynarr_length (mcpros);
    Elemcount count;
    for (count = 0; count < len; count++, p++)
      mark_object (*p);
  }
#endif /* NEW_GC */

  { /* GCPRO() */
    struct gcpro *tail;
    int i;
    for (tail = gcprolist; tail; tail = tail->next)
      for (i = 0; i < tail->nvars; i++)
	mark_object (tail->var[i]);
  }

  { /* specbind() */
    struct specbinding *bind;
    for (bind = specpdl; bind != specpdl_ptr; bind++)
      {
	mark_object (bind->symbol);
	mark_object (bind->old_value);
      }
  }

  {
    struct catchtag *c;
    for (c = catchlist; c; c = c->next)
      {
	mark_object (c->tag);
	mark_object (c->val);
	mark_object (c->actual_tag);
	mark_object (c->backtrace);
      }
  }

  {
    struct backtrace *backlist;
    for (backlist = backtrace_list; backlist; backlist = backlist->next)
      {
	int nargs = backlist->nargs;
	int i;

	mark_object (*backlist->function);
	if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */
	    /* might be fake (internal profiling entry) */
	    && backlist->args)
	  mark_object (backlist->args[0]);
	else
	  for (i = 0; i < nargs; i++)
	    mark_object (backlist->args[i]);
      }
  }

  mark_profiling_info ();

#ifdef USE_KKCC
# undef mark_object
#endif
}

static void
gc_finish_mark (void)
{
#ifdef NEW_GC
  GC_SET_PHASE (FINISH_MARK);
#endif /* NEW_GC */
  init_marking_ephemerons ();

  while (finish_marking_weak_hash_tables () > 0 ||
	 finish_marking_weak_lists       () > 0 ||
	 continue_marking_ephemerons     () > 0)
#ifdef USE_KKCC
    {
      kkcc_marking (0);
    }
#else /* not USE_KKCC */
  ;
#endif /* not USE_KKCC */

  /* At this point, we know which objects need to be finalized: we
     still need to resurrect them */

  while (finish_marking_ephemerons       () > 0 ||
	 finish_marking_weak_lists       () > 0 ||
	 finish_marking_weak_hash_tables () > 0)
#ifdef USE_KKCC
    {
      kkcc_marking (0);
    }
#else /* not USE_KKCC */
  ;
#endif /* not USE_KKCC */

  /* And prune (this needs to be called after everything else has been
     marked and before we do any sweeping). */
  /* #### this is somewhat ad-hoc and should probably be an object
     method */
  prune_weak_hash_tables ();
  prune_weak_lists ();
  prune_specifiers ();
  prune_syntax_tables ();

  prune_ephemerons ();
  prune_weak_boxes ();
}

#ifdef NEW_GC
static void
gc_finalize (void)
{
  GC_SET_PHASE (FINALIZE);
  register_for_finalization ();
}

static void
gc_sweep (void)
{
  GC_SET_PHASE (SWEEP);
  mc_sweep ();
}
#endif /* NEW_GC */


static void
gc_finish (void)
{
#ifdef NEW_GC
  GC_SET_PHASE (FINISH_GC);
#endif /* NEW_GC */
  finish_object_memory_usage_stats ();
  consing_since_gc = 0;
#ifndef DEBUG_XEMACS
  /* Allow you to set it really fucking low if you really want ... */
  if (gc_cons_threshold < 10000)
    gc_cons_threshold = 10000;
#endif
  recompute_need_to_garbage_collect ();

#ifndef NEW_GC
  inhibit_non_essential_conversion_operations--;
#endif /* not NEW_GC */
  gc_in_progress = 0;

  run_post_gc_actions ();

  /******* End of garbage collection ********/

#ifndef NEW_GC
  if (!breathing_space)
    {
      breathing_space = malloc (4096 - MALLOC_OVERHEAD);
    }
#endif /* not NEW_GC */

  need_to_signal_post_gc = 1;
  funcall_allocation_flag = 1;

  PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection);

#ifdef NEW_GC
  GC_SET_PHASE (NONE);
#endif /* NEW_GC */
}

#ifdef NEW_GC
static void
gc_suspend_mark_phase (void)
{
  PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection);
  write_barrier_enabled = 1;
  consing_since_gc = 0;
  vdb_start_dirty_bits_recording ();
}

static int
gc_resume_mark_phase (void)
{
  PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection);
  assert (write_barrier_enabled);
  vdb_stop_dirty_bits_recording ();
  write_barrier_enabled = 0;
  return vdb_read_dirty_bits ();
}

static int
gc_mark (int incremental)
{
  GC_SET_PHASE (MARK);
  if (!incremental)
    {
      kkcc_marking (0);
    }
  else 
    {
      kkcc_marking (gc_incremental_traversal_threshold);
      if (!KKCC_GC_STACK_EMPTY)
	{
	  gc_suspend_mark_phase ();
	  return 0;
	}
    }
  return 1;
}

static int
gc_resume_mark (int incremental)
{
  if (!incremental)
    {
      if (!KKCC_GC_STACK_EMPTY)
	{
	  GC_STAT_RESUME_GC;
	  /* An incremental garbage collection is already running ---
	     now wrap it up and resume it atomically. */
	  gc_resume_mark_phase ();
	  gc_mark_root_set (REPUSH_ROOT_SET);
	  kkcc_marking (0);
	}
    }
  else
    {
      int repushed_objects;
      int mark_work;
      GC_STAT_RESUME_GC;
      repushed_objects = gc_resume_mark_phase ();
      mark_work = (gc_incremental_traversal_threshold > repushed_objects) ?
	gc_incremental_traversal_threshold : repushed_objects;
      kkcc_marking (mark_work);
      if (KKCC_GC_STACK_EMPTY)
	{
	  /* Mark root set again and finish up marking. */
	  gc_mark_root_set (REPUSH_ROOT_SET);
	  kkcc_marking (0);
	}
      else
	{
	  gc_suspend_mark_phase ();
	  return 0;
	}
    }
  return 1;
}


static void
gc_1 (int incremental)
{
  switch (GC_PHASE)
    {
    case NONE:
      gc_prepare ();
      kkcc_gc_stack_init();
#ifdef DEBUG_XEMACS
      kkcc_bt_init ();
#endif
    case INIT_GC:
      gc_mark_root_set (PUSH_ROOT_SET);
    case PUSH_ROOT_SET:
      if (!gc_mark (incremental))
	return; /* suspend gc */
    case MARK:
      if (!KKCC_GC_STACK_EMPTY)
	if (!gc_resume_mark (incremental))
	  return; /* suspend gc */
      gc_finish_mark ();
    case FINISH_MARK:
      gc_finalize ();
      kkcc_gc_stack_free ();
#ifdef DEBUG_XEMACS
      kkcc_bt_free ();
#endif
    case FINALIZE:
      gc_sweep ();
    case SWEEP:
      gc_finish ();
    case FINISH_GC:
      break;
    }
}

static void
gc (int incremental)
{
  if (gc_currently_forbidden
      || in_display
      || preparing_for_armageddon)
    return;

  /* Very important to prevent GC during any of the following
     stuff that might run Lisp code; otherwise, we'll likely
     have infinite GC recursion. */
  speccount = begin_gc_forbidden ();

  show_gc_cursor_and_message ();

  gc_1 (incremental);

  remove_gc_cursor_and_message ();

  /* now stop inhibiting GC */
  unbind_to (speccount);
}

void 
gc_full (void)
{
  gc (0);
}

DEFUN ("gc-full", Fgc_full, 0, 0, "", /*
This function performs a full garbage collection. If an incremental
garbage collection is already running, it completes without any
further interruption.  This function guarantees that unused objects
are freed when it returns. Garbage collection happens automatically if
the client allocates more than `gc-cons-threshold' bytes of Lisp data
since the previous garbage collection.
*/
       ())
{
  gc_full ();
  return Qt;
}

void 
gc_incremental (void)
{
  gc (allow_incremental_gc);
}

DEFUN ("gc-incremental", Fgc_incremental, 0, 0, "", /*
This function starts an incremental garbage collection. If an
incremental garbage collection is already running, the next cycle
starts. Note that this function has not necessarily freed any memory
when it returns. This function only guarantees, that the traversal of
the heap makes progress.  The next cycle of incremental garbage
collection happens automatically if the client allocates more than
`gc-incremental-cons-threshold' bytes of Lisp data since previous
garbage collection.
*/
       ())
{
  gc_incremental ();
  return Qt;
}
#else /* not NEW_GC */
void garbage_collect_1 (void)
{
  if (gc_in_progress
      || gc_currently_forbidden
      || in_display
      || preparing_for_armageddon)
    return;

  /* Very important to prevent GC during any of the following
     stuff that might run Lisp code; otherwise, we'll likely
     have infinite GC recursion. */
  speccount = begin_gc_forbidden ();

  show_gc_cursor_and_message ();

  gc_prepare ();
#ifdef USE_KKCC
  kkcc_gc_stack_init();
#ifdef DEBUG_XEMACS
  kkcc_bt_init ();
#endif
#endif /* USE_KKCC */
  gc_mark_root_set ();
#ifdef USE_KKCC
  kkcc_marking (0);
#endif /* USE_KKCC */
  gc_finish_mark ();
#ifdef USE_KKCC
  kkcc_gc_stack_free ();
#ifdef DEBUG_XEMACS
  kkcc_bt_free ();
#endif
#endif /* USE_KKCC */
  gc_sweep_1 ();
  gc_finish ();

  remove_gc_cursor_and_message ();

  /* now stop inhibiting GC */
  unbind_to (speccount);
}
#endif /* not NEW_GC */


/************************************************************************/
/*			     Initializations				*/
/************************************************************************/

/* Initialization */
static void
common_init_gc_early (void)
{
  Vgc_message = Qzero;

  gc_currently_forbidden = 0;
  gc_hooks_inhibited = 0;

  need_to_garbage_collect = always_gc;

  gc_cons_threshold = GC_CONS_THRESHOLD;
  gc_cons_percentage = 40; /* #### what is optimal? */
  total_gc_usage_set = 0;
#ifdef NEW_GC
  gc_cons_incremental_threshold = GC_CONS_INCREMENTAL_THRESHOLD;
  gc_incremental_traversal_threshold = GC_INCREMENTAL_TRAVERSAL_THRESHOLD;
#endif /* NEW_GC */
}

void
init_gc_early (void)
{
#ifdef NEW_GC
  /* Reset the finalizers_to_run list after pdump_load. */
  Vfinalizers_to_run = Qnil;
#endif /* NEW_GC */
}

void
reinit_gc_early (void)
{
  common_init_gc_early ();
}

void
init_gc_once_early (void)
{
  common_init_gc_early ();
}

void
syms_of_gc (void)
{
  DEFSYMBOL (Qpre_gc_hook);
  DEFSYMBOL (Qpost_gc_hook);
#ifdef NEW_GC
  DEFSUBR (Fgc_full);
  DEFSUBR (Fgc_incremental);
#ifdef ERROR_CHECK_GC
  DEFSUBR (Fgc_stats);
#endif /* not ERROR_CHECK_GC */
#endif /* NEW_GC */
}

void
vars_of_gc (void)
{
  staticpro_nodump (&pre_gc_cursor);

  QSin_garbage_collection = build_defer_string ("(in garbage collection)");
  staticpro (&QSin_garbage_collection);

  DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
*Number of bytes of consing between full garbage collections.
\"Consing\" is a misnomer in that this actually counts allocation
of all different kinds of objects, not just conses.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection.  All data types count.

Garbage collection happens automatically when `eval' or `funcall' are
called.  (Note that `funcall' is called implicitly as part of evaluation.)
By binding this temporarily to a large number, you can effectively
prevent garbage collection during a part of the program.

Normally, you cannot set this value less than 10,000 (if you do, it is
automatically reset during the next garbage collection).  However, if
XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing
you to set this value very low to track down problems with insufficient
GCPRO'ing.  If you set this to a negative number, garbage collection will
happen at *EVERY* call to `eval' or `funcall'.  This is an extremely
effective way to check GCPRO problems, but be warned that your XEmacs
will be unusable!  You almost certainly won't have the patience to wait
long enough to be able to set it back.
 
See also `consing-since-gc' and `gc-cons-percentage'.
*/ );

  DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
*Percentage of memory allocated between garbage collections.

Garbage collection will happen if this percentage of the total amount of
memory used for data (see `lisp-object-memory-usage') has been allocated
since the last garbage collection.  However, it will not happen if less
than `gc-cons-threshold' bytes have been allocated -- this sets an absolute
minimum in case very little data has been allocated or the percentage is
set very low.  Set this to 0 to have garbage collection always happen after
`gc-cons-threshold' bytes have been allocated, regardless of current memory
usage.

See also `consing-since-gc' and `gc-cons-threshold'.
*/ );

#ifdef NEW_GC
  DEFVAR_INT ("gc-cons-incremental-threshold", 
	      &gc_cons_incremental_threshold /*
*Number of bytes of consing between cycles of incremental garbage
collections.  \"Consing\" is a misnomer in that this actually counts
allocation of all different kinds of objects, not just conses.  The
next garbage collection cycle can happen automatically once this many
bytes have been allocated since the last garbage collection cycle.
All data types count.

See also `gc-cons-threshold'.
*/ );

  DEFVAR_INT ("gc-incremental-traversal-threshold", 
	      &gc_incremental_traversal_threshold /*
*Number of elements processed in one cycle of incremental travesal.
*/ );
#endif /* NEW_GC */

  DEFVAR_BOOL ("purify-flag", &purify_flag /*
Non-nil means loading Lisp code in order to dump an executable.
This means that certain objects should be allocated in readonly space.
*/ );

  DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /*
*Non-nil means display messages at start and end of garbage collection.
*/ );
  garbage_collection_messages = 0;

  DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
Function or functions to be run just before each garbage collection.
Interrupts, garbage collection, and errors are inhibited while this hook
runs, so be extremely careful in what you add here.  In particular, avoid
consing, and do not interact with the user.
*/ );
  Vpre_gc_hook = Qnil;

  DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
Function or functions to be run just after each garbage collection.
Interrupts, garbage collection, and errors are inhibited while this hook
runs.  Each hook is called with one argument which is an alist with
finalization data.
*/ );
  Vpost_gc_hook = Qnil;

  DEFVAR_LISP ("gc-message", &Vgc_message /*
String to print to indicate that a garbage collection is in progress.
This is printed in the echo area.  If the selected frame is on a
window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
image instance) in the domain of the selected frame, the mouse pointer
will change instead of this message being printed.
*/ );
  Vgc_message = build_defer_string (gc_default_message);

  DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
Pointer glyph used to indicate that a garbage collection is in progress.
If the selected window is on a window system and this glyph specifies a
value (i.e. a pointer image instance) in the domain of the selected
window, the pointer will be changed as specified during garbage collection.
Otherwise, a message will be printed in the echo area, as controlled
by `gc-message'.
*/ );

#ifdef NEW_GC
  DEFVAR_BOOL ("allow-incremental-gc", &allow_incremental_gc /*
*Non-nil means to allow incremental garbage collection. Nil prevents
*incremental garbage collection, the garbage collector then only does
*full collects (even if (gc-incremental) is called).
*/ );

  Vfinalizers_to_run = Qnil;
  staticpro_nodump (&Vfinalizers_to_run);
#endif /* NEW_GC */
}

void
complex_vars_of_gc (void)
{
  Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
}