[m-rev.] for review: add support for MPS GC

[Fergus Henderson]

On 31-Jul-2002, Fergus Henderson <fjh at cs.mu.OZ.AU> wrote:
> Add support for interfacing Mercury with the MPS garbage collector.
> 
> This change is broken into three parts:
> 
> 	1. Import version 1.100.1 of the MPS kit into the Mercury
> 	   CVS repository, in the directory `mercury/mps_gc'.
> 
> 	2. Make some changes to the MPS kit for Mercury,
> 	   to support fully-conservative collection and tagged pointers,
> 	   and to wrap it in an interface that is similar to that of
> 	   the Boehm collector.
> 
> 	3. Modify the rest of the Mercury implementation
> 	   to support linking with the MPS kit instead
> 	   of the Boehm collector.  This involved defining
> 	   `mps' as a new GC method and a new grade component.

This is part 2 of 3.

mps_gc/code/fmtme.h:
mps_gc/code/fmtme.c:
	New files.  These define a new object format variety for Mercury
	objects.  (An object format variety is used to create an object
	format, which tells the MPS toolkit how to trace objects and how
	to determine their size.  For Mercury objects, we add a header
	which records the size of the object, and we scan all the fields
	of the objects conservatively.)

mps_gc/code/mpmtypes.h:
mps_gc/code/mps.h:
mps_gc/code/format.c:
	Various minor changes to support the new "Mercury" object format
	variety.

mps_gc/code/mercury_mps.h:
mps_gc/code/mercury_mps.c:
	New files.  These provide a wrapper around the MPS interface,
	for use with the Mercury implementation.

mps_gc/code/mercury_mps_ss.c:
	New file.  A test case to test mercury_mps.{h,c}.

mps_gc/code/comm.gmk:
	Handle the new files.

mps_gc/code/config.h:
	Define THREAD_SINGLE rather than THREAD_MULTI.

mps_gc/code/gc.gmk:
	Delete -Werror from CFLAGS.

mps_gc/code/global.c:
mps_gc/code/trace.c:
	Modify to handle fully-conservative collection.

mps_gc/code/poolams.c:
	Modify to handle tagged pointers.

mps_gc/code/lockli.c:
	Fix compile errors that occurred when THREAD_SINGLE
	was defined.

