/* Incremental, generational, concurrent GC using MPS.
   Copyright (C) 2024 Free Software Foundation, Inc.

This file is part of GNU Emacs.

Author: Gerd Möllmann <gerd@gnu.org>

GNU Emacs 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 3 of the License, or (at
your option) any later version.

GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>. */

// clang-format on

#include <config.h>
#include "igc.h"
#include <limits.h>
#include <mps.h>
#include <mpsavm.h>
#include <mpscamc.h>
#include <mpscawl.h>
#include <mpslib.h>
#include <stdlib.h>
#include "lisp.h"
#include "bignum.h"
#include "buffer.h"
#include "coding.h"
#include "dispextern.h"
#include "emacs-module.h"
#include "font.h"
#include "frame.h"
#include "intervals.h"
#include "itree.h"
#include "pdumper.h"
#include "termhooks.h"
#include "thread.h"
#include "treesit.h"
#include "puresize.h"

#ifndef USE_LSB_TAG
# error "USE_LSB_TAG required"
#endif
#ifdef WIDE_EMACS_INT
# error "WIDE_EMACS_INT not supported"
#endif
#if USE_STACK_LISP_OBJECTS
# error "USE_STACK_LISP_OBJECTS not supported"
#endif
#ifndef HAVE_PDUMPER
# error "HAVE_PDUMPER required"
#endif
#ifdef HAVE_TEXT_CONVERSION
//# error "HAVE_TEXT_CONVERSION not supported"
# warning "HAVE_TEXT_CONVERSION not supported"
#endif

/* Note: Emacs will call allocation functions whlle aborting. This leads
   to all sorts of interesting phenomena when an assertion fails inside
   a function called from MPS.

   Example: We assert while MPS holds a lock, and MPS finds that it
   already holds the lock while Emacs is handling the assertion failure.

   The function signature must be that of mps_lib_assert_fail_t.  */

static void
igc_assert_fail (const char *file, unsigned line, const char *msg)
{
  die (msg, file, line);
}

#ifdef IGC_DEBUG