--- /dev/null	Wed Jun  5 16:22:54 2002
+++ mps_gc/code/fmtme.c	Wed Jul 31 10:56:25 2002
@@ -0,0 +1,199 @@
+/* fmtme.c: Mercury object format.
+ * This is part of the interface between Mercury and the MPS
+ * memory pool system kit.
+ *
+ * Copyright (c) 2002 Fergus Henderson and The University of Melbourne.
+ * Portions Copyright (c) 2001 Ravenbrook Limited.  
+ * Portions copyright (c) 2002 Global Graphics Software.
+ * See end of file for license.
+ *
+ * The Mercury format is as follows:
+ *	The first word is the size.
+ *	The remaining words contain arbitrary data,
+ *	which is scanned conservatively.
+ */
+
+#include "testlib.h"
+#include "mpscams.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#ifdef MPS_OS_W3
+#include "mpsw3.h"
+#endif
+#include "mps.h"
+#include "mpm.h"	/* for TraceScanArea() */
+#include "fmtme.h"
+#include <stdlib.h>
+#include <stdarg.h>
+#include <math.h>
+#include <string.h>
+#include <assert.h>
+
+#define notreached()    assert(0)
+#define unused(param)   ((void)param)
+
+static mps_res_t mercury_scan(mps_ss_t mps_ss, mps_addr_t base,
+                  mps_addr_t limit);
+static mps_addr_t mercury_skip(mps_addr_t object);
+static void mercury_copy(mps_addr_t old, mps_addr_t new);
+static void mercury_pad(mps_addr_t addr, size_t size);
+
+static struct mps_fmt_mercury_s mercury_fmt_mercury_s =
+{
+  ALIGN,
+  mercury_scan,
+  mercury_skip,
+  mercury_copy,
+  mercury_pad
+};
+
+mps_res_t mercury_scan(mps_ss_t mps_ss,
+                  mps_addr_t base_object,
+                  mps_addr_t limit_object)
+{
+  /* `base' and `limit' are client pointers,
+      i.e. they point at the word *after* the header word.
+     We need to convert them to base pointers before calling TraceScanArea. */
+  return TraceScanArea((ScanState)mps_ss,
+  	(Addr *)CLIENT_PTR_TO_BASE_PTR(base_object),
+  	(Addr *)CLIENT_PTR_TO_BASE_PTR(limit_object));
+}
+
+static mps_addr_t mercury_skip(mps_addr_t object)
+{
+  mps_word_t *base;
+  size_t num_words;
+
+  base = (mps_word_t *)CLIENT_PTR_TO_BASE_PTR(object);
+  num_words = (size_t)base[0];
+
+  return (mps_addr_t)((mps_word_t *)object + num_words);
+}
+
+static void mercury_copy(mps_addr_t old, mps_addr_t new)
+{
+  mps_word_t *old_base, *new_base;
+  size_t num_words;
+
+  /* XXX are `old' and `new' supposed to be base pointers or client pointers? */
+  /* i.e. do they point at or past the header word? */
+  assert(0);
+#if 0
+  old_base = ((mps_word_t *)old);
+  new_base = ((mps_word_t *)new);
+#else
+  old_base = (mps_word_t *)CLIENT_PTR_TO_BASE_PTR(old);
+  new_base = (mps_word_t *)CLIENT_PTR_TO_BASE_PTR(new);
+#endif
+  num_words = (size_t)old_base[0];
+  (void)memcpy(new_base, old_base, num_words * sizeof(mps_word_t));
+}
+
+/*
+void mercury_fwd(mps_addr_t old,
+            mps_addr_t new)
+{
+    unused(old); unused(new);
+    notreached();
+}
+
+mps_addr_t mercury_isfwd(mps_addr_t object)
+{
+    unused(object);
+    notreached();
+    return 0;
+}
+*/
+
+static void mercury_pad(mps_addr_t addr, size_t size)
+{
+  mps_word_t *p;
+  size_t num_words, i;
+
+  /* Make sure the size is aligned. */
+  assert((size & (ALIGN-1)) == 0);
+
+  num_words = size / sizeof(mps_word_t);
+
+  /* XXX is `addr' supposed to be a base pointer or a client pointer? */
+  /* i.e. does it point at or past the header word? */
+  assert(0);
+#if 1
+  p = (mps_word_t *)addr;
+#else
+  p = (mps_word_t *)CLIENT_PTR_TO_BASE_PTR(addr);
+#endif
+
+  /* the first word contains the size */
+  p[0] = num_words;
+
+  /* null out the remaining words, if any */
+  for (i = 1; i < num_words; i++) {
+    p[i] = 0;
+  }
+}
+
+/*
+mps_addr_t mercury_class(mps_addr_t obj)
+{
+    unused(obj);
+    notreached();
+    return 0;
+}
+*/
+
+/* Functions returning the mercury format structures */
+
+mps_fmt_mercury_s *mercury_fmt_mercury(void)
+{
+  return &mercury_fmt_mercury_s;
+}
+
+/* Format variety-independent version that picks the right format
+ * variety and creates it.  */
+
+mps_res_t mercury_fmt(mps_fmt_t *mps_fmt_o, mps_arena_t mps_arena)
+{
+  return mps_fmt_create_mercury(mps_fmt_o, mps_arena, mercury_fmt_mercury());
+}
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2002 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * All rights reserved.  This is an open source license.  Contact
+ * Ravenbrook for commercial licensing options.
+ * 
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ * 
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 
+ * 3. Redistributions in any form must be accompanied by information on how
+ * to obtain complete source code for this software and any accompanying
+ * software that uses this software.  The source code must either be
+ * included in the distribution or be available for no more than the cost
+ * of distribution plus a nominal fee, and must be freely redistributable
+ * under reasonable conditions.  For an executable file, complete source
+ * code means the source code for all modules it contains. It does not
+ * include source code for modules or files that typically accompany the
+ * major components of the operating system on which the executable file
+ * runs.
+ * 
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+ * PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+ * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
--- /dev/null	Wed Jun  5 16:22:54 2002
+++ mps_gc/code/fmtme.h	Wed Jul 31 10:56:35 2002
@@ -0,0 +1,72 @@
+/* fmtme.h: Mercury object format.
+ * This is part of the interface between Mercury and the MPS
+ * memory pool system kit.
+ *
+ * Copyright (c) 2002 Fergus Henderson and The University of Melbourne.
+ * Portions Copyright (c) 2001 Ravenbrook Limited.  
+ * Portions copyright (c) 2002 Global Graphics Software.
+ * See end of file for license.
+ *
+ * The Mercury format is as follows:
+ *	The first word is the size.
+ *	The remaining words contain arbitrary data,
+ *	which is scanned conservatively.
+ */
+
+#include "mps.h"
+
+/* Function returning the mercury format structure */
+
+mps_fmt_mercury_s *mercury_fmt_mercury(void);
+
+/* Format variety-independent version that picks the right format
+ * variety and creates it.  */
+
+mps_res_t mercury_fmt(mps_fmt_t *mps_fmt_o, mps_arena_t mps_arena);
+
+#define ALIGN   	(sizeof(mps_word_t))
+#define TAGMASK   	(sizeof(mps_word_t) - 1)
+
+#define BASE_PTR_TO_CLIENT_PTR(p)((mps_word_t *)(p) + 1)
+#define CLIENT_PTR_TO_BASE_PTR(p)((mps_word_t *)((mps_word_t)p & ~TAGMASK) - 1)
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2002 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * All rights reserved.  This is an open source license.  Contact
+ * Ravenbrook for commercial licensing options.
+ * 
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ * 
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 
+ * 3. Redistributions in any form must be accompanied by information on how
+ * to obtain complete source code for this software and any accompanying
+ * software that uses this software.  The source code must either be
+ * included in the distribution or be available for no more than the cost
+ * of distribution plus a nominal fee, and must be freely redistributable
+ * under reasonable conditions.  For an executable file, complete source
+ * code means the source code for all modules it contains. It does not
+ * include source code for modules or files that typically accompany the
+ * major components of the operating system on which the executable file
+ * runs.
+ * 
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+ * PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+ * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
--- /dev/null	Wed Jun  5 16:22:54 2002
+++ mps_gc/code/mercury_mps.c	Wed Jul 31 10:59:00 2002
@@ -0,0 +1,189 @@
+/* mercury_mps.c: an interface between Mercury and the MPS
+ * memory pool system kit.
+ *
+ * Copyright (c) 2002 Fergus Henderson and The University of Melbourne.
+ * Portions Copyright (c) 2001 Ravenbrook Limited.  
+ * Portions copyright (c) 2002 Global Graphics Software.
+ * See end of file for license.
+ *
+ * .design: Adapted from amsss.c.
+ *	Uses a new "Mercury" object format.
+ *	Conservative scanning.
+ *	Parts of the interface designed to mimmick the
+ *	interface of the Boehm (et al) conservative collector.
+ * DONE:
+ *	- test writing to fields [done]
+ *	- add support for tagged pointers [done]
+ *	- put the test code into a separate file [done]
+ *	- define header file and abstract out the appropriate interfaces [done]
+ *	- use GC_stackbottom, GC_init [done]
+ * TODO:
+ *	- add extra pools for small fixed-size objects
+ *	- add extra pools for atomic objects
+ *	- register main thread's stack as roots
+ *	- register global data as roots
+ *	- register global data in shared libraries as roots
+ */
+
+#include "testlib.h"
+#include "mpscams.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#ifdef MPS_OS_W3
+#include "mpsw3.h"
+#endif
+#include "mps.h"
+#include "fmtme.h"
+#include "mercury_mps.h"
+#include <stdlib.h>
+#include <stdarg.h>
+#include <math.h>
+#include <string.h>
+#include <assert.h>
+
+static void mercury_init_cell(mps_addr_t addr, size_t size);
+
+mps_arena_t	mercury_mps_arena;
+mps_ap_t	mercury_mps_ap; /* XXX should be thread-local */
+mps_thr_t	mercury_mps_thread; /* XXX should be thread-local */
+mps_root_t	mercury_mps_stack; /* XXX should be thread-local */
+mps_fmt_t	mercury_mps_format;
+mps_chain_t	mercury_mps_chain;
+mps_pool_t	mercury_mps_pool;
+
+void *GC_stackbottom;
+
+static mps_pool_debug_option_s freecheckOptions =
+  { NULL, 0, (void *)"Dead", 4 };
+
+/* One generation, with a capacity of 160k,
+   and an expected mortality rate of 90%. */
+static mps_gen_param_s chain_params[1] = { { 160, 0.90 } };
+
+/* check -- Test a return code, and exit on error */
+
+static void check(mps_res_t res, const char *s)
+{
+  if (res != MPS_RES_OK) {
+    error("\n%s: %d\n", s, res);
+  }
+}
+
+void mercury_mps_init(size_t initial_vm_size, mps_bool_t debug)
+{
+  check(mps_arena_create(&mercury_mps_arena, mps_arena_class_vm(),
+  		       initial_vm_size),
+        "arena_create");
+  check(mps_thread_reg(&mercury_mps_thread, mercury_mps_arena), "thread_reg");
+
+  check(mps_root_create_reg(&mercury_mps_stack, mercury_mps_arena,
+			    MPS_RANK_AMBIG, 0, mercury_mps_thread,
+			    mps_stack_scan_ambig, GC_stackbottom, 0),
+      "Root Create\n");
+  check(mercury_fmt(&mercury_mps_format, mercury_mps_arena), "fmt_create");
+  check(mps_chain_create(&mercury_mps_chain, mercury_mps_arena, 1,
+			 chain_params),
+        "chain_create");
+  if (debug) {
+    check(mps_pool_create(&mercury_mps_pool, mercury_mps_arena,
+    			mps_class_ams_debug(), &freecheckOptions,
+			mercury_mps_format, mercury_mps_chain, TRUE),
+          "pool_create(ams_debug,ambig)");
+  } else {
+    check(mps_pool_create(&mercury_mps_pool, mercury_mps_arena, mps_class_ams(),
+    			mercury_mps_format, mercury_mps_chain, TRUE),
+          "pool_create(ams,ambig)");
+  }
+  check(mps_ap_create(&mercury_mps_ap, mercury_mps_pool, MPS_RANK_AMBIG),
+        "ap_create");
+}
+
+void mercury_mps_finish(void)
+{
+  mps_ap_destroy(mercury_mps_ap);
+  mps_pool_destroy(mercury_mps_pool);
+  mps_chain_destroy(mercury_mps_chain);
+  mps_fmt_destroy(mercury_mps_format);
+  mps_root_destroy(mercury_mps_stack);
+  mps_thread_dereg(mercury_mps_thread);
+  mps_arena_destroy(mercury_mps_arena);
+}
+
+static void mercury_init_cell(mps_addr_t addr, size_t size)
+{
+  mps_word_t *p;
+  size_t num_words, i;
+
+  /* Make sure the size is aligned. */
+  assert((size & (ALIGN-1)) == 0);
+
+  /* the first word contains the size */
+  num_words = size / sizeof(mps_word_t);
+  p = (mps_word_t *)addr;
+  p[0] = num_words;
+
+  /* null out the remaining words */
+  for(i = 1; i < num_words; ++i) {
+    p[i] = 0;
+  }
+}
+
+/* Allocate a cell containing the specified number of words.
+   The pointer returned will be word-aligned. */
+mps_addr_t mercury_mps_alloc(size_t num_words)
+{
+  size_t size = (num_words + 1) * sizeof(mps_word_t);
+  mps_addr_t p;
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, p, mercury_mps_ap, size);
+    if (res) {
+      check(res, "MPS_RESERVE_BLOCK");
+    }
+    mercury_init_cell(p, size);
+  } while(!mps_commit(mercury_mps_ap, p, size));
+
+  return (mps_addr_t)BASE_PTR_TO_CLIENT_PTR(p);
+}
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2002 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * All rights reserved.  This is an open source license.  Contact
+ * Ravenbrook for commercial licensing options.
+ * 
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ * 
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 
+ * 3. Redistributions in any form must be accompanied by information on how
+ * to obtain complete source code for this software and any accompanying
+ * software that uses this software.  The source code must either be
+ * included in the distribution or be available for no more than the cost
+ * of distribution plus a nominal fee, and must be freely redistributable
+ * under reasonable conditions.  For an executable file, complete source
+ * code means the source code for all modules it contains. It does not
+ * include source code for modules or files that typically accompany the
+ * major components of the operating system on which the executable file
+ * runs.
+ * 
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+ * PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+ * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
--- /dev/null	Wed Jun  5 16:22:54 2002
+++ mps_gc/code/mercury_mps.h	Wed Jul 31 10:59:17 2002
@@ -0,0 +1,69 @@
+/* mercury_mps.h: an interface between Mercury and the MPS
+ * memory pool system kit.
+ *
+ * Copyright (c) 2002 Fergus Henderson and The University of Melbourne.
+ */
+
+#include "mps.h"
+
+extern mps_arena_t	mercury_mps_arena;
+extern mps_ap_t		mercury_mps_ap; /* XXX should be thread-local */
+extern mps_thr_t	mercury_mps_thread; /* XXX should be thread-local */
+extern mps_fmt_t	mercury_mps_format;
+extern mps_chain_t	mercury_mps_chain;
+extern mps_pool_t	mercury_mps_pool;
+
+/* Allocate and initialize the MPS data structures.
+   The initial_vm_size argument specifies the initial virtual memory
+   size, in bytes, to reserve.  (See the docs for mps_arena_class_vm()
+   in ../manual/reference/index.html for details.)
+   If the debug argument is TRUE, use the debugging version.  */
+void mercury_mps_init(size_t initial_vm_size, mps_bool_t debug);
+
+/* Deallocate the MPS data structures. */
+void mercury_mps_finish(void);
+
+/* Allocate a cell containing the specified number of words.
+   The pointer returned will be word-aligned.
+   Requires mercury_mps_init() to have been called first.  */
+mps_addr_t mercury_mps_alloc(size_t num_words);
+
+/*
+** Define some wrappers around the MPS interface that make it a bit
+** more like the Boehm collector's interface.
+** XXX There are some differences from the Boehm interface, though;
+** see the XXX comments below.
+*/
+
+extern void *GC_stackbottom;
+
+/* XXX only word-aligned, not double-word-aligned */
+#define GC_MALLOC(bytes) \
+  mercury_mps_alloc(((bytes) + sizeof(mps_word_t) - 1) / sizeof(mps_word_t))
+
+/* XXX only word-aligned, not double-word-aligned */
+/* XXX should allocate in an atomic pool */
+#define GC_MALLOC_ATOMIC(bytes) \
+  mercury_mps_alloc(((bytes) + sizeof(mps_word_t) - 1) / sizeof(mps_word_t))
+
+/* XXX should be inline */
+#define GC_MALLOC_WORDS(ptr, num_wds) \
+  ((ptr) = mercury_mps_alloc(num_wds))
+
+/* XXX FIXME should ensure that it doesn't get collected */
+#define GC_MALLOC_UNCOLLECTABLE(bytes) \
+  mercury_mps_alloc(((bytes) + sizeof(mps_word_t) - 1) / sizeof(mps_word_t))
+
+/* XXX when expanding, this copies too many bytes;
+ *     might lead to possible page fault */
+#define GC_REALLOC(old_ptr, new_bytes) \
+  memcpy(GC_MALLOC(new_bytes), (old_ptr), (new_bytes))
+
+#define GC_FREE(ptr) /* nop */
+
+#define GC_INIT() /* nop */
+
+#define GC_gcollect() \
+  (mps_arena_collect(mercury_mps_arena), \
+   mps_arena_release(mercury_mps_arena))
+
--- /dev/null	Wed Jun  5 16:22:54 2002
+++ mps_gc/code/mercury_mps_ss.c	Wed Jul 31 10:59:34 2002
@@ -0,0 +1,219 @@
+/* mercury_mps_ss.c: STRESS TEST for the interface between Mercury
+ * and the MPS memory pool system kit.
+ *
+ * Copyright (c) 2002 Fergus Henderson and The University of Melbourne.
+ * Portions Copyright (c) 2001 Ravenbrook Limited.  
+ * Portions copyright (c) 2002 Global Graphics Software.
+ * See end of file for license.
+ *
+ * .design: Adapted from amsss.c.
+ *	Uses the interface defined in mercury_mps.h.
+ */
+
+#include "mps.h"
+#include "mercury_mps.h"
+#include "fmtme.h"
+#include "testlib.h"
+
+#define exactRootsCOUNT 50
+#define ambigRootsCOUNT 100
+/* This is enough for three GCs. */
+#define totalSizeMAX    800 * (size_t)1024
+#define totalSizeSTEP   200 * (size_t)1024
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL         ((mps_addr_t)0xDECEA5ED)
+#define testArenaSIZE   ((size_t)16<<20) /* 16 Mb */
+#define initTestFREQ    3000
+#define splatTestFREQ   6000
+
+/* we have two sets of roots, but despite the names,
+   actually both are ambiguous roots (i.e. conservatively scanned). */
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+static size_t totalSize = 0;
+
+/* make -- object allocation and init */
+
+static mps_addr_t make(void)
+{
+  size_t length = (rnd() % 20) + 1, size = (length+1) * sizeof(mps_word_t);
+  mps_addr_t p;
+
+  p = mercury_mps_alloc(length);
+
+  totalSize += size;
+  return (mps_addr_t) ((mps_word_t)p | (rnd() & TAGMASK));
+}
+
+static void mercury_write(mps_addr_t addr, mps_addr_t *refs, size_t nr_refs)
+{
+  if (addr != objNULL && ((mps_word_t)addr & 0x1001) != 0x1001) {
+    mps_word_t *p = (mps_word_t *)CLIENT_PTR_TO_BASE_PTR(addr);
+    mps_word_t num_words = p[0];
+
+    /* Update a random entry. */
+    if(num_words > 1) {
+      size_t i = 1 + (rnd() % (num_words - 1));
+
+      if(rnd() & 1)
+        p[i] = rnd() | 0x1001; /* random odd int */
+      else
+        p[i] = (mps_word_t)refs[rnd() % nr_refs]; /* random ptr */
+    }
+  }
+}
+
+/* test -- the actual stress test */
+
+static void *test(void *arg, size_t haveAmbigous)
+{
+  mps_pool_t pool;
+  mps_root_t exactRoot, ambigRoot;
+  size_t lastStep = 0, i, r;
+  unsigned long objs;
+  mps_ap_t busy_ap;
+  mps_addr_t busy_init;
+
+  pool = (mps_pool_t)arg;
+
+  die(mps_ap_create(&busy_ap, pool, MPS_RANK_AMBIG), "BufferCreate 2");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  if (haveAmbigous)
+    for(i = 0; i < ambigRootsCOUNT; ++i)
+      ambigRoots[i] = (mps_addr_t) ((mps_word_t)rnd_addr());
+
+  die(mps_root_create_table(&exactRoot, mercury_mps_arena,
+                                   MPS_RANK_AMBIG, (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT),
+      "root_create_table(exact)");
+  if (haveAmbigous)
+    die(mps_root_create_table(&ambigRoot, mercury_mps_arena,
+                              MPS_RANK_AMBIG, (mps_rm_t)0,
+                              &ambigRoots[0], ambigRootsCOUNT),
+        "root_create_table(ambig)");
+
+  /* create an ap, and leave it busy */
+  die(mps_reserve(&busy_init, busy_ap, 64), "mps_reserve busy");
+
+  objs = 0; totalSize = 0;
+  while(totalSize < totalSizeMAX) {
+    if (totalSize > lastStep + totalSizeSTEP) {
+      lastStep = totalSize;
+      printf("\nSize %lu bytes, %lu objects.\n",
+             (unsigned long)totalSize, objs);
+      fflush(stdout);
+#if 0
+      for(i = 0; i < exactRootsCOUNT; ++i)
+        cdie(exactRoots[i] == objNULL || mercury_check(exactRoots[i]),
+             "all roots check");
+#endif
+    }
+
+    r = (size_t)rnd();
+    if (!haveAmbigous || (r & 1)) {
+      i = (r >> 1) % exactRootsCOUNT;
+#if 0
+      if (exactRoots[i] != objNULL)
+        cdie(mercury_check(exactRoots[i]), "dying root check");
+#endif
+      exactRoots[i] = make();
+#if 1
+      if (exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+        mercury_write(exactRoots[(exactRootsCOUNT-1) - i],
+                    exactRoots, exactRootsCOUNT);
+#endif
+    } else {
+      i = (r >> 1) % ambigRootsCOUNT;
+      ambigRoots[(ambigRootsCOUNT-1) - i] = make();
+      /* Create random interior pointers */
+      ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 5);
+    }
+
+    if (rnd() % initTestFREQ == 0)
+      *(int*)busy_init = -1; /* check that the buffer is still there */
+
+    if (rnd() % splatTestFREQ == 0)
+      mps_pool_check_free_space(pool);
+
+    ++objs;
+    if (objs % 256 == 0) {
+      printf(".");
+      fflush(stdout);
+    }
+  }
+
+  (void)mps_commit(busy_ap, busy_init, 64);
+  mps_ap_destroy(busy_ap);
+  mps_root_destroy(exactRoot);
+  if (haveAmbigous)
+    mps_root_destroy(ambigRoot);
+
+  return NULL;
+}
+
+int main(int argc, char **argv)
+{
+  void *r;
+
+  randomize(argc, argv);
+
+  GC_stackbottom = &argc;
+
+  printf("\nAMS Debug\n");
+  mercury_mps_init(testArenaSIZE, TRUE);
+  mps_tramp(&r, test, mercury_mps_pool, 1);
+  mercury_mps_finish();
+
+  printf("\nAMS\n");
+  mercury_mps_init(testArenaSIZE, FALSE);
+  mps_tramp(&r, test, mercury_mps_pool, 1);
+  mercury_mps_finish();
+
+  fflush(stdout); /* synchronize */
+  fprintf(stderr, "\nConclusion:  Failed to find any defects.\n");
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2002 Ravenbrook Limited <http://www.ravenbrook.com/>.
+ * All rights reserved.  This is an open source license.  Contact
+ * Ravenbrook for commercial licensing options.
+ * 
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ * 
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 
+ * 3. Redistributions in any form must be accompanied by information on how
+ * to obtain complete source code for this software and any accompanying
+ * software that uses this software.  The source code must either be
+ * included in the distribution or be available for no more than the cost
+ * of distribution plus a nominal fee, and must be freely redistributable
+ * under reasonable conditions.  For an executable file, complete source
+ * code means the source code for all modules it contains. It does not
+ * include source code for modules or files that typically accompany the
+ * major components of the operating system on which the executable file
+ * runs.
+ * 
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+ * PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+ * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */

diff -u mps-kit-1.100.1/code/comm.gmk mps_gc/code/comm.gmk
--- mps-kit-1.100.1/code/comm.gmk	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/comm.gmk	Tue Jul 30 21:12:02 2002
@@ -186,6 +186,7 @@
 FMTDY = fmtdy.c fmtno.c
 FMTDYTST = fmtdy.c fmtno.c fmtdytst.c
 FMTHETST = fmthe.c fmtdy.c fmtno.c fmtdytst.c
+MERCURYMPS = fmtme.c mercury_mps.c
 PLINTH = mpsliban.c mpsioan.c
 EVENTPROC = eventcnv.c eventpro.c table.c
 MPMCOMMON = mpsi.c mpm.c arenavm.c arenacl.c arena.c global.c locus.c \
@@ -256,6 +257,8 @@
 PLINTHDEP = $(PLINTH:%.c=$(PFM)/$(VARIETY)/%.d)
 EVENTPROCOBJ = $(EVENTPROC:%.c=$(PFM)/$(VARIETY)/%.o)
 EVENTPROCDEP = $(EVENTPROC:%.c=$(PFM)/$(VARIETY)/%.d)
+MERCURYMPSOBJ = $(MERCURYMPS:%.c=$(PFM)/$(VARIETY)/%.o)
+MERCURYMPSDEP = $(MERCURYMPS:%.c=$(PFM)/$(VARIETY)/%.d)
 endif
 
 
@@ -268,6 +271,7 @@
      mpsicv lockcov poolncv locv qs apss \
      finalcv arenacv bttest teletest \
      abqtest cbstest btcv mv2test messtest steptest \
+     mercury_mps_ss \
      eventcnv mps.a
 
 swall: mmsw.a replaysw
@@ -292,6 +296,7 @@
   abqtest cbstest btcv mv2test \
   messtest steptest \
   eventcnv replay replaysw \
+  mercury_mps_ss \
   mps.a mmsw.a mpsplan.a mmdw.a: phony
 ifdef VARIETY
 	$(MAKE) -f $(PFM).gmk TARGET=$@ variety
@@ -380,6 +385,9 @@
 $(PFM)/$(VARIETY)/amsss: $(PFM)/$(VARIETY)/amsss.o \
 	$(FMTDYTSTOBJ) $(MPMOBJ) $(AMSOBJ) $(TESTLIBOBJ)
 
+$(PFM)/$(VARIETY)/mercury_mps_ss: $(PFM)/$(VARIETY)/mercury_mps_ss.o \
+	$(MPMOBJ) $(AMSOBJ) $(TESTLIBOBJ) $(MERCURYMPSOBJ)
+
 $(PFM)/$(VARIETY)/amssshe: $(PFM)/$(VARIETY)/amssshe.o \
 	$(FMTHETSTOBJ) $(MPMOBJ) $(AMSOBJ) $(TESTLIBOBJ)
 
@@ -431,7 +439,8 @@
   $(PFM)/$(VARIETY)/eventpro.o $(PFM)/$(VARIETY)/table.o \
   $(MPMOBJ) $(AWLOBJ) $(AMSOBJ) $(POOLNOBJ) $(AMCOBJ) $(SNCOBJ) $(MVFFOBJ)
 
-$(PFM)/$(VARIETY)/mps.a: $(MPMOBJ) $(AMCOBJ) $(SNCOBJ) $(MVFFOBJ)
+$(PFM)/$(VARIETY)/mps.a: $(MPMOBJ) $(AMCOBJ) $(AMSOBJ) $(SNCOBJ) $(MVFFOBJ) \
+  $(MERCURYMPSOBJ)
 
 $(PFM)/$(VARIETY)/mmdw.a: $(MPMOBJ) $(AMCOBJ) $(LOOBJ) $(SNCOBJ) \
   $(FMTDYOBJ) $(AWLOBJ)
@@ -507,7 +516,7 @@
 # %%PART: Add the dependency file macro for the new part here.
 include $(MPMDEP) $(AMSDEP) $(AMCDEP) $(LODEP) $(SWDEP) \
   $(AWLDEP) $(POOLNDEP) $(TESTLIBDEP) $(FMTDYDEP) $(FMTHETSTDEP) \
-  $(PLINTHDEP) $(EVENTPROCDEP)
+  $(PLINTHDEP) $(EVENTPROCDEP) $(MERCURYMPSDEP)
 endif
 endif
 
diff -u mps-kit-1.100.1/code/config.h mps_gc/code/config.h
--- mps-kit-1.100.1/code/config.h	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/config.h	Wed Jul 31 09:13:13 2002
@@ -287,7 +287,9 @@
 #define MPS_PROD_STRING         "mps"
 #define MPS_PROD_MPS
 #define ARENA_INIT_SPARE_COMMIT_LIMIT   ((Size)10uL*1024uL*1024uL)
-#define THREAD_MULTI
+/* XXX changed to single-threaded version. -fjh */
+/* #define THREAD_MULTI */
+#define THREAD_SINGLE
 #define PROTECTION
 #define DONGLE_NONE
 #define PROD_CHECK_DEFAULT CheckSHALLOW
diff -u mps-kit-1.100.1/code/format.c mps_gc/code/format.c
--- mps-kit-1.100.1/code/format.c	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/format.c	Tue Jul 30 14:34:20 2002
@@ -23,7 +23,8 @@
   CHECKL(format->serial < format->arena->formatSerial);
   CHECKL(format->variety == FormatVarietyA
          || format->variety == FormatVarietyB
-         || format->variety == FormatVarietyAutoHeader);
+         || format->variety == FormatVarietyAutoHeader
+	 || format->variety == FormatVarietyMercury);
   CHECKL(RingCheck(&format->arenaRing));
   CHECKL(AlignCheck(format->alignment));
   /* @@@@ alignment should be less than maximum allowed */
@@ -91,7 +92,7 @@
     format->class = class;
   }
   if (headerSize != 0) {
-    AVER(variety == FormatVarietyAutoHeader);
+    AVER(variety == FormatVarietyAutoHeader || variety == FormatVarietyMercury);
     format->headerSize = headerSize;
   } else {
     format->headerSize = 0;
diff -u mps-kit-1.100.1/code/gc.gmk mps_gc/code/gc.gmk
--- mps-kit-1.100.1/code/gc.gmk	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/gc.gmk	Tue Jul 30 14:34:20 2002
@@ -9,7 +9,7 @@
 
 CC = gcc
 CFLAGSCOMPILER := \
-	-ansi -pedantic -Wall -Werror -Wpointer-arith \
+	-ansi -pedantic -Wall -Wpointer-arith \
 	-Wstrict-prototypes -Wmissing-prototypes \
 	-Winline -Waggregate-return -Wnested-externs \
 	-Wcast-qual -Wshadow
diff -u mps-kit-1.100.1/code/global.c mps_gc/code/global.c
--- mps-kit-1.100.1/code/global.c	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/global.c	Tue Jul 30 14:34:20 2002
@@ -715,7 +715,8 @@
   /* .read.conservative: @@@@ Should scan at rank phase-of-trace, */
   /* not RankEXACT which is conservative.  See also */
   /* <code/trace.c#scan.conservative> for a similar nasty. */
-  TraceScanSingleRef(arena->flippedTraces, RankEXACT, arena,
+  /* XXX changed from RankEXACT to RankAmbig. -fjh. */
+  TraceScanSingleRef(arena->flippedTraces, RankAMBIG, arena,
                      seg, (Ref *)addr);
   /* get the possibly fixed reference */
   return ArenaPeekSeg(arena, seg, addr);
diff -u mps-kit-1.100.1/code/lockli.c mps_gc/code/lockli.c
--- mps-kit-1.100.1/code/lockli.c	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/lockli.c	Wed Jul 31 09:18:27 2002
@@ -73,7 +73,7 @@
 
 /* LockSize -- size of a LockStruct */
 
-size_t LockSize(void)
+size_t (LockSize)(void)
 {
   return sizeof(LockStruct);
 }
@@ -81,7 +81,7 @@
 
 /* LockCheck -- check a lock */
 
-Bool LockCheck(Lock lock)
+Bool (LockCheck)(Lock lock)
 {
   CHECKS(Lock, lock);
   /* While claims can't be very large, I don't dare to put a limit on it. */
@@ -92,7 +92,7 @@
 
 /* LockInit -- initialize a lock */
 
-void LockInit(Lock lock)
+void (LockInit)(Lock lock)
 {
   pthread_mutexattr_t attr;
   int res;
@@ -114,7 +114,7 @@
 
 /* LockFinish -- finish a lock */
 
-void LockFinish(Lock lock)
+void (LockFinish)(Lock lock)
 {
   int res;
 
@@ -129,7 +129,7 @@
 
 /* LockClaim -- claim a lock (non-recursive) */
 
-void LockClaim(Lock lock)
+void (LockClaim)(Lock lock)
 {
   int res;
 
@@ -148,7 +148,7 @@
 
 /* LockReleaseMPM -- release a lock (non-recursive) */
 
-void LockReleaseMPM(Lock lock)
+void (LockReleaseMPM)(Lock lock)
 {
   int res;
 
@@ -163,7 +163,7 @@
 
 /* LockClaimRecursive -- claim a lock (recursive) */
 
-void LockClaimRecursive(Lock lock)
+void (LockClaimRecursive)(Lock lock)
 {
   int res;
 
@@ -183,7 +183,7 @@
 
 /* LockReleaseRecursive -- release a lock (recursive) */
 
-void LockReleaseRecursive(Lock lock)
+void (LockReleaseRecursive)(Lock lock)
 {
   int res;
 
@@ -218,7 +218,7 @@
 
 /* LockClaimGlobalRecursive -- claim the global recursive lock */
 
-void LockClaimGlobalRecursive(void)
+void (LockClaimGlobalRecursive)(void)
 {
   int res;
 
@@ -231,7 +231,7 @@
 
 /* LockReleaseGlobalRecursive -- release the global recursive lock */
 
-void LockReleaseGlobalRecursive(void)
+void (LockReleaseGlobalRecursive)(void)
 {
   LockReleaseRecursive(globalRecLock);
 }
@@ -239,7 +239,7 @@
 
 /* LockClaimGlobal -- claim the global non-recursive lock */
 
-void LockClaimGlobal(void)
+void (LockClaimGlobal)(void)
 {
   int res;
 
@@ -252,7 +252,7 @@
 
 /* LockReleaseGlobal -- release the global non-recursive lock */
 
-void LockReleaseGlobal(void)
+void (LockReleaseGlobal)(void)
 {
   LockReleaseMPM(globalLock);
 }
diff -u mps-kit-1.100.1/code/mpmtypes.h mps_gc/code/mpmtypes.h
--- mps-kit-1.100.1/code/mpmtypes.h	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/mpmtypes.h	Tue Jul 30 14:34:20 2002
@@ -304,6 +304,7 @@
   FormatVarietyB,
   FormatVarietyAutoHeader,
   FormatVarietyFixed,
+  FormatVarietyMercury,
   FormatVarietyLIMIT
 };
 
diff -u mps-kit-1.100.1/code/mps.h mps_gc/code/mps.h
--- mps-kit-1.100.1/code/mps.h	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/mps.h	Tue Jul 30 14:34:20 2002
@@ -220,6 +220,14 @@
   mps_fmt_pad_t   pad;
 } mps_fmt_fixed_s;
 
+typedef struct mps_fmt_mercury_s {
+  mps_align_t     align;
+  mps_fmt_scan_t  scan;
+  mps_fmt_skip_t  skip;
+  mps_fmt_copy_t  copy;
+  mps_fmt_pad_t   pad;
+} mps_fmt_mercury_s;
+
 
 /* Internal Definitions */
 
@@ -282,6 +290,8 @@
                                             mps_fmt_auto_header_s *);
 extern mps_res_t mps_fmt_create_fixed(mps_fmt_t *, mps_arena_t,
                                       mps_fmt_fixed_s *);
+extern mps_res_t mps_fmt_create_mercury(mps_fmt_t *, mps_arena_t,
+                                      mps_fmt_mercury_s *);
 extern void mps_fmt_destroy(mps_fmt_t);
 
 
diff -u mps-kit-1.100.1/code/mpsi.c mps_gc/code/mpsi.c
--- mps-kit-1.100.1/code/mpsi.c	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/mpsi.c	Tue Jul 30 14:34:20 2002
@@ -52,9 +52,12 @@
 #include "mpsavm.h" /* only for mps_space_create */
 #include "sac.h"
 #include "chain.h"
+#include <assert.h>
 
 SRCID(mpsi, "$Id: //info.ravenbrook.com/project/mps/version/1.100/code/mpsi.c#1 $");
 
+#define notreached()    assert(0)
+#define unused(param)   ((void)param)
 
 /* mpsi_check -- check consistency of interface mappings
  *
@@ -590,6 +593,55 @@
   *mps_fmt_o = (mps_fmt_t)format;
   return MPS_RES_OK;
 }
+
+static void mercury_no_fwd(mps_addr_t old,
+            mps_addr_t new)
+{
+    unused(old); unused(new);
+    notreached();
+}
+
+static mps_addr_t mercury_no_isfwd(mps_addr_t object)
+{
+    unused(object);
+    notreached();
+    return 0;
+}
+
+/* mps_fmt_create_mercury -- create an object format of variant Mercury */
+
+mps_res_t mps_fmt_create_mercury(mps_fmt_t *mps_fmt_o,
+                           mps_arena_t mps_arena,
+                           mps_fmt_mercury_s *mps_fmt_mercury)
+{
+  Arena arena = (Arena)mps_arena;
+  Format format;
+  Res res;
+
+  ArenaEnter(arena);
+
+  AVER(mps_fmt_mercury != NULL);
+
+  res = FormatCreate(&format,
+                     arena,
+                     (Align)mps_fmt_mercury->align,
+                     FormatVarietyMercury,
+                     (FormatScanMethod)mps_fmt_mercury->scan,
+                     (FormatSkipMethod)mps_fmt_mercury->skip,
+		     (FormatMoveMethod)mercury_no_fwd,
+                     (FormatIsMovedMethod)mercury_no_isfwd,
+                     (FormatCopyMethod)mps_fmt_mercury->copy,
+                     (FormatPadMethod)mps_fmt_mercury->pad,
+		     NULL, /* class */
+                     (Size)sizeof(mps_word_t));
+
+  ArenaLeave(arena);
+
+  if (res != ResOK) return res;
+  *mps_fmt_o = (mps_fmt_t)format;
+  return MPS_RES_OK;
+}
+
 
 
 /* mps_fmt_destroy -- destroy a format object */
diff -u mps-kit-1.100.1/code/poolams.c mps_gc/code/poolams.c
--- mps-kit-1.100.1/code/poolams.c	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/poolams.c	Tue Jul 30 14:35:43 2002
@@ -1403,17 +1403,24 @@
       /* In this state, the pool doesn't support ambiguous references (see */
       /* .ambiguous.noshare), so this is not a reference. */
       break;
-    /* not a real pointer if not aligned or not allocated */
-    if (!AddrIsAligned(base, PoolAlignment(pool))
-       || !AMS_ALLOCED(seg, i)) {
+#if 0 /* Note: this test disabled for Mercury,
+             since we need to handle tagged pointers. -fjh */
+    /* not a real pointer if not aligned */
+    if (!AddrIsAligned(base, PoolAlignment(pool)))
+      break;
+#endif
+    /* not a real pointer if not allocated */
+    if (!AMS_ALLOCED(seg, i))
       break;
-    }
     amsseg->ambiguousFixes = TRUE;
     /* falls through */
   case RankEXACT:
   case RankFINAL:
   case RankWEAK:
+#if 0 /* Note: this test disabled for Mercury,
+               since we need to handle tagged pointers. -fjh */
     AVER_CRITICAL(AddrIsAligned(base, PoolAlignment(pool)));
+#endif
     AVER_CRITICAL(AMS_ALLOCED(seg, i));
     if (AMS_IS_WHITE(seg, i)) {
       ss->wasMarked = FALSE;
Common subdirectories: mps-kit-1.100.1/code/s7ppac and mps_gc/code/s7ppac
diff -u mps-kit-1.100.1/code/trace.c mps_gc/code/trace.c
--- mps-kit-1.100.1/code/trace.c	Fri Jun 21 02:16:18 2002
+++ mps_gc/code/trace.c	Tue Jul 30 14:34:20 2002
@@ -1022,7 +1022,8 @@
     /* .scan.conservative: At the moment we scan at RankEXACT.  Really */
     /* we should be scanning at the "phase" of the trace, which is the */
     /* minimum rank of all grey segments. (see request.mps.170160) */
-    traceScanSeg(traces, RankEXACT, arena, seg);
+    /* XXX changed from RankEXACT to RankAMBIG. -fjh. */
+    traceScanSeg(traces, RankAMBIG, arena, seg);
 
     /* The pool should've done the job of removing the greyness that */
     /* was causing the segment to be protected, so that the mutator */

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
The University of Melbourne         |  of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh>  |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------