#define igc_assert(expr)				\
  do							\
    {							\
      if (!(expr))					\
	igc_assert_fail (__FILE__, __LINE__, #expr);	\
    }							\
  while (0)						\

#else
# define igc_assert(expr) (void) 9
#endif

#define igc_static_assert(x) verify (x)
#define IGC_TAG_MASK (~VALMASK)

/* Using mps_arena_has_addr is expensive. so try to do something that is
   "good enough". This can return true for malloc'd memory. */

static mps_addr_t min_addr, max_addr;

static bool
is_pure (const mps_addr_t addr)
{
  return PURE_P (addr);
}

static bool
is_mps (const mps_addr_t addr)
{
  return addr >= min_addr && addr < max_addr && !pdumper_object_p (addr)
    && !c_symbol_p (addr) && !is_pure (addr);
}

enum
{
  IGC_ALIGN = GCALIGNMENT,
  IGC_ALIGN_DFLT = IGC_ALIGN,
};

static bool
is_aligned (const mps_addr_t addr)
{
  return ((mps_word_t) addr & IGC_TAG_MASK) == 0;
}

#define IGC_CHECK_RES(res)			\
  do						\
    {						\
      if ((res) != MPS_RES_OK)			\
	emacs_abort ();				\
    }						\
  while (0)					\

#define IGC_WITH_PARKED(gc)                        \
  for (int i = (mps_arena_park (gc->arena), 1); i; \
       i = (mps_arena_release (gc->arena), 0))

#define IGC_DEFINE_LIST(data)                                                  \
  typedef struct data##_list                                                   \
  {                                                                            \
    struct data##_list *next, *prev;                                           \
    data d;                                                                    \
  } data##_list;                                                               \
                                                                               \
  static data##_list *data##_list_push (data##_list **head, data *d)           \
  {                                                                            \
    data##_list *r = xzalloc (sizeof *r);                                      \
    r->d = *d;                                                                 \
    r->next = *head;                                                           \
    r->prev = NULL;                                                            \
    if (r->next)                                                               \
      r->next->prev = r;                                                       \
    *head = r;                                                                 \
    return r;                                                                  \
  }                                                                            \
                                                                               \
  static void data##_list_remove (data *d, data##_list **head, data##_list *r) \
  {                                                                            \
    if (r->next)                                                               \
      r->next->prev = r->prev;                                                 \
    if (r->prev)                                                               \
      r->prev->next = r->next;                                                 \
    else                                                                       \
      *head = r->next;                                                         \
    *d = r->d;                                                                 \
    xfree (r);                                                                 \
  }

enum igc_obj_type
{
  IGC_OBJ_INVALID,
  IGC_OBJ_PAD,
  IGC_OBJ_FWD,
  IGC_OBJ_CONS,
  IGC_OBJ_SYMBOL,
  IGC_OBJ_INTERVAL,
  IGC_OBJ_STRING,
  IGC_OBJ_STRING_DATA,
  IGC_OBJ_VECTOR,
  IGC_OBJ_ITREE_TREE,
  IGC_OBJ_ITREE_NODE,
  IGC_OBJ_IMAGE,
  IGC_OBJ_FACE,
  IGC_OBJ_FACE_CACHE,
  IGC_OBJ_FLOAT,
  IGC_OBJ_BLV,
  IGC_OBJ_WEAK,
  IGC_OBJ_LAST
};

static const char *obj_type_names[] = {
  "IGC_OBJ_INVALID",	"IGC_OBJ_PAD",	       "IGC_OBJ_FWD",
  "IGC_OBJ_CONS",	"IGC_OBJ_SYMBOL",      "IGC_OBJ_INTERVAL",
  "IGC_OBJ_STRING",	"IGC_OBJ_STRING_DATA", "IGC_OBJ_VECTOR",
  "IGC_OBJ_ITREE_TREE", "IGC_OBJ_ITREE_NODE",  "IGC_OBJ_IMAGE",
  "IGC_OBJ_FACE",	"IGC_OBJ_FACE_CACHE",  "IGC_OBJ_FLOAT",
  "IGC_OBJ_BLV",	"IGC_OBJ_WEAK",
};

igc_static_assert (ARRAYELTS (obj_type_names) == IGC_OBJ_LAST);

struct igc_stats
{
  struct
  {
    size_t nwords;
    size_t nobjs;
  } obj[IGC_OBJ_LAST];

  struct
  {
    size_t nwords;
    size_t nobjs;
  } pvec[PVEC_TAG_MAX + 1];
};

/* Always having a header makes it possible to have an
   address-independant hash, which is (a) much easier to handle than MPS
   location dependencies, and (b) makes it possible to implement sxhash
   variants in a way that works as expected even if GCs happen between
   calls.  */

enum
{
  IGC_TYPE_BITS = 5,
  IGC_PVEC_BITS = 6,
  IGC_HASH_BITS = 21,
  IGC_SIZE_BITS = 32
};

igc_static_assert (IGC_OBJ_LAST - 1 < (1 << IGC_TYPE_BITS));
igc_static_assert (PVEC_TAG_MAX < (1 << IGC_PVEC_BITS));

struct igc_header
{
  enum igc_obj_type obj_type : IGC_TYPE_BITS;
  enum pvec_type pvec_type : IGC_PVEC_BITS;
  mps_word_t hash : IGC_HASH_BITS;
  mps_word_t nwords : IGC_SIZE_BITS;
};

igc_static_assert (sizeof (struct igc_header) == 8);

static mps_word_t
to_words (mps_word_t nbytes)
{
  igc_assert (nbytes % sizeof (mps_word_t) == 0);
  return nbytes / sizeof (mps_word_t);
}

static mps_word_t
to_bytes (mps_word_t nwords)
{
  return nwords << 3;
}

struct igc_fwd
{
  struct igc_header header;
  mps_addr_t new_base_addr;
};

static mps_addr_t
client_to_base (mps_addr_t client_addr)
{
  return (char *) client_addr - sizeof (struct igc_header);
}

static mps_addr_t
base_to_client (mps_addr_t base_addr)
{
  return (char *) base_addr + sizeof (struct igc_header);
}

static size_t
igc_round (size_t nbytes, size_t align)
{
  return ROUNDUP (nbytes, align);
}

/* Value is the size in bytes that we need to allocate from MPS
   for a client object of size NBYTES. */

static size_t
obj_size (size_t nbytes)
{
  nbytes += sizeof (struct igc_header);
  nbytes = max (nbytes, sizeof (struct igc_fwd));
  nbytes = igc_round (nbytes, IGC_ALIGN_DFLT);
  return nbytes;
}

struct igc_root
{
  struct igc *gc;
  mps_root_t root;
  void *start, *end;
  bool ambig;
};

typedef struct igc_root igc_root;
IGC_DEFINE_LIST (igc_root);

struct igc_thread
{
  struct igc *gc;
  mps_thr_t thr;
  mps_ap_t dflt_ap;
  mps_ap_t leaf_ap;
  mps_ap_t weak_strong_ap;
  mps_ap_t weak_weak_ap;
  igc_root_list *specpdl_root;
  igc_root_list *bc_root;
  struct thread_state *ts;
};

typedef struct igc_thread igc_thread;
IGC_DEFINE_LIST (igc_thread);

struct igc
{
  mps_arena_t arena;
  mps_chain_t chain;
  mps_fmt_t dflt_fmt;
  mps_pool_t dflt_pool;
  mps_fmt_t leaf_fmt;
  mps_pool_t leaf_pool;
  mps_fmt_t weak_fmt;
  mps_pool_t weak_pool;
  struct igc_root_list *roots;
  struct igc_thread_list *threads;
};

static struct igc *global_igc;

static struct igc_root_list *
register_root (struct igc *gc, mps_root_t root, void *start, void *end,
	       bool ambig)
{
  struct igc_root r
    = { .gc = gc, .root = root, .start = start, .end = end, .ambig = ambig };
  return igc_root_list_push (&gc->roots, &r);
}

static mps_root_t
deregister_root (struct igc_root_list *r)
{
  struct igc_root root;
  igc_root_list_remove (&root, &r->d.gc->roots, r);
  return root.root;
}

static void
destroy_root (struct igc_root_list **r)
{
  mps_root_destroy (deregister_root (*r));
  *r = NULL;
}

static struct igc_thread_list *
register_thread (struct igc *gc, mps_thr_t thr, struct thread_state *ts)
{
  struct igc_thread t = { .gc = gc, .thr = thr, .ts = ts };
  return igc_thread_list_push (&gc->threads, &t);
}

static mps_thr_t
deregister_thread (struct igc_thread_list *t)
{
  struct igc_thread thread;
  igc_thread_list_remove (&thread, &t->d.gc->threads, t);
  return thread.thr;
}

#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-variable"

static mps_res_t
fix_lisp_obj (mps_ss_t ss, Lisp_Object *pobj)
{
  MPS_SCAN_BEGIN (ss)
  {
    mps_word_t *p = (mps_word_t *) pobj;
    mps_word_t word = *p;
    mps_word_t tag = word & IGC_TAG_MASK;

    if (tag == Lisp_Int0 || tag == Lisp_Int1)
      return MPS_RES_OK;
    else if (tag == Lisp_Type_Unused0)
      emacs_abort ();

    if (tag == Lisp_Symbol)
      {
	ptrdiff_t off = word ^ tag;
	mps_addr_t client = (mps_addr_t) ((char *) lispsym + off);
	if (is_mps (client))
	  {
	    mps_addr_t base = client_to_base (client);
	    if (MPS_FIX1 (ss, base))
	      {
		mps_res_t res = MPS_FIX2 (ss, &base);
		if (res != MPS_RES_OK)
		  return res;
		client = base_to_client (base);
		ptrdiff_t new_off = (char *) client - (char *) lispsym;
		*p = new_off | tag;
	      }
	  }
      }
    else
      {
	/* I have encountered cases where MPS_FIX1 returns true, but the
	   reference is somewhere completely off, so that MPS_FIX2 asserts.
	   IOW, MPS_FIX1 has undefined behavior if called on an address that
	   is not in the arena.  */
	mps_addr_t client = (mps_addr_t) (word ^ tag);
	if (is_mps (client))
	  {
	    mps_addr_t base = client_to_base (client);
	    if (MPS_FIX1 (ss, base))
	      {
		mps_res_t res = MPS_FIX2 (ss, &base);
		if (res != MPS_RES_OK)
		  return res;
		client = base_to_client (base);
		*p = (mps_word_t) client | tag;
	      }
	  }
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_raw (mps_ss_t ss, mps_addr_t *p)
{
  MPS_SCAN_BEGIN (ss)
  {
    mps_addr_t client = *p;
    if (is_mps (client) && is_aligned (client))
      {
	mps_addr_t base = client_to_base (client);
	if (MPS_FIX1 (ss, base))
	  {
	    mps_res_t res = MPS_FIX2 (ss, &base);
	    if (res != MPS_RES_OK)
	      return res;
	    *p = base_to_client (base);
	  }
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

#define IGC_FIX12_OBJ(ss, p)                           \
  do                                                   \
    {                                                  \
      mps_res_t res;                                   \
      MPS_FIX_CALL (ss, res = fix_lisp_obj (ss, (p))); \
      if (res != MPS_RES_OK)                           \
	return res;                                    \
    }                                                  \
  while (0)

#define IGC_FIX12_RAW(ss, p)                                     \
  do                                                             \
    {                                                            \
      mps_res_t res;                                             \
      MPS_FIX_CALL (ss, res = fix_raw (ss, (mps_addr_t *) (p))); \
      if (res != MPS_RES_OK)                                     \
	return res;                                              \
    }                                                            \
  while (0)

#define IGC_FIX12_NOBJS(ss, a, n)                            \
  do                                                         \
    {                                                        \
      mps_res_t res;                                         \
      MPS_FIX_CALL ((ss), res = fix_array ((ss), (a), (n))); \
      if (res != MPS_RES_OK)                                 \
	return res;                                          \
    }                                                        \
  while (0)

#define IGC_FIX_CALL(ss, expr)         \
  do                                   \
    {                                  \
      mps_res_t res;                   \
      MPS_FIX_CALL (ss, res = (expr)); \
      if (res != MPS_RES_OK)           \
	return res;                    \
    }                                  \
  while (0)

#define IGC_FIX_CALL_FN(ss, type, client_addr, fn) \
  do                                               \
    {                                              \
      type *obj_ = (type *) client_addr;           \
      mps_res_t res;                               \
      MPS_FIX_CALL (ss, res = fn (ss, obj_));      \
      if (res != MPS_RES_OK)                       \
	return res;                                \
    }                                              \
  while (0)

static mps_res_t
fix_array (mps_ss_t ss, Lisp_Object *array, size_t n)
{
  MPS_SCAN_BEGIN (ss)
  {
    for (size_t i = 0; i < n; ++i)
      IGC_FIX12_OBJ (ss, &array[i]);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_staticvec (mps_ss_t ss, void *start, void *end, void *closure)
{
  igc_assert (start == staticvec);
  MPS_SCAN_BEGIN (ss)
  {
    for (Lisp_Object **p = start; (void *) p < end; ++p)
      if (*p)
	IGC_FIX12_OBJ (ss, *p);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_fwd (mps_ss_t ss, lispfwd fwd)
{
  MPS_SCAN_BEGIN (ss)
  {
    switch (XFWDTYPE (fwd))
      {
      case Lisp_Fwd_Int:
      case Lisp_Fwd_Bool:
      case Lisp_Fwd_Kboard_Obj:
	break;

      case Lisp_Fwd_Obj:
	{
	  /* It is not guaranteed that we see all of these when
	     scanning staticvec because of DEFVAR_LISP_NOPRO.  */
	  struct Lisp_Objfwd *o = (void *) fwd.fwdptr;
	  IGC_FIX12_OBJ (ss, o->objvar);
	}
	break;

      case Lisp_Fwd_Buffer_Obj:
	{
	  struct Lisp_Buffer_Objfwd *b = (void *) fwd.fwdptr;
	  IGC_FIX12_OBJ (ss, &b->predicate);
	}
	break;
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_symbol (mps_ss_t ss, struct Lisp_Symbol *sym)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_OBJ (ss, &sym->u.s.name);
    IGC_FIX12_OBJ (ss, &sym->u.s.function);
    IGC_FIX12_OBJ (ss, &sym->u.s.plist);
    IGC_FIX12_RAW (ss, &sym->u.s.next);
    switch (sym->u.s.redirect)
      {
      case SYMBOL_PLAINVAL:
	IGC_FIX12_OBJ (ss, &sym->u.s.val.value);
	break;

      case SYMBOL_VARALIAS:
	IGC_FIX12_RAW (ss, &sym->u.s.val.alias);
	break;

      case SYMBOL_LOCALIZED:
	IGC_FIX12_RAW (ss, &sym->u.s.val.blv);
	break;

      case SYMBOL_FORWARDED:
	IGC_FIX_CALL (ss, fix_fwd (ss, sym->u.s.val.fwd));
	break;
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

/* This exists because we need access to a threads' current specpdl
   pointer, which means we need access to the thread_state, which can
   move in memory. */

static mps_res_t
scan_igc (mps_ss_t ss, void *start, void *end, void *closure)
{
  igc_assert (start == (void *) global_igc);
  MPS_SCAN_BEGIN (ss)
  {
    struct igc *gc = start;
    for (struct igc_thread_list *t = gc->threads; t; t = t->next)
      IGC_FIX12_RAW (ss, &t->d.ts);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_lispsym (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    for (struct Lisp_Symbol *sym = start; (void *) sym < end; ++sym)
      IGC_FIX_CALL (ss, fix_symbol (ss, sym));
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_rdstack (mps_ss_t ss, void *start, void *end, void *closure)
{
  if (rdstack.stack == NULL)
    return MPS_RES_OK;

  MPS_SCAN_BEGIN (ss)
  {
    for (ptrdiff_t i = 0; i < rdstack.sp; i++)
      {
	struct read_stack_entry *e = &rdstack.stack[i];
	switch (e->type)
	  {
	  case RE_list_start:
	    break;
	  case RE_list:
	  case RE_list_dot:
	    IGC_FIX12_OBJ (ss, &e->u.list.head);
	    IGC_FIX12_OBJ (ss, &e->u.list.tail);
	    break;
	  case RE_vector:
	  case RE_record:
	  case RE_char_table:
	  case RE_sub_char_table:
	  case RE_byte_code:
	  case RE_string_props:
	    IGC_FIX12_OBJ (ss, &e->u.vector.elems);
	    break;
	  case RE_special:
	    IGC_FIX12_OBJ (ss, &e->u.special.symbol);
	    break;
	  case RE_numbered:
	    IGC_FIX12_OBJ (ss, &e->u.numbered.number);
	    IGC_FIX12_OBJ (ss, &e->u.numbered.placeholder);
	    break;
	  }
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_specpdl (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    /* MPS docs say that root scanning functions have exclusive access to
       what is being scanned, the same way format scanning functions
       do. That means I can use the thread's specpdl_ptr here. */
    struct igc_thread_list *t = closure;
    igc_assert (start == (void *) t->d.ts->m_specpdl);
    igc_assert (end == (void *) t->d.ts->m_specpdl_end);
    end = t->d.ts->m_specpdl_ptr;

    for (union specbinding *pdl = start; (void *) pdl < end; ++pdl)
      {
	switch (pdl->kind)
	  {
	  case SPECPDL_UNWIND:
	    IGC_FIX12_OBJ (ss, &pdl->unwind.arg);
	    break;

	    /* This is used by SAFE_ALLOCA/malloc. */
	  case SPECPDL_UNWIND_ARRAY:
	    IGC_FIX12_NOBJS (ss, pdl->unwind_array.array,
			     pdl->unwind_array.nelts);
	    break;

	  case SPECPDL_UNWIND_EXCURSION:
	    IGC_FIX12_OBJ (ss, &pdl->unwind_excursion.marker);
	    IGC_FIX12_OBJ (ss, &pdl->unwind_excursion.window);
	    break;

	    /* The bt.args member either points to something on a
	       thread's control stack, or to something in the bytecode
	       stack. Both should already be ambiguous roots.  */
	  case SPECPDL_BACKTRACE:
	    break;

#ifdef HAVE_MODULES
	  case SPECPDL_MODULE_RUNTIME:
	    break;

	    // If I am not mistaken, the emacs_env in this binding
	    // actually lives on the stack (see module-load e.g.).
	    // So, we don't have to do something here for the Lisp
	    // objects in emacs_env.
	  case SPECPDL_MODULE_ENVIRONMENT:
	    break;
#endif

	  case SPECPDL_LET_DEFAULT:
	  case SPECPDL_LET_LOCAL:
	    IGC_FIX12_OBJ (ss, &pdl->let.where);
	    FALLTHROUGH;
	  case SPECPDL_LET:
	    IGC_FIX12_OBJ (ss, &pdl->let.symbol);
	    IGC_FIX12_OBJ (ss, &pdl->let.old_value);
	    break;

	  case SPECPDL_UNWIND_PTR:
	    /* This defines a mark function of its own, which
	       is of no use to us.  Only user is sort.c. */
	    if (pdl->unwind_ptr.mark)
	      {
		igc_assert (!"SPECPDL_UNWIND_PTR with mark function");
	      }
	    break;

	  case SPECPDL_UNWIND_INT:
	  case SPECPDL_UNWIND_INTMAX:
	  case SPECPDL_UNWIND_VOID:
	  case SPECPDL_NOP:
	    break;
	  }
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

/* Scan the area of memory [START, END) ambiguously. In general,
   references may be either tagged words or pointers. This is used for
   blocks allocated with malloc and thread stacks. */

static mps_res_t
scan_ambig (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    for (mps_word_t *p = start; p < (mps_word_t *) end; ++p)
      {
	mps_word_t word = *p;
	mps_word_t tag = word & IGC_TAG_MASK;

	/* If the references in the object being scanned are
	   ambiguous then MPS_FIX2() does not update the
	   reference (because it can’t know if it’s a
	   genuine reference). The MPS handles an ambiguous
	   reference by pinning the block pointed to so that
	   it cannot move. */
	mps_addr_t ref = (mps_addr_t) word;
	mps_res_t res = MPS_FIX12 (ss, &ref);
	if (res != MPS_RES_OK)
	  return res;

	switch (tag)
	  {
	  case Lisp_Int0:
	  case Lisp_Int1:
	  case Lisp_Type_Unused0:
	    break;

	  case Lisp_Symbol:
	    {
	      ptrdiff_t off = word ^ tag;
	      ref = (mps_addr_t) ((char *) lispsym + off);
	      res = MPS_FIX12 (ss, &ref);
	      if (res != MPS_RES_OK)
		return res;
	    }
	    break;

	  default:
	    ref = (mps_addr_t) (word ^ tag);
	    res = MPS_FIX12 (ss, &ref);
	    if (res != MPS_RES_OK)
	      return res;
	    break;
	  }
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_pure (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    igc_assert (start == (void *) pure);
    extern ptrdiff_t pure_bytes_used_lisp;
    end = (char *) pure + pure_bytes_used_lisp;
    if (end > start)
      IGC_FIX_CALL (ss, scan_ambig (ss, start, end, NULL));
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_bc (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    struct igc_thread_list *t = closure;
    struct bc_thread_state *bc = &t->d.ts->bc;
    igc_assert (start == (void *) bc->stack);
    igc_assert (end == (void *) bc->stack_end);
    end = bc_next_frame (bc->fp);
    if (end > start)
      IGC_FIX_CALL (ss, scan_ambig (ss, start, end, NULL));
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_exact (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    for (Lisp_Object *p = start; (void *) p < end; ++p)
      IGC_FIX12_OBJ (ss, p);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
scan_ptr_exact (mps_ss_t ss, void *start, void *end, void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    for (void **p = start; (void *) p < end; ++p)
      if (*p)
	IGC_FIX12_RAW (ss, p);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

/***********************************************************************
			 Default pad, fwd, ...
 ***********************************************************************/

static void
dflt_pad (mps_addr_t base_addr, mps_word_t nbytes)
{
  igc_assert (nbytes >= sizeof (struct igc_header));
  struct igc_header *h = base_addr;
  h->obj_type = IGC_OBJ_PAD;
  h->nwords = to_words (nbytes);
}

static void
dflt_fwd (mps_addr_t old_base_addr, mps_addr_t new_base_addr)
{
  struct igc_header *h = old_base_addr;
  igc_assert (to_bytes (h->nwords) >= sizeof (struct igc_fwd));
  igc_assert (h->obj_type != IGC_OBJ_PAD);
  struct igc_fwd *f = old_base_addr;
  f->header.obj_type = IGC_OBJ_FWD;
  f->new_base_addr = new_base_addr;
}

static mps_addr_t
is_dflt_fwd (mps_addr_t base_addr)
{
  struct igc_fwd *f = base_addr;
  if (f->header.obj_type == IGC_OBJ_FWD)
    return f->new_base_addr;
  return NULL;
}

static mps_addr_t
dflt_skip (mps_addr_t base_addr)
{
  struct igc_header *h = base_addr;
  mps_addr_t next = (char *) base_addr + to_bytes (h->nwords);
  igc_assert (to_bytes (h->nwords) >= sizeof (struct igc_header));
  return next;
}

static mps_res_t
fix_string (mps_ss_t ss, struct Lisp_String *s)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_RAW (ss, &s->u.s.data);
    IGC_FIX12_RAW (ss, &s->u.s.intervals);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_interval (mps_ss_t ss, struct interval *iv)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_RAW (ss, &iv->left);
    IGC_FIX12_RAW (ss, &iv->right);
    if (iv->up_obj)
      IGC_FIX12_OBJ (ss, &iv->up.obj);
    else if (iv->up.interval)
      IGC_FIX12_RAW (ss, &iv->up.interval);
    IGC_FIX12_OBJ (ss, &iv->plist);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_itree_tree (mps_ss_t ss, struct itree_tree *t)
{
  MPS_SCAN_BEGIN (ss)
  {
    if (t->root)
      IGC_FIX12_RAW (ss, &t->root);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_itree_node (mps_ss_t ss, struct itree_node *n)
{
  MPS_SCAN_BEGIN (ss)
  {
    if (n->parent)
      IGC_FIX12_RAW (ss, &n->parent);
    if (n->left)
      IGC_FIX12_RAW (ss, &n->left);
    if (n->right)
      IGC_FIX12_RAW (ss, &n->right);
    IGC_FIX12_OBJ (ss, &n->data);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_image (mps_ss_t ss, struct image *i)
{
  MPS_SCAN_BEGIN (ss)
  {
#ifdef HAVE_WINDOW_SYSTEM
    IGC_FIX12_OBJ (ss, &i->spec);
    IGC_FIX12_OBJ (ss, &i->dependencies);
    IGC_FIX12_OBJ (ss, &i->lisp_data);
    IGC_FIX12_RAW (ss, &i->next);
    IGC_FIX12_RAW (ss, &i->prev);
#endif
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_face (mps_ss_t ss, struct face *f)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_NOBJS (ss, f->lface, ARRAYELTS (f->lface));
    IGC_FIX12_RAW (ss, &f->font);
    IGC_FIX12_RAW (ss, &f->next);
    IGC_FIX12_RAW (ss, &f->prev);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_face_cache (mps_ss_t ss, struct face_cache *c)
{
  MPS_SCAN_BEGIN (ss)
  {
    if (c->faces_by_id)
      for (int i = 0; i < c->used; ++i)
	{
	  igc_assert (c->faces_by_id[i] != NULL);
	  IGC_FIX12_RAW (ss, &c->faces_by_id[i]);
	}

    if (c->buckets)
      for (int i = 0; i < FACE_CACHE_BUCKETS_SIZE; ++i)
	if (c->buckets[i])
	  IGC_FIX12_RAW (ss, &c->buckets[i]);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_weak (mps_ss_t ss, mps_addr_t base)
{
  MPS_SCAN_BEGIN (ss) { igc_assert (!"fix_weak"); }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_cons (mps_ss_t ss, struct Lisp_Cons *cons)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_OBJ (ss, &cons->u.s.car);
    IGC_FIX12_OBJ (ss, &cons->u.s.u.cdr);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_blv (mps_ss_t ss, struct Lisp_Buffer_Local_Value *blv)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_OBJ (ss, &blv->where);
    IGC_FIX12_OBJ (ss, &blv->defcell);
    IGC_FIX12_OBJ (ss, &blv->valcell);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t fix_vector (mps_ss_t ss, struct Lisp_Vector *v);

static mps_res_t
dflt_scanx (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
	    void *closure)
{
  MPS_SCAN_BEGIN (ss)
  {
    for (mps_addr_t base = base_start; base < base_limit;
	 base = dflt_skip (base))
      {
	mps_addr_t client = base_to_client (base);
	struct igc_header *header = base;

	if (closure)
	  {
	    struct igc_stats *st = closure;
	    st->obj[header->obj_type].nwords += header->nwords;
	    st->obj[header->obj_type].nobjs += 1;
	    st->obj[header->pvec_type].nwords += header->nwords;
	    st->obj[header->pvec_type].nobjs += 1;
	  }

	switch (header->obj_type)
	  {
	  case IGC_OBJ_INVALID:
	    emacs_abort ();

	  case IGC_OBJ_PAD:
	  case IGC_OBJ_FWD:
	    continue;

	  case IGC_OBJ_CONS:
	    IGC_FIX_CALL_FN (ss, struct Lisp_Cons, client, fix_cons);
	    break;

	  case IGC_OBJ_STRING_DATA:
	  case IGC_OBJ_FLOAT:
	  case IGC_OBJ_LAST:
	    emacs_abort ();

	  case IGC_OBJ_SYMBOL:
	    IGC_FIX_CALL_FN (ss, struct Lisp_Symbol, client, fix_symbol);
	    break;

	  case IGC_OBJ_INTERVAL:
	    IGC_FIX_CALL_FN (ss, struct interval, client, fix_interval);
	    break;

	  case IGC_OBJ_STRING:
	    IGC_FIX_CALL_FN (ss, struct Lisp_String, client, fix_string);
	    break;

	  case IGC_OBJ_VECTOR:
	    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, client, fix_vector);
	    break;

	  case IGC_OBJ_ITREE_TREE:
	    IGC_FIX_CALL_FN (ss, struct itree_tree, client, fix_itree_tree);
	    break;

	  case IGC_OBJ_ITREE_NODE:
	    IGC_FIX_CALL_FN (ss, struct itree_node, client, fix_itree_node);
	    break;

	  case IGC_OBJ_IMAGE:
	    IGC_FIX_CALL_FN (ss, struct image, client, fix_image);
	    break;

	  case IGC_OBJ_FACE:
	    IGC_FIX_CALL_FN (ss, struct face, client, fix_face);
	    break;

	  case IGC_OBJ_FACE_CACHE:
	    IGC_FIX_CALL_FN (ss, struct face_cache, client, fix_face_cache);
	    break;

	  case IGC_OBJ_BLV:
	    IGC_FIX_CALL_FN (ss, struct Lisp_Buffer_Local_Value, client,
			     fix_blv);
	    break;

	  case IGC_OBJ_WEAK:
	    IGC_FIX_CALL_FN (ss, mps_word_t, client, fix_weak);
	    break;
	  }
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
dflt_scan (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL (ss, dflt_scanx (ss, base_start, base_limit, NULL));
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static enum pvec_type
pseudo_vector_type (const struct Lisp_Vector *v)
{
  return PSEUDOVECTOR_TYPE (v);
}

static mps_res_t
fix_vectorlike (mps_ss_t ss, struct Lisp_Vector *v)
{
  MPS_SCAN_BEGIN (ss)
  {
    ptrdiff_t size = v->header.size;
    if (size & PSEUDOVECTOR_FLAG)
      size &= PSEUDOVECTOR_SIZE_MASK;
#ifdef IGC_DEBUG
    /* V can be something like &main_thread */
    if (is_mps (v))
      {
	struct igc_header *h = client_to_base (v);
	igc_assert (to_bytes (h->nwords) >= size * word_size);
      }
#endif
    IGC_FIX12_NOBJS (ss, v->contents, size);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_buffer (mps_ss_t ss, struct buffer *b)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, b, fix_vectorlike);
    IGC_FIX12_RAW (ss, &b->own_text.intervals);
    IGC_FIX12_RAW (ss, &b->own_text.markers);
    IGC_FIX12_RAW (ss, &b->overlays);
    IGC_FIX12_RAW (ss, &b->own_text.markers);

    IGC_FIX12_RAW (ss, &b->base_buffer);
    if (b->base_buffer)
      b->text = &b->base_buffer->own_text;
    else
      b->text = &b->own_text;

    // FIXME: special handling of undo_list?
    IGC_FIX12_OBJ (ss, &b->undo_list_);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_frame (mps_ss_t ss, struct frame *f)
{
  MPS_SCAN_BEGIN (ss)
  {
    // FIXME
    // output_data;
    // terminal
    // glyph_pool
    // glyph matrices
    // struct font_driver_list *font_driver_list;
    // struct text_conversion_state conversion;
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, f, fix_vectorlike);
    IGC_FIX12_RAW (ss, &f->face_cache);
    if (f->terminal)
      IGC_FIX12_RAW (ss, &f->terminal);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_window (mps_ss_t ss, struct window *w)
{
  MPS_SCAN_BEGIN (ss)
  {
    /* FIXME: matrices... */
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, w, fix_vectorlike);

    /* FIXME: window.h syas the following two are "marked specially", so
       they are not seen by fix_vectorlike. That's of course a no-go
       with MPS. What ever is special about these, we have to find
       another way to accomplish that with MPS. */
    IGC_FIX12_OBJ (ss, &w->prev_buffers);
    IGC_FIX12_OBJ (ss, &w->next_buffers);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_hash_table (mps_ss_t ss, struct Lisp_Hash_Table *h)
{
  MPS_SCAN_BEGIN (ss)
  {
    // FIXME: weak
    IGC_FIX12_NOBJS (ss, h->key, h->table_size);
    IGC_FIX12_NOBJS (ss, h->value, h->table_size);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_char_table (mps_ss_t ss, struct Lisp_Vector *v)
{
  MPS_SCAN_BEGIN (ss)
  {
    int size = v->header.size & PSEUDOVECTOR_SIZE_MASK;
    enum pvec_type type = pseudo_vector_type (v);
    int idx = type == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0;
    for (int i = idx; i < size; ++i)
      IGC_FIX12_OBJ (ss, &v->contents[i]);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_overlay (mps_ss_t ss, struct Lisp_Overlay *o)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_RAW (ss, &o->buffer);
    IGC_FIX12_OBJ (ss, &o->plist);
    IGC_FIX12_RAW (ss, &o->interval);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_subr (mps_ss_t ss, struct Lisp_Subr *s)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_OBJ (ss, &s->command_modes);
#ifdef HAVE_NATIVE_COMP
    IGC_FIX12_OBJ (ss, &s->intspec.native);
    IGC_FIX12_OBJ (ss, &s->command_modes);
    IGC_FIX12_OBJ (ss, &s->native_comp_u);
    IGC_FIX12_OBJ (ss, &s->lambda_list);
    IGC_FIX12_OBJ (ss, &s->type);
#endif
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_misc_ptr (mps_ss_t ss, struct Lisp_Misc_Ptr *p)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, p, fix_vectorlike);
    IGC_FIX12_RAW (ss, &p->pointer);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_user_ptr (mps_ss_t ss, struct Lisp_User_Ptr *p)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, p, fix_vectorlike);
    IGC_FIX12_RAW (ss, &p->p);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_handler (mps_ss_t ss, struct handler *h)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_OBJ (ss, &h->tag_or_ch);
    IGC_FIX12_OBJ (ss, &h->val);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_thread (mps_ss_t ss, struct thread_state *s)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, s, fix_vectorlike);
    IGC_FIX12_RAW (ss, &s->m_current_buffer);
    IGC_FIX12_RAW (ss, &s->next_thread);
    for (struct handler *h = s->m_handlerlist; h; h = h->next)
      IGC_FIX_CALL_FN (ss, struct handler, h, fix_handler);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

/* This is here because main_thread is, for some reason, a variable in
   the data segment, and not like other threads. */

static mps_res_t
scan_main_thread (mps_ss_t ss, void *start, void *end, void *closure)
{
  igc_assert (start == (void *) &main_thread);
  MPS_SCAN_BEGIN (ss)
  {
    struct thread_state *s = start;
    IGC_FIX_CALL (ss, fix_thread (ss, s));
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_mutex (mps_ss_t ss, struct Lisp_Mutex *m)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, m, fix_vectorlike);
    IGC_FIX12_RAW (ss, &m->name);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_coding (mps_ss_t ss, struct coding_system *c)
{
  MPS_SCAN_BEGIN (ss)
  {
    if (c)
      {
	IGC_FIX12_OBJ (ss, &c->src_object);
	IGC_FIX12_OBJ (ss, &c->dst_object);
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_terminal (mps_ss_t ss, struct terminal *t)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, t, fix_vectorlike);
    IGC_FIX12_RAW (ss, &t->next_terminal);
    // These are malloc'd, so they can be accessed.
    IGC_FIX_CALL_FN (ss, struct coding_system, t->keyboard_coding, fix_coding);
    IGC_FIX_CALL_FN (ss, struct coding_system, t->terminal_coding, fix_coding);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_marker (mps_ss_t ss, struct Lisp_Marker *m)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX12_RAW (ss, &m->buffer);
    IGC_FIX12_RAW (ss, &m->next);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_finalizer (mps_ss_t ss, struct Lisp_Finalizer *f)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, f, fix_vectorlike);
    IGC_FIX12_RAW (ss, &f->next);
    IGC_FIX12_RAW (ss, &f->prev);
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

#ifdef HAVE_XWIDGETS

static mps_res_t
fix_xwidget (mps_ss_t ss, struct xwidget *w)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, w, fix_vectorlike);
    igc_assert (!"xwidget");
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_xwidget_view (mps_ss_t ss, struct xwidget_view *v)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
    igc_assert (!"xwidget_view");
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

#endif // HAVE_XWIDGETS

static mps_res_t
fix_other (mps_ss_t ss, void *o)
{
  MPS_SCAN_BEGIN (ss)
  {
    IGC_FIX_CALL_FN (ss, struct Lisp_Vector, o, fix_vectorlike);
    // Not used on macOS. Some scroll bar stuff in w32?
    igc_assert (!"other");
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

static mps_res_t
fix_obarray (mps_ss_t ss, struct Lisp_Obarray *o)
{
  MPS_SCAN_BEGIN (ss)
  {
    if (o->buckets)
      IGC_FIX12_NOBJS (ss, o->buckets, obarray_size (o));
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

/* Note that there is a small window after committing a vectorlike
   allocation where the object is zeroed, and so the vector header is
   also zero.  This doesn't have an adverse effect. */

static mps_res_t
fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
{
  MPS_SCAN_BEGIN (ss)
  {
    switch (pseudo_vector_type (v))
      {
      case PVEC_OBARRAY:
	IGC_FIX_CALL_FN (ss, struct Lisp_Obarray, v, fix_obarray);
	break;

      case PVEC_BUFFER:
	IGC_FIX_CALL_FN (ss, struct buffer, v, fix_buffer);
	break;

      case PVEC_FRAME:
	IGC_FIX_CALL_FN (ss, struct frame, v, fix_frame);
	break;

      case PVEC_WINDOW:
	IGC_FIX_CALL_FN (ss, struct window, v, fix_window);
	break;

      case PVEC_HASH_TABLE:
	IGC_FIX_CALL_FN (ss, struct Lisp_Hash_Table, v, fix_hash_table);
	break;

      case PVEC_CHAR_TABLE:
      case PVEC_SUB_CHAR_TABLE:
	IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_char_table);
	break;

      case PVEC_BOOL_VECTOR:
	break;

      case PVEC_OVERLAY:
	IGC_FIX_CALL_FN (ss, struct Lisp_Overlay, v, fix_overlay);
	break;

      case PVEC_SUBR:
	IGC_FIX_CALL_FN (ss, struct Lisp_Subr, v, fix_subr);
	break;

      case PVEC_FREE:
	emacs_abort ();

      case PVEC_FINALIZER:
	IGC_FIX_CALL_FN (ss, struct Lisp_Finalizer, v, fix_finalizer);
	break;

      case PVEC_OTHER:
	IGC_FIX_CALL_FN (ss, void, v, fix_other);
	break;

      case PVEC_MISC_PTR:
	IGC_FIX_CALL_FN (ss, struct Lisp_Misc_Ptr, v, fix_misc_ptr);
	break;

      case PVEC_USER_PTR:
	IGC_FIX_CALL_FN (ss, struct Lisp_User_Ptr, v, fix_user_ptr);
	break;

#ifdef HAVE_XWIDGETS
      case PVEC_XWIDGET:
	IGC_FIX_CALL_FN (ss, struct xwidget, v, fix_xwidget);
	break;

      case PVEC_XWIDGET_VIEW:
	IGC_FIX_CALL_FN (ss, struct xwidget_view, v, fix_xwidget_view);
	break;
#endif

      case PVEC_THREAD:
	IGC_FIX_CALL_FN (ss, struct thread_state, v, fix_thread);
	break;

      case PVEC_MUTEX:
	IGC_FIX_CALL_FN (ss, struct Lisp_Mutex, v, fix_mutex);
	break;

      case PVEC_TERMINAL:
	IGC_FIX_CALL_FN (ss, struct terminal, v, fix_terminal);
	break;

      case PVEC_MARKER:
	IGC_FIX_CALL_FN (ss, struct Lisp_Marker, v, fix_marker);
	break;

      case PVEC_BIGNUM:
	break;

      case PVEC_NORMAL_VECTOR:
      case PVEC_SYMBOL_WITH_POS:
      case PVEC_PROCESS:
      case PVEC_WINDOW_CONFIGURATION:
      case PVEC_XWIDGET:
      case PVEC_XWIDGET_VIEW:
      case PVEC_MODULE_FUNCTION:
      case PVEC_CONDVAR:
      case PVEC_NATIVE_COMP_UNIT:
      case PVEC_TS_COMPILED_QUERY:
      case PVEC_TS_NODE:
      case PVEC_TS_PARSER:
      case PVEC_SQLITE:
      case PVEC_COMPILED:
      case PVEC_RECORD:
      case PVEC_FONT:
	IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
	break;
      }
  }
  MPS_SCAN_END (ss);
  return MPS_RES_OK;
}

#pragma GCC diagnostic pop

static igc_root_list *
root_create (struct igc *gc, void *start, void *end, mps_rank_t rank,
	     mps_area_scan_t scan, bool ambig)
{
  mps_root_t root;
  mps_res_t res
    = mps_root_create_area (&root, gc->arena, rank, 0, start, end, scan, 0);
  IGC_CHECK_RES (res);
  return register_root (gc, root, start, end, ambig);
}

static igc_root_list *
root_create_ambig (struct igc *gc, void *start, void *end)
{
  return root_create (gc, start, end, mps_rank_ambig (), scan_ambig, true);
}

static igc_root_list *
root_create_exact (struct igc *gc, void *start, void *end, mps_area_scan_t scan)
{
  return root_create (gc, start, end, mps_rank_exact (), scan, false);
}

static void
root_create_staticvec (struct igc *gc)
{
  root_create_exact (gc, staticvec, staticvec + ARRAYELTS (staticvec),
		     scan_staticvec);
}

static void
root_create_lispsym (struct igc *gc)
{
  root_create_exact (gc, lispsym, lispsym + ARRAYELTS (lispsym), scan_lispsym);
}

static void
root_create_buffer (struct igc *gc, struct buffer *b)
{
  void *start = &b->name_, *end = &b->own_text;
  root_create_ambig (gc, start, end);
}

static void
root_create_terminal_list (struct igc *gc)
{
  void *start = &terminal_list;
  void *end = (char *) start + sizeof (terminal_list);
  root_create_ambig (gc, start, end);
}

static void
root_create_main_thread (struct igc *gc)
{
  void *start = &main_thread;
  void *end = (char *) &main_thread + sizeof (main_thread);
  root_create_exact (gc, start, end, scan_main_thread);
}

void
igc_root_create_ambig (void *start, void *end)
{
  root_create_ambig (global_igc, start, end);
}

void
igc_root_create_exact (Lisp_Object *start, Lisp_Object *end)
{
  root_create_exact (global_igc, start, end, scan_exact);
}

void
igc_root_create_exact_ptr (void *var_addr)
{
  void *start = var_addr;
  void *end = (char *) start + sizeof (void *);
  root_create_exact (global_igc, start, end, scan_ptr_exact);
}

static void
root_create_specpdl (struct igc_thread_list *t)
{
  struct igc *gc = t->d.gc;
  struct thread_state *ts = t->d.ts;
  igc_assert (ts->m_specpdl != NULL);
  igc_assert (t->d.specpdl_root == NULL);
  mps_root_t root;
  mps_res_t res
    = mps_root_create_area (&root, gc->arena, mps_rank_exact (), 0,
			    ts->m_specpdl, ts->m_specpdl_end, scan_specpdl, t);
  IGC_CHECK_RES (res);
  t->d.specpdl_root
    = register_root (gc, root, ts->m_specpdl, ts->m_specpdl_end, false);
}

static void
root_create_bc (struct igc_thread_list *t)
{
  struct igc *gc = t->d.gc;
  struct bc_thread_state *bc = &t->d.ts->bc;
  igc_assert (bc->stack != NULL);
  mps_root_t root;
  mps_res_t res = mps_root_create_area (&root, gc->arena, mps_rank_ambig (), 0,
					bc->stack, bc->stack_end, scan_bc, t);
  IGC_CHECK_RES (res);
  igc_assert (t->d.bc_root == NULL);
  t->d.bc_root = register_root (gc, root, bc->stack, bc->stack_end, true);
}

static void
root_create_igc (struct igc *gc)
{
  root_create (gc, gc, gc + 1, mps_rank_exact (), scan_igc, false);
}

static void
root_create_pure (struct igc *gc)
{
  void *start = &pure[0];
  void *end = &pure[PURESIZE];
  root_create (gc, start, end, mps_rank_ambig (), scan_pure, true);
}

static void
root_create_thread (struct igc_thread_list *t)
{
  struct igc *gc = t->d.gc;
  mps_root_t root;
  void *cold = (void *) t->d.ts->m_stack_bottom;
  mps_res_t res
    = mps_root_create_thread_scanned (&root, gc->arena, mps_rank_ambig (), 0,
				      t->d.thr, scan_ambig, 0, cold);
  IGC_CHECK_RES (res);
  register_root (gc, root, cold, NULL, true);
}

static void
root_create_rdstack (struct igc *gc)
{
  root_create_exact (gc, &rdstack, &rdstack + 1, scan_rdstack);
}

void
igc_on_grow_specpdl (void)
{
  /* Note that no two roots may overlap, so we have to temporarily
     stop the collector while replacing one root with another (xpalloc
     may realloc). Alternatives: (1) don't realloc, (2) alloc specpdl
     from MPS pool that is scanned. */
  struct igc_thread_list *t = current_thread->gc_info;
  IGC_WITH_PARKED (t->d.gc)
  {
    destroy_root (&t->d.specpdl_root);
    root_create_specpdl (t);
  }
}

static mps_res_t
create_weak_ap (mps_ap_t *ap, struct igc_thread *t, bool weak)
{
  struct igc *gc = t->gc;
  mps_res_t res;
  mps_pool_t pool = gc->weak_pool;
  MPS_ARGS_BEGIN (args)
  {
    MPS_ARGS_ADD (args, MPS_KEY_RANK,
		  weak ? mps_rank_weak () : mps_rank_exact ());
    res = mps_ap_create_k (ap, pool, args);
  }
  MPS_ARGS_END (args);
  return res;
}

static void
create_thread_aps (struct igc_thread *t)
{
  struct igc *gc = t->gc;
  mps_res_t res;
  res = mps_ap_create_k (&t->dflt_ap, gc->dflt_pool, mps_args_none);
  IGC_CHECK_RES (res);
  res = mps_ap_create_k (&t->leaf_ap, gc->leaf_pool, mps_args_none);
  IGC_CHECK_RES (res);
  res = create_weak_ap (&t->weak_strong_ap, t, false);
  IGC_CHECK_RES (res);
  res = create_weak_ap (&t->weak_weak_ap, t, true);
  IGC_CHECK_RES (res);
}

static struct igc_thread_list *
thread_add (struct thread_state *ts)
{
  mps_thr_t thr;
  mps_res_t res = mps_thread_reg (&thr, global_igc->arena);
  IGC_CHECK_RES (res);
  struct igc_thread_list *t = register_thread (global_igc, thr, ts);
  root_create_thread (t);
  create_thread_aps (&t->d);
  return t;
}

void *
igc_thread_add (struct thread_state *ts)
{
  struct igc_thread_list *t = thread_add (ts);
  root_create_specpdl (t);
  root_create_bc (t);
  return t;
}

void
igc_on_alloc_main_thread_specpdl (void)
{
  root_create_specpdl (current_thread->gc_info);
}

void
igc_on_alloc_main_thread_bc (void)
{
  root_create_bc (current_thread->gc_info);
}

static void
add_main_thread (void)
{
  igc_assert (current_thread->gc_info == NULL);
  igc_assert (current_thread->m_stack_bottom == stack_bottom);
  current_thread->gc_info = thread_add (current_thread);
}

void
igc_thread_remove (void *info)
{
  struct igc_thread_list *t = info;
  mps_ap_destroy (t->d.dflt_ap);
  mps_ap_destroy (t->d.leaf_ap);
  mps_ap_destroy (t->d.weak_strong_ap);
  mps_ap_destroy (t->d.weak_weak_ap);
  mps_thread_dereg (t->d.thr);
  destroy_root (&t->d.specpdl_root);
  destroy_root (&t->d.bc_root);
  deregister_thread (t);
}

static void
release_arena (void)
{
  mps_arena_release (global_igc->arena);
}

specpdl_ref
igc_park_arena (void)
{
  specpdl_ref count = SPECPDL_INDEX ();
  record_unwind_protect_void (release_arena);
  mps_arena_park (global_igc->arena);
  return count;
}

void
igc_on_pdump_loaded (void *start, void *end)
{
  root_create_ambig (global_igc, start, end);
}

static igc_root_list *
root_find (void *start)
{
  for (igc_root_list *r = global_igc->roots; r; r = r->next)
    if (r->d.start == start)
      return r;
  return NULL;
}

Lisp_Object *
igc_xalloc_lisp_objs_exact (size_t n)
{
  size_t size = n * sizeof (Lisp_Object);
  void *p = xzalloc (size);
  root_create_exact (global_igc, p, (char *) p + size, scan_exact);
  return p;
}

void *
igc_xzalloc_ambig (size_t size)
{
  /* Not sure if xzalloc can ever return NULL here, depending on all the
     config options involved. Also not sure when it returns non-null for
     size 0. It does for me on macOS. */
  void *p = xzalloc (size);
  if (p == NULL)
    return NULL;

  /* Can't make a root that has zero length. Want one to be able to
     detect calling igc_free on something not having a root. */
  void *end = (char *) p + size;
  if (end == p)
    end = (char *) p + IGC_ALIGN_DFLT;
  root_create_ambig (global_igc, p, end);
  return p;
}

void
igc_xfree (void *p)
{
  if (p == NULL || pdumper_object_p (p))
    return;
  struct igc_root_list *r = root_find (p);
  igc_assert (r != NULL);
  destroy_root (&r);
  xfree (p);
}

void *
igc_xpalloc_ambig (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
		   ptrdiff_t nitems_max, ptrdiff_t item_size)
{
  IGC_WITH_PARKED (global_igc)
  {
    if (pa)
      {
	struct igc_root_list *r = root_find (pa);
	igc_assert (r != NULL);
	destroy_root (&r);
      }
    pa = xpalloc (pa, nitems, nitems_incr_min, nitems_max, item_size);
    char *end = (char *) pa + *nitems * item_size;
    root_create_ambig (global_igc, pa, end);
  }
  return pa;
}

void *
igc_xnrealloc_ambig (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
{
  IGC_WITH_PARKED (global_igc)
  {
    if (pa)
      {
	struct igc_root_list *r = root_find (pa);
	igc_assert (r != NULL);
	destroy_root (&r);
      }
    pa = xnrealloc (pa, nitems, item_size);
    char *end = (char *) pa + nitems * item_size;
    root_create_ambig (global_igc, pa, end);
  }
  return pa;
}

void
igc_create_charset_root (void *table, size_t size)
{
  root_create_ambig (global_igc, table, (char *) table + size);
}

static void
finalize_hash_table (struct Lisp_Hash_Table *h)
{
  if (h->table_size)
    {
      /* Set the table size to 0 so that we don't further scan a hash
	 table after it has been finalized. Also, keep in mind that
	 xfree works with objects in a loaded dump. */
      h->table_size = 0;
      xfree (h->index);
      xfree (h->key);
      xfree (h->value);
      xfree (h->next);
      xfree (h->hash);
    }
}

static void
finalize_obarray (struct Lisp_Obarray *o)
{
  if (o->buckets)
    {
      void *b = o->buckets;
      o->buckets = NULL;
      xfree (b);
    }
}

static void
finalize_bignum (struct Lisp_Bignum *n)
{
  mpz_clear (n->value);
}

static void
finalize_font (struct font *font)
{
  struct Lisp_Vector *v = (void *) font;
  if ((v->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)
    {
      /* The font driver might sometimes be NULL, e.g. if Emacs was
	 interrupted before it had time to set it up.  */
      const struct font_driver *drv = font->driver;
      if (drv)
	{
	  /* Attempt to catch subtle bugs like Bug#16140.  */
	  eassert (valid_font_driver (drv));
	  drv->close_font (font);
	}
    }

#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
  /* The Android font driver needs the ability to associate extra
     information with font entities.  */
  if (((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_ENTITY_MAX)
      && PSEUDOVEC_STRUCT (vector, font_entity)->is_android)
    android_finalize_font_entity (PSEUDOVEC_STRUCT (vector, font_entity));
#endif
}

static void
finalize_user_ptr (struct Lisp_User_Ptr *p)
{
  if (p->finalizer)
    p->finalizer (p->p);
}

static void
finalize_ts_parser (struct Lisp_TS_Parser *p)
{
#ifdef HAVE_TREE_SITTER
  treesit_delete_parser (p);
#endif
}

static void
finalize_ts_query (struct Lisp_TS_Query *q)
{
#ifdef HAVE_TREE_SITTER
  treesit_delete_query (q);
#endif
}

static void
finalize_module_function (struct Lisp_Module_Function *f)
{
#ifdef HAVE_MODULES
  module_finalize_function (f);
#endif
}

static void
finalize_comp_unit (struct Lisp_Native_Comp_Unit *u)
{
#ifdef HAVE_NATIVE_COMP
  unload_comp_unit (u);
#endif
}

static void
finalize_subr (struct Lisp_Subr *subr)
{
#ifdef HAVE_NATIVE_COMP
  if (!NILP (subr->native_comp_u))
    {
      subr->native_comp_u = Qnil;
      xfree ((char *) subr->symbol_name);
      xfree (subr->native_c_name);
    }
#endif
}

static Lisp_Object
finalizer_handler (Lisp_Object args)
{
  add_to_log ("finalizer failed: %S", args);
  return Qnil;
}

static void
finalize_finalizer (struct Lisp_Finalizer *f)
{
  Lisp_Object fun = f->function;
  if (!NILP (fun))
    {
      f->function = Qnil;
      unchain_finalizer (f);
      specpdl_ref count = SPECPDL_INDEX ();
      ++number_finalizers_run;
      specbind (Qinhibit_quit, Qt);
      internal_condition_case_1 (call0, fun, Qt, finalizer_handler);
      unbind_to (count, Qnil);
    }
}

static void
finalize_vector (mps_addr_t v)
{
  switch (pseudo_vector_type (v))
    {
    case PVEC_FREE:
      emacs_abort ();

    case PVEC_HASH_TABLE:
      finalize_hash_table (v);
      break;

    case PVEC_BIGNUM:
      finalize_bignum (v);
      break;

    case PVEC_FONT:
      finalize_font (v);
      break;

    case PVEC_THREAD:
      finalize_one_thread (v);
      break;

    case PVEC_MUTEX:
      finalize_one_mutex (v);
      break;

    case PVEC_CONDVAR:
      finalize_one_condvar (v);
      break;

    case PVEC_USER_PTR:
      finalize_user_ptr (v);
      break;

    case PVEC_TS_PARSER:
      finalize_ts_parser (v);
      break;

    case PVEC_TS_COMPILED_QUERY:
      finalize_ts_query (v);
      break;

    case PVEC_MODULE_FUNCTION:
      finalize_module_function (v);
      break;

    case PVEC_NATIVE_COMP_UNIT:
      finalize_comp_unit (v);
      break;

    case PVEC_SUBR:
      finalize_subr (v);
      break;

    case PVEC_FINALIZER:
      finalize_finalizer (v);
      break;

    case PVEC_OBARRAY:
      finalize_obarray (v);
      break;

    case PVEC_SYMBOL_WITH_POS:
    case PVEC_PROCESS:
    case PVEC_RECORD:
    case PVEC_COMPILED:
    case PVEC_SQLITE:
    case PVEC_TS_NODE:
    case PVEC_NORMAL_VECTOR:
    case PVEC_WINDOW_CONFIGURATION:
    case PVEC_BUFFER:
    case PVEC_FRAME:
    case PVEC_WINDOW:
    case PVEC_CHAR_TABLE:
    case PVEC_SUB_CHAR_TABLE:
    case PVEC_BOOL_VECTOR:
    case PVEC_OVERLAY:
    case PVEC_OTHER:
    case PVEC_MISC_PTR:
    case PVEC_XWIDGET:
    case PVEC_XWIDGET_VIEW:
    case PVEC_TERMINAL:
    case PVEC_MARKER:
      igc_assert (!"not implemented");
      break;
    }
}

static void
finalize (struct igc *gc, mps_addr_t base)
{
  mps_addr_t client = base_to_client (base);
  struct igc_header *h = base;
  switch (h->obj_type)
    {
    case IGC_OBJ_INVALID:
    case IGC_OBJ_PAD:
    case IGC_OBJ_FWD:
      emacs_abort ();

    case IGC_OBJ_CONS:
    case IGC_OBJ_SYMBOL:
    case IGC_OBJ_INTERVAL:
    case IGC_OBJ_STRING:
    case IGC_OBJ_STRING_DATA:
    case IGC_OBJ_ITREE_TREE:
    case IGC_OBJ_ITREE_NODE:
    case IGC_OBJ_IMAGE:
    case IGC_OBJ_FACE:
    case IGC_OBJ_FACE_CACHE:
    case IGC_OBJ_FLOAT:
    case IGC_OBJ_WEAK:
    case IGC_OBJ_BLV:
    case IGC_OBJ_LAST:
      igc_assert (!"finalize not implemented");
      break;

    case IGC_OBJ_VECTOR:
      finalize_vector (client);
      break;
    }
}

static void
maybe_finalize (mps_addr_t client, enum pvec_type tag)
{
  mps_addr_t ref = client_to_base (client);
  switch (tag)
    {
    case PVEC_HASH_TABLE:
    case PVEC_BIGNUM:
    case PVEC_FONT:
    case PVEC_THREAD:
    case PVEC_MUTEX:
    case PVEC_CONDVAR:
    case PVEC_USER_PTR:
    case PVEC_TS_PARSER:
    case PVEC_TS_COMPILED_QUERY:
    case PVEC_MODULE_FUNCTION:
    case PVEC_NATIVE_COMP_UNIT:
    case PVEC_SUBR:
    case PVEC_FINALIZER:
    case PVEC_OBARRAY:
      mps_finalize (global_igc->arena, &ref);
      break;

    case PVEC_NORMAL_VECTOR:
    case PVEC_FREE:
    case PVEC_MARKER:
    case PVEC_OVERLAY:
    case PVEC_SYMBOL_WITH_POS:
    case PVEC_MISC_PTR:
    case PVEC_PROCESS:
    case PVEC_FRAME:
    case PVEC_WINDOW:
    case PVEC_BOOL_VECTOR:
    case PVEC_BUFFER:
    case PVEC_TERMINAL:
    case PVEC_XWIDGET:
    case PVEC_XWIDGET_VIEW:
    case PVEC_OTHER:
    case PVEC_WINDOW_CONFIGURATION:
    case PVEC_TS_NODE:
    case PVEC_SQLITE:
    case PVEC_COMPILED:
    case PVEC_CHAR_TABLE:
    case PVEC_SUB_CHAR_TABLE:
    case PVEC_RECORD:
      break;
    }
}

/* Process MPS messages. This should be extended to handle messages only
   for a certain amoount of time. See mps_clock_t, mps_clock, and
   mps_clocks_per_sec functions.  */

static void
process_messages (struct igc *gc)
{
  mps_message_type_t type;
  while (mps_message_queue_type (&type, gc->arena))
    {
      mps_message_t msg;
      if (!mps_message_get (&msg, gc->arena, type))
	continue;

      if (type == mps_message_type_finalization ())
	{
	  mps_addr_t base_addr;
	  mps_message_finalization_ref (&base_addr, gc->arena, msg);
	  finalize (gc, base_addr);
	}
      else if (type == mps_message_type_gc_start ())
	{
	  const char *why = mps_message_gc_start_why (gc->arena, msg);
	  fprintf (stderr, "*** MPS GC start: %s\n", why);
	}

      mps_message_discard (gc->arena, msg);
    }
}

static void
enable_messages (struct igc *gc, bool enable)
{
  void (*fun) (mps_arena_t, mps_message_type_t)
    = enable ? mps_message_type_enable : mps_message_type_disable;
  fun (gc->arena, mps_message_type_finalization ());
  fun (gc->arena, mps_message_type_gc_start ());
}

void
igc_process_messages (void)
{
  process_messages (global_igc);
}

void
igc_on_idle (void)
{
  process_messages (global_igc);
  mps_arena_step (global_igc->arena, 0.1, 0);
}

static mps_ap_t
thread_ap (enum igc_obj_type type)
{
  struct igc_thread_list *t = current_thread->gc_info;
  switch (type)
    {
    case IGC_OBJ_INVALID:
    case IGC_OBJ_PAD:
    case IGC_OBJ_FWD:
    case IGC_OBJ_LAST:
    case IGC_OBJ_WEAK:
      emacs_abort ();

    case IGC_OBJ_CONS:
    case IGC_OBJ_SYMBOL:
    case IGC_OBJ_INTERVAL:
    case IGC_OBJ_STRING:
    case IGC_OBJ_VECTOR:
    case IGC_OBJ_ITREE_TREE:
    case IGC_OBJ_ITREE_NODE:
    case IGC_OBJ_IMAGE:
    case IGC_OBJ_FACE:
    case IGC_OBJ_FACE_CACHE:
    case IGC_OBJ_BLV:
      return t->d.dflt_ap;

    case IGC_OBJ_STRING_DATA:
    case IGC_OBJ_FLOAT:
      return t->d.leaf_ap;
    }
  emacs_abort ();
}

/* Conditional breakpoints can be so slow that it is often more
   effective to instrument code. This fucntion is for such cases. */
void
igc_break (void)
{
}

void
igc_collect (void)
{
  struct igc *gc = global_igc;
  mps_arena_collect (gc->arena);
  mps_arena_release (gc->arena);
}

static unsigned
obj_hash (void)
{
  static unsigned obj_count = 0;
  if (obj_count == (1 << IGC_HASH_BITS))
    obj_count = 0;
  return obj_count++;
}

size_t
igc_hash (Lisp_Object key)
{
  mps_word_t word = XLI (key);
  mps_word_t tag = word & IGC_TAG_MASK;
  mps_addr_t client = NULL;
  switch (tag)
    {
    case Lisp_Type_Unused0:
      emacs_abort ();

    case Lisp_Int0:
    case Lisp_Int1:
      return word;

    case Lisp_Symbol:
      {
	ptrdiff_t off = word ^ tag;
	client = (mps_addr_t) ((char *) lispsym + off);
      }
      break;

    case Lisp_String:
    case Lisp_Vectorlike:
    case Lisp_Cons:
    case Lisp_Float:
      client = (mps_addr_t) (word ^ tag);
      break;
    }

  if (is_mps (client))
    {
      // The following assertion is very expensive.
      // igc_assert (mps_arena_has_addr (global_igc->arena, client));
      struct igc_header *h = client_to_base (client);
      return h->hash;
    }

  return word;
}

static mps_addr_t
alloc (size_t size, enum igc_obj_type type, enum pvec_type pvec_type)
{
  mps_ap_t ap = thread_ap (type);
  mps_addr_t p, obj;
  size = obj_size (size);
  do
    {
      mps_res_t res = mps_reserve (&p, ap, size);
      if (res)
	memory_full (0);
      // Object _must_ have valid contents before commit
      memclear (p, size);
      struct igc_header *h = p;
      h->obj_type = type;
      h->pvec_type = pvec_type;
      h->hash = obj_hash ();
      igc_assert (size < ((size_t) 1 << IGC_SIZE_BITS));
      h->nwords = to_words (size);
      obj = base_to_client (p);
    }
  while (!mps_commit (ap, p, size));
  return obj;
}

Lisp_Object
igc_make_cons (Lisp_Object car, Lisp_Object cdr)
{
  struct Lisp_Cons *cons = alloc (sizeof *cons, IGC_OBJ_CONS, PVEC_FREE);
  cons->u.s.car = car;
  cons->u.s.u.cdr = cdr;
  return make_lisp_ptr (cons, Lisp_Cons);
}

Lisp_Object
igc_alloc_symbol (void)
{
  struct Lisp_Symbol *sym = alloc (sizeof *sym, IGC_OBJ_SYMBOL, PVEC_FREE);
  return make_lisp_symbol (sym);
}

Lisp_Object
igc_make_float (double val)
{
  struct Lisp_Float *f = alloc (sizeof *f, IGC_OBJ_FLOAT, PVEC_FREE);
  f->u.data = val;
  return make_lisp_ptr (f, Lisp_Float);
}

static unsigned char *
alloc_string_data (size_t nbytes, bool clear)
{
  unsigned char *data = alloc (nbytes + 1, IGC_OBJ_STRING_DATA, PVEC_FREE);
  data[nbytes] = 0;
  return data;
}

/* Reallocate multibyte STRING data when a single character is
   replaced. The character is at byte offset BYTE_POS in the string.
   The character being replaced is CHAR_LEN bytes long, and the
   character that will replace it is NEW_CLEN bytes long.  Return the
   address where the caller should store the new character.  */
unsigned char *
igc_replace_char (Lisp_Object string, ptrdiff_t at_byte_pos,
		  ptrdiff_t old_char_len, ptrdiff_t new_char_len)
{
  struct Lisp_String *s = XSTRING (string);

  // Replacing caaracters of the same length.
  if (old_char_len == new_char_len)
    return s->u.s.data + at_byte_pos;

  ptrdiff_t old_nbytes = SBYTES (string);
  ptrdiff_t nbytes_needed = old_nbytes + (new_char_len - old_char_len);
  struct igc_header *old_header = client_to_base (s->u.s.data);
  ptrdiff_t capacity = to_bytes (old_header->nwords) - sizeof *old_header;
  if (capacity < nbytes_needed)
    {
      unsigned char *new_data = alloc_string_data (nbytes_needed, false);
      memcpy (new_data, SDATA (string), old_nbytes);
      s->u.s.data = new_data;
    }

  // Set up string as if the character had been inserted.
  s->u.s.size_byte = nbytes_needed;
  unsigned char *insertion_addr = s->u.s.data + at_byte_pos;
  memmove (insertion_addr + new_char_len, insertion_addr + old_char_len,
	   eabs (new_char_len - old_char_len));
  return insertion_addr;
}

Lisp_Object
igc_make_string (size_t nchars, size_t nbytes, bool unibyte, bool clear)
{
  struct Lisp_String *s = alloc (sizeof *s, IGC_OBJ_STRING, PVEC_FREE);
  s->u.s.size = nchars;
  s->u.s.size_byte = unibyte ? -1 : nbytes;
  s->u.s.data = alloc_string_data (nbytes, clear);
  return make_lisp_ptr (s, Lisp_String);
}

Lisp_Object
igc_make_multibyte_string (size_t nchars, size_t nbytes, bool clear)
{
  return igc_make_string (nchars, nbytes, false, clear);
}

Lisp_Object
igc_make_unibyte_string (size_t nchars, size_t nbytes, bool clear)
{
  return igc_make_string (nchars, nbytes, true, clear);
}

struct interval *
igc_make_interval (void)
{
  return alloc (sizeof (struct interval), IGC_OBJ_INTERVAL, PVEC_FREE);
}

struct Lisp_Vector *
igc_alloc_pseudovector (size_t nwords_mem, size_t nwords_lisp,
			size_t nwords_zero, enum pvec_type tag)
{
  struct Lisp_Vector *v
    = alloc (header_size + nwords_mem * word_size, IGC_OBJ_VECTOR, tag);
  XSETPVECTYPESIZE (v, tag, nwords_lisp, nwords_mem - nwords_lisp);
  maybe_finalize (v, tag);
  return v;
}

struct Lisp_Vector *
igc_alloc_vector (ptrdiff_t len)
{
  struct Lisp_Vector *v
    = alloc (header_size + len * word_size, IGC_OBJ_VECTOR, PVEC_NORMAL_VECTOR);
  v->header.size = len;
  return v;
}

struct Lisp_Vector *
igc_alloc_record (ptrdiff_t len)
{
  struct Lisp_Vector *v
    = alloc (header_size + len * word_size, IGC_OBJ_VECTOR, PVEC_RECORD);
  v->header.size = len;
  XSETPVECTYPE (v, PVEC_RECORD);
  return v;
}

struct itree_tree *
igc_make_itree_tree (void)
{
  struct itree_tree *t = alloc (sizeof *t, IGC_OBJ_ITREE_TREE, PVEC_FREE);
  return t;
}

struct itree_node *
igc_make_itree_node (void)
{
  struct itree_node *n = alloc (sizeof *n, IGC_OBJ_ITREE_NODE, PVEC_FREE);
  return n;
}

#ifdef HAVE_WINDOW_SYSTEM
struct image *
igc_make_image (void)
{
  struct image *img = alloc (sizeof *img, IGC_OBJ_IMAGE, PVEC_FREE);
  return img;
}
#endif

struct face *
igc_make_face (void)
{
  struct face *face = alloc (sizeof *face, IGC_OBJ_FACE, PVEC_FREE);
  return face;
}

struct face_cache *
igc_make_face_cache (void)
{
  struct face_cache *c = alloc (sizeof *c, IGC_OBJ_FACE_CACHE, PVEC_FREE);
  return c;
}

struct Lisp_Buffer_Local_Value *
igc_alloc_blv (void)
{
  struct Lisp_Buffer_Local_Value *blv
    = alloc (sizeof *blv, IGC_OBJ_BLV, PVEC_FREE);
  return blv;
}

int
igc_valid_lisp_object_p (Lisp_Object obj)
{
  return 1;
}

DEFUN ("igc-info", Figc_info, Sigc_info, 0, 0, 0, doc : /* */)
(void)
{
  struct igc *gc = global_igc;
  struct igc_stats st = { 0 };
  mps_res_t res;
  IGC_WITH_PARKED (gc) { res = mps_pool_walk (gc->dflt_pool, dflt_scanx, &st); }
  if (res != MPS_RES_OK)
    error ("Error %d walking memory", res);

  Lisp_Object result = Qnil;
  for (int i = 0; i < IGC_OBJ_LAST; ++i)
    {
      Lisp_Object e
	= list3 (build_string (obj_type_names[i]), make_int (st.obj[i].nobjs),
		 make_int (st.obj[i].nwords));
      result = Fcons (e, result);
    }

  return result;
}

DEFUN ("igc-roots", Figc_roots, Sigc_roots, 0, 0, 0, doc : /* */)
(void)
{
  struct igc *gc = global_igc;
  Lisp_Object roots = Qnil;

  for (igc_root_list *r = gc->roots; r; r = r->next)
    {
      Lisp_Object type = r->d.ambig ? Qambig : Qexact;
      Lisp_Object e = list3 (type, make_int ((intmax_t) r->d.start),
			     make_int ((intmax_t) r->d.end));
      roots = Fcons (e, roots);
    }

  return roots;
}

static void
arena_extended (mps_arena_t arena, void *base, size_t size)
{
  if (min_addr == NULL || base < min_addr)
    min_addr = base;
  mps_addr_t end = (char *) base + size;
  if (max_addr == NULL || end > max_addr)
    max_addr = end;
}

static void
arena_contracted (mps_arena_t arena, void *base, size_t size)
{
  /* Can MPS free something that is in the middle? */
  mps_addr_t end = (char *) base + size;
  if (end == max_addr)
    max_addr = base;
  if (base == min_addr)
    min_addr = end;
}

static void
make_arena (struct igc *gc)
{
  mps_res_t res;
  MPS_ARGS_BEGIN (args)
  {
    MPS_ARGS_ADD (args, MPS_KEY_ARENA_EXTENDED, (mps_fun_t) &arena_extended);
    MPS_ARGS_ADD (args, MPS_KEY_ARENA_CONTRACTED,
		  (mps_fun_t) &arena_contracted);
    res = mps_arena_create_k (&gc->arena, mps_arena_class_vm (), args);
  }
  MPS_ARGS_END (args);
  IGC_CHECK_RES (res);

  mps_gen_param_s gens[] = { { 128000, 0.8 }, { 5 * 128000, 0.4 } };
  res = mps_chain_create (&gc->chain, gc->arena, ARRAYELTS (gens), gens);
  IGC_CHECK_RES (res);
}

static mps_fmt_t
make_dflt_fmt (struct igc *gc)
{
  mps_res_t res;
  mps_fmt_t fmt;
  MPS_ARGS_BEGIN (args)
  {
    MPS_ARGS_ADD (args, MPS_KEY_FMT_ALIGN, IGC_ALIGN);
    /* Don't use in-band headers. I suspect they ahve problems,
       specifically amcSegScanNailedRange calls NailboardGet with a
       client address, which calls NailboardGet, and one can see that
       the the board contains base addresses which leads to an assertion
       failure. */
    MPS_ARGS_ADD (args, MPS_KEY_FMT_HEADER_SIZE, 0);
    MPS_ARGS_ADD (args, MPS_KEY_FMT_SCAN, dflt_scan);
    MPS_ARGS_ADD (args, MPS_KEY_FMT_SKIP, dflt_skip);
    MPS_ARGS_ADD (args, MPS_KEY_FMT_FWD, dflt_fwd);
    MPS_ARGS_ADD (args, MPS_KEY_FMT_ISFWD, is_dflt_fwd);
    MPS_ARGS_ADD (args, MPS_KEY_FMT_PAD, dflt_pad);
    res = mps_fmt_create_k (&fmt, gc->arena, args);
  }
  MPS_ARGS_END (args);
  IGC_CHECK_RES (res);
  return fmt;
}

static mps_pool_t
make_pool_with_class (struct igc *gc, mps_fmt_t fmt, mps_class_t cls)
{
  mps_res_t res;
  mps_pool_t pool;
  MPS_ARGS_BEGIN (args)
  {
    MPS_ARGS_ADD (args, MPS_KEY_FORMAT, fmt);
    MPS_ARGS_ADD (args, MPS_KEY_CHAIN, gc->chain);
    // Must use interior pointers, bc we hand out client pointers.
    MPS_ARGS_ADD (args, MPS_KEY_INTERIOR, true);
    res = mps_pool_create_k (&pool, gc->arena, cls, args);
  }
  MPS_ARGS_END (args);
  IGC_CHECK_RES (res);
  return pool;
}

static mps_pool_t
make_pool_amc (struct igc *gc, mps_fmt_t fmt)
{
  return make_pool_with_class (gc, fmt, mps_class_amc ());
}

static mps_pool_t
make_pool_awl (struct igc *gc, mps_fmt_t fmt)
{
  return make_pool_with_class (gc, fmt, mps_class_awl ());
}

static mps_pool_t
make_pool_amcz (struct igc *gc, mps_fmt_t fmt)
{
  return make_pool_with_class (gc, fmt, mps_class_amcz ());
}

static struct igc *
make_igc (void)
{
  struct igc *gc = xzalloc (sizeof *gc);
  make_arena (gc);

  gc->dflt_fmt = make_dflt_fmt (gc);
  gc->dflt_pool = make_pool_amc (gc, gc->dflt_fmt);
  gc->leaf_fmt = make_dflt_fmt (gc);
  gc->leaf_pool = make_pool_amcz (gc, gc->leaf_fmt);
  gc->weak_fmt = make_dflt_fmt (gc);
  gc->weak_pool = make_pool_awl (gc, gc->weak_fmt);

  root_create_igc (gc);
  root_create_pure (gc);
  root_create_buffer (gc, &buffer_defaults);
  root_create_buffer (gc, &buffer_local_symbols);
  root_create_staticvec (gc);
  root_create_lispsym (gc);
  root_create_terminal_list (gc);
  root_create_main_thread (gc);
  root_create_rdstack (gc);

  enable_messages (gc, true);
  return gc;
}

/* To call from LLDB. */

void
igc_postmortem (void)
{
  mps_arena_postmortem (global_igc->arena);
}

void
init_igc (void)
{
  mps_lib_assert_fail_install (igc_assert_fail);
  global_igc = make_igc ();
  add_main_thread ();
}

void
syms_of_igc (void)
{
  defsubr (&Sigc_info);
  defsubr (&Sigc_roots);
  DEFSYM (Qambig, "ambig");
  DEFSYM (Qexact, "exact");
  Fprovide (intern_c_string ("mps"), Qnil);
}