7 files changed, 631 insertions, 32 deletions

diff --git a/mps/code/awluthe.c b/mps/code/awluthe.c
new file mode 100644
index 00000000000..cb3fe99f343
--- /dev/null
+++ b/mps/code/awluthe.c
@@ -0,0 +1,326 @@
+/* impl.c.awluthe: POOL CLASS AWL UNIT TEST WITH OBJECT HEADERS
+ *
+ * $Id$
+ * Copyright (c) 2001 Ravenbrook Limited.
+ *
+ * DESIGN
+ *
+ * .design: see design.mps.poolawl.test.*
+ */
+
+#include "mpscawl.h"
+#include "mpsclo.h"
+#include "mpsavm.h"
+#include "fmthe.h"
+#include "testlib.h"
+#include "mps.h"
+#include "mpstd.h"
+#ifdef MPS_OS_W3
+#include "mpsw3.h"
+#endif
+#include <string.h>
+
+
+#define testArenaSIZE     ((size_t)64<<20)
+#define TABLE_SLOTS 49
+#define ITERATIONS 5000
+#define CHATTER 100
+
+
+static mps_word_t bogus_class;
+
+#define UNINIT 0x041412ED
+
+#define DYLAN_ALIGN 4 /* depends on value defined in fmtdy.c */
+
+
+/* size_tAlignUp -- align w up to alignment a */
+
+#define size_tAlignUp(w, a) (((w) + (a) - 1) & ~((size_t)(a) - 1))
+
+
+static mps_word_t wrapper_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* Extra word */
+  4uL<<2|2,                     /* F */
+  2uL<<(MPS_WORD_WIDTH - 8),    /* V */
+  1uL<<2|1,                     /* VL */
+  1                             /* patterns */
+};
+
+
+static mps_word_t string_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  0,                            /* F */
+  2uL<<(MPS_WORD_WIDTH - 8)|3uL<<3|4,   /* V */
+  1                             /* VL */
+};
+
+static mps_word_t table_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  1uL<<2|1,                     /* F */
+  2uL<<(MPS_WORD_WIDTH - 8)|2,  /* V */
+  1                             /* VL */
+};
+
+
+static void initialise_wrapper(mps_word_t *wrapper)
+{
+  wrapper[0] = (mps_word_t)&wrapper_wrapper;
+  wrapper[1] = (mps_word_t)&bogus_class;
+}
+
+
+/* alloc_string  - create a dylan string object
+ *
+ * create a dylan string object (byte vector) whose contents
+ * are the string s (including the terminating NUL)
+ * .assume.dylan-obj
+ */
+
+static mps_word_t *alloc_string(char *s, mps_ap_t ap)
+{
+  size_t l;
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  l = strlen(s)+1;
+  /* number of words * sizeof word */
+  objsize = (2 + (l+sizeof(mps_word_t)-1)/sizeof(mps_word_t))
+            * sizeof(mps_word_t);
+  objsize = size_tAlignUp(objsize, DYLAN_ALIGN);
+  do {
+    size_t i;
+    char *s2;
+
+    die(mps_reserve(&p, ap, objsize + headerSIZE), "Reserve Leaf\n");
+    object = (mps_word_t *)((char *)p + headerSIZE);
+    object[0] = (mps_word_t)string_wrapper;
+    object[1] = l << 2 | 1;
+    s2 = (char *)&object[2];
+    for(i = 0; i < l; ++i) {
+      s2[i] = s[i];
+    }
+    ((int*)p)[0] = realHeader;
+    ((int*)p)[1] = 0xED0ED;
+  } while(!mps_commit(ap, p, objsize + headerSIZE));
+  return object;
+}
+
+
+/* alloc_table -- create a table with n variable slots
+ *
+ * .assume.dylan-obj
+ */
+
+static mps_word_t *alloc_table(unsigned long n, mps_ap_t ap)
+{
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  objsize = (3 + n) * sizeof(mps_word_t);
+  objsize = size_tAlignUp(objsize, MPS_PF_ALIGN);
+  do {
+    unsigned long i;
+
+    die(mps_reserve(&p, ap, objsize + headerSIZE), "Reserve Table\n");
+    object = (mps_word_t *)((char *)p + headerSIZE);
+    object[0] = (mps_word_t)table_wrapper;
+    object[1] = 0;
+    object[2] = n << 2 | 1;
+    for(i = 0; i < n; ++i) {
+      object[3+i] = 0;
+    }
+    ((int*)p)[0] = realHeader;
+    ((int*)p)[1] = 0xED0ED;
+  } while(!mps_commit(ap, p, objsize + headerSIZE));
+  return object;
+}
+
+
+/* gets the nth slot from a table
+ * .assume.dylan-obj
+ */
+static mps_word_t *table_slot(mps_word_t *table, unsigned long n)
+{
+  return (mps_word_t *)table[3+n];
+}
+
+
+/* sets the nth slot in a table
+ * .assume.dylan-obj
+ */
+static void set_table_slot(mps_word_t *table,
+                           unsigned long n, mps_word_t *p)
+{
+  cdie(table[0] == (mps_word_t)table_wrapper, "set_table_slot");
+  table[3+n] = (mps_word_t)p;
+}
+
+
+/* links two tables together via their link slot
+ * (1st fixed part slot)
+ */
+static void table_link(mps_word_t *t1, mps_word_t *t2)
+{
+  cdie(t1[0] == (mps_word_t)table_wrapper, "table_link 1");
+  cdie(t2[0] == (mps_word_t)table_wrapper, "table_link 2");
+  t1[1] = (mps_word_t)t2;
+  t2[1] = (mps_word_t)t1;
+}
+
+
+static void test(mps_ap_t leafap, mps_ap_t exactap, mps_ap_t weakap,
+                 mps_ap_t bogusap)
+{
+  mps_word_t *weaktable;
+  mps_word_t *exacttable;
+  mps_word_t *preserve[TABLE_SLOTS];    /* preserves objects in the weak */
+                                        /* table by referring to them */
+  unsigned long i, j;
+  void *p;
+
+  exacttable = alloc_table(TABLE_SLOTS, exactap);
+  weaktable = alloc_table(TABLE_SLOTS, weakap);
+  table_link(exacttable, weaktable);
+
+  /* Leave bogusap between reserve and commit for the duration */
+  die(mps_reserve(&p, bogusap, 64), "Reserve bogus");
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    mps_word_t *string;
+    if (rnd() % 2 == 0) {
+      string = alloc_string("iamalive", leafap);
+      preserve[i] = string;
+    } else {
+      string = alloc_string("iamdead", leafap);
+      preserve[i] = 0;
+    }
+    set_table_slot(weaktable, i, string);
+    string = alloc_string("iamexact", leafap);
+    set_table_slot(exacttable, i, string);
+  }
+
+  for(j = 0; j < ITERATIONS; ++j) {
+    for(i = 0; i < TABLE_SLOTS; ++i) {
+      mps_word_t *string;
+
+      string = alloc_string("spong", leafap);
+    }
+  }
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    if (preserve[i] == 0) {
+      if (table_slot(weaktable, i)) {
+        error("Strongly unreachable weak table entry found, slot %lu.\n", i);
+      } else {
+        if (table_slot(exacttable, i) != 0) {
+          error("Weak table entry deleted, but corresponding "
+                "exact table entry not deleted, slot %lu.\n", i);
+        }
+      }
+    }
+  }
+
+  (void)mps_commit(bogusap, p, 64);
+}
+
+
+/* setup -- set up pools for the test
+ *
+ * v serves two purposes:
+ *  - a pseudo stack base for the stack root.
+ *  - pointer to a guff structure, which packages some values needed
+ *   (arena and thr mostly)
+ */
+
+struct guff_s {
+  mps_arena_t arena;
+  mps_thr_t thr;
+};
+
+static void *setup(void *v, size_t s)
+{
+  struct guff_s *guff;
+  mps_arena_t arena;
+  mps_pool_t leafpool;
+  mps_pool_t tablepool;
+  mps_fmt_t dylanfmt;
+  mps_fmt_t dylanweakfmt;
+  mps_ap_t leafap, exactap, weakap, bogusap;
+  mps_root_t stack;
+  mps_thr_t thr;
+
+  guff = (struct guff_s *)v;
+  (void)s;
+  arena = guff->arena;
+  thr = guff->thr;
+
+  die(mps_root_create_reg(&stack, arena, MPS_RANK_AMBIG, 0, thr,
+                          mps_stack_scan_ambig, v, 0),
+      "Root Create\n");
+  EnsureHeaderFormat(&dylanfmt, arena);
+  EnsureHeaderWeakFormat(&dylanweakfmt, arena);
+  die(mps_pool_create(&leafpool, arena, mps_class_lo(), dylanfmt),
+      "Leaf Pool Create\n");
+  die(mps_pool_create(&tablepool, arena, mps_class_awl(), dylanweakfmt,
+                      dylan_weak_dependent),
+      "Table Pool Create\n");
+  die(mps_ap_create(&leafap, leafpool, MPS_RANK_EXACT),
+      "Leaf AP Create\n");
+  die(mps_ap_create(&exactap, tablepool, MPS_RANK_EXACT),
+      "Exact AP Create\n");
+  die(mps_ap_create(&weakap, tablepool, MPS_RANK_WEAK),
+      "Weak AP Create\n");
+  die(mps_ap_create(&bogusap, tablepool, MPS_RANK_EXACT),
+      "Bogus AP Create\n");
+
+  test(leafap, exactap, weakap, bogusap);
+
+  mps_ap_destroy(bogusap);
+  mps_ap_destroy(weakap);
+  mps_ap_destroy(exactap);
+  mps_ap_destroy(leafap);
+  mps_pool_destroy(tablepool);
+  mps_pool_destroy(leafpool);
+  mps_fmt_destroy(dylanweakfmt);
+  mps_fmt_destroy(dylanfmt);
+  mps_root_destroy(stack);
+
+  return NULL;
+}
+
+
+int main(int argc, char **argv)
+{
+  struct guff_s guff;
+  mps_arena_t arena;
+  mps_thr_t thread;
+  void *r;
+
+  randomize(argc, argv);
+
+  initialise_wrapper(wrapper_wrapper);
+  initialise_wrapper(string_wrapper);
+  initialise_wrapper(table_wrapper);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "arena_create\n");
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  guff.arena = arena;
+  guff.thr = thread;
+  mps_tramp(&r, setup, &guff, 0);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  fflush(stdout); /* synchronize */
+  fprintf(stderr, "\nConclusion:  Failed to find any defects.\n");
+  return 0;
+}
diff --git a/mps/code/comm.gmk b/mps/code/comm.gmk
index aafb2134680..8e3172f7c77 100644
--- a/mps/code/comm.gmk
+++ b/mps/code/comm.gmk
@@ -277,7 +277,7 @@ endif
 # %%TARGET: Add the target to the all dependencies, if it uses the
 # CONFIG_PROD_MPS configuration, to swall if CONFIG_PROD_EPCORE
 
-all: mpmss sacss amcss amcsshe amsss segsmss awlut \
+all: mpmss sacss amcss amcsshe amsss segsmss awlut awluthe \
      mpsicv lockcov poolncv locv qs apss \
      finalcv arenacv bttest teletest \
      abqtest cbstest btcv mv2test messtest \
@@ -289,8 +289,9 @@ swall: mmsw.a epvmss replaysw epdss
 # These tests are run overnight (see design.buildsys.overnight).
 #   bttest & teletest cannot be run unattended
 #   mv2test cannot be run because MV2 is broken
-testrun: mpmss apss sacss amcss amcsshe amsss segsmss awlut mpsicv lockcov \
-         poolncv locv qs finalcv arenacv abqtest cbstest btcv messtest
+testrun: mpmss apss sacss amcss amcsshe amsss segsmss awlut awluthe \
+         mpsicv lockcov poolncv locv qs finalcv arenacv \
+         abqtest cbstest btcv messtest
         $(^:%=date && $(PFM)/$(VARIETY)/% &&) true
 
 # Runs the automatic tests that are built with CONFIG_PROD_EPCORE
@@ -304,7 +305,7 @@ testrunep: epvmss epdss
 # %%TARGET: Add a pseudo-target for the new target here.
 
 mpmss sacss amcss amcssth amcsshe amsss segsmss awlut awlutth \
-  mpsicv lockcov poolncv locv qs apss \
+  awluthe mpsicv lockcov poolncv locv qs apss \
   finalcv arenacv bttest teletest epvmss epdss \
   abqtest cbstest btcv mv2test \
   messtest \
@@ -409,6 +410,9 @@ $(PFM)/$(VARIETY)/epdss: $(PFM)/$(VARIETY)/epdss.o \
 $(PFM)/$(VARIETY)/awlut: $(PFM)/$(VARIETY)/awlut.o \
         $(FMTDYTSTOBJ) $(MPMOBJ) $(LOOBJ) $(AWLOBJ) $(TESTLIBOBJ)
 
+$(PFM)/$(VARIETY)/awluthe: $(PFM)/$(VARIETY)/awluthe.o \
+        $(PFM)/$(VARIETY)/fmthe.o $(MPMOBJ) $(LOOBJ) $(AWLOBJ) $(TESTLIBOBJ)
+
 $(PFM)/$(VARIETY)/awlutth: $(PFM)/$(VARIETY)/awlutth.o \
         $(FMTDYTSTOBJ) $(MPMOBJ) $(LOOBJ) $(AWLOBJ) $(TESTLIBOBJ)
 
diff --git a/mps/code/fmthe.c b/mps/code/fmthe.c
index 9657c056a80..ffd9a29a4c7 100644
--- a/mps/code/fmthe.c
+++ b/mps/code/fmthe.c
@@ -159,7 +159,7 @@ static int dylan_wrapper_check(mps_word_t *w)
   /* size.  This assumes that DylanWorks is only going to use byte */
   /* vectors in the non-word case. */
 
-  /* Variable part format 6 is reserved. */ 
+  /* Variable part format 6 is reserved. */
   assert(vf != 6);
 
   /* There should be no shift in word vector formats. */
@@ -216,6 +216,79 @@ static mps_res_t dylan_scan_contig(mps_ss_t mps_ss,
   return MPS_RES_OK;
 }
 
+/* dylan_weak_dependent -- returns the linked object, if any.
+ */
+
+extern mps_addr_t dylan_weak_dependent(mps_addr_t parent)
+{
+  mps_word_t *object;
+  mps_word_t *wrapper;
+  mps_word_t fword;
+  mps_word_t fl;
+  mps_word_t ff;
+
+  assert(parent != NULL);
+  object = (mps_word_t *)parent;
+  wrapper = (mps_word_t *)object[0];
+  assert(dylan_wrapper_check(wrapper));
+  fword = wrapper[3];
+  ff = fword & 3;
+  /* traceable fixed part */
+  assert(ff == 1);
+  fl = fword & ~3uL;
+  /* at least one fixed field */
+  assert(fl >= 1);
+  return (mps_addr_t) object[1];
+}
+
+
+/* Scan weakly a contiguous array of references in [base, limit). */
+/* Only required to scan vectors for Dylan Weak Tables. */
+/* Depends on the vector length field being scannable (ie a tagged */
+/* integer). */
+/* When a reference that has been fixed to NULL is detected the */
+/* corresponding reference in the associated table (pointed to be the */
+/* assoc variable) will be deleted. */
+
+static mps_res_t
+dylan_scan_contig_weak(mps_ss_t mps_ss,
+                       mps_addr_t *base, mps_addr_t *limit,
+                       mps_addr_t *objectBase, mps_addr_t *assoc)
+{
+  mps_addr_t *p;
+  mps_res_t res;
+  mps_addr_t r;
+
+  MPS_SCAN_BEGIN(mps_ss) {
+    p = base;
+    goto skip_inc;
+  loop:
+    ++p;
+  skip_inc:
+    if(p >= limit)
+      goto out;
+    r = *p;
+    if(((mps_word_t)r & 3) != 0) /* non-pointer */
+      goto loop;
+    if(!MPS_FIX1(mps_ss, r))
+      goto loop;
+    res = MPS_FIX2(mps_ss, p);
+    if(res == MPS_RES_OK) {
+      if(*p == 0 && r != 0) {
+        if(assoc != NULL) {
+          assoc[p-objectBase] = 0;      /* delete corresponding entry */
+        }
+      }
+      goto loop;
+    }
+    return res;
+  out:
+    assert(p == limit);
+  } MPS_SCAN_END(mps_ss);
+
+  return MPS_RES_OK;
+}
+
 
 /* dylan_scan_pat -- scan according to pattern
  *
@@ -450,6 +523,97 @@ static mps_res_t dylan_scan(mps_ss_t mps_ss,
 }
 
 
+static mps_res_t dylan_scan1_weak(mps_ss_t mps_ss, mps_addr_t *object_io)
+{
+  mps_addr_t *assoc;
+  mps_addr_t *base;
+  mps_addr_t *p, q;
+  mps_res_t res;
+  mps_word_t *w;
+  mps_word_t fword, ff, fl;
+  mps_word_t h;
+  mps_word_t vword, vf, vl;
+  int header;
+
+  assert(object_io != NULL);
+  base = (mps_addr_t *)*object_io;
+  assert(base != NULL);
+  p = base;
+
+  header = *(int*)((char*)p - headerSIZE);
+  switch(headerType(header)) {
+  case realTYPE:
+      break;
+  case padTYPE:
+      *object_io = (mps_addr_t)((char*)p + headerPadSize(header));
+      return MPS_RES_OK;
+  default:
+      notreached();
+      break;
+  }
+
+  h = (mps_word_t)p[0];
+  /* object should not be forwarded (as there is no forwarding method) */
+  assert((h & 3) == 0);
+
+  mps_fix(mps_ss, p);
+
+  /* w points to wrapper */
+  w = (mps_word_t *)p[0];
+
+  assert(dylan_wrapper_check(w));
+
+  ++p;                  /* skip header */
+
+  fword = w[WF];
+  fl = fword >> 2;
+  /* weak vectors should have at least one fixed field */
+  /* (for assoc field) */
+  assert(fl >= 1);
+
+  ff = fword & 3;
+
+  /* weak vectors should have traceable fixed format */
+  assert(ff == 1);
+
+  assoc = (mps_addr_t *)p[0];
+
+  vword = w[WV];
+  vf = vword & 7;
+  vl = (mps_word_t)p[fl] >> 2;
+
+  /* weak vectors should be non-stretchy traceable */
+  assert(vf == 2);
+
+  /* q is end of the object.  There are fl fixed fields, vl variable */
+  /* fields and another slot that contains the vector length */
+  q = p + fl + vl + 1;
+
+  res = dylan_scan_contig_weak(mps_ss, p, q, base, assoc);
+  if(res != MPS_RES_OK) {
+    return res;
+  }
+
+  *object_io = AddHeader(q);
+  return MPS_RES_OK;
+}
+
+
+static mps_res_t dylan_scan_weak(mps_ss_t mps_ss,
+                                 mps_addr_t base, mps_addr_t limit)
+{
+  mps_res_t res;
+
+  while(base < limit) {
+    res = dylan_scan1_weak(mps_ss, &base);
+    if(res) return res;
+  }
+
+  assert(base <= AddHeader(limit));
+
+  return MPS_RES_OK;
+}
+
 static mps_addr_t dylan_skip(mps_addr_t object)
 {
   mps_addr_t *p;        /* cursor in object */
@@ -563,6 +727,25 @@ static void dylan_pad(mps_addr_t addr, size_t fullSize)
 }
 
 
+static mps_addr_t dylan_no_isfwd(mps_addr_t object)
+{
+  unused(object);
+  notreached();
+  return 0;
+}
+
+static void dylan_no_fwd(mps_addr_t old, mps_addr_t new)
+{
+  unused(old); unused(new);
+  notreached();
+}
+
+static void dylan_no_pad(mps_addr_t addr, size_t size)
+{
+  unused(addr); unused(size);
+  notreached();
+}
+
 /* HeaderFormat -- format descriptor for this format */
 
 static struct mps_fmt_auto_header_s HeaderFormat =
@@ -577,6 +760,20 @@ static struct mps_fmt_auto_header_s HeaderFormat =
 };
 
 
+/* HeaderWeakFormat -- format descriptor for this format */
+
+static struct mps_fmt_auto_header_s HeaderWeakFormat =
+{
+  ALIGN,
+  dylan_scan_weak,
+  dylan_skip,
+  dylan_no_fwd,
+  dylan_no_isfwd,
+  dylan_no_pad,
+  (size_t)headerSIZE
+};
+
+
 /* EnsureHeaderFormat -- create a format object for this format */
 
 mps_res_t EnsureHeaderFormat(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
@@ -585,6 +782,14 @@ mps_res_t EnsureHeaderFormat(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
 }
 
 
+/* EnsureHeaderWeakFormat -- create a format object for the weak format */
+
+mps_res_t EnsureHeaderWeakFormat(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
+{
+  return mps_fmt_create_auto_header(mps_fmt_o, arena, &HeaderWeakFormat);
+}
+
+
 /* HeaderFormatCheck -- check an object in this format */
 
 mps_res_t HeaderFormatCheck(mps_addr_t addr)
@@ -595,3 +800,14 @@ mps_res_t HeaderFormatCheck(mps_addr_t addr)
   else
     return MPS_RES_FAIL;
 }
+
+/* HeaderWeakFormatCheck -- check an object in this format */
+
+mps_res_t HeaderWeakFormatCheck(mps_addr_t addr)
+{
+  if (addr != 0 && ((mps_word_t)addr & (ALIGN-1)) == 0
+      && dylan_wrapper_check((mps_word_t *)((mps_word_t *)addr)[0]))
+    return MPS_RES_OK;
+  else
+    return MPS_RES_FAIL;
+}
diff --git a/mps/code/fmthe.h b/mps/code/fmthe.h
index 5d42ffbd15e..0445f34d098 100644
--- a/mps/code/fmthe.h
+++ b/mps/code/fmthe.h
@@ -10,10 +10,14 @@
 #include "mps.h"
 
 
-/* Format */
+/* Formats */
 extern mps_res_t EnsureHeaderFormat(mps_fmt_t *, mps_arena_t);
+extern mps_res_t EnsureHeaderWeakFormat(mps_fmt_t *, mps_arena_t);
 extern mps_res_t HeaderFormatCheck(mps_addr_t addr);
+extern mps_res_t HeaderWeakFormatCheck(mps_addr_t addr);
 
+/* dependent object function for weak pool */
+extern mps_addr_t dylan_weak_dependent(mps_addr_t);
 
 /* Constants describing wrappers. Used only for debugging / testing */
 #define WW 0    /* offset of Wrapper-Wrapper */
diff --git a/mps/code/fri4gc.gmk b/mps/code/fri4gc.gmk
index a6b2c9b8b6f..05e41e8de23 100644
--- a/mps/code/fri4gc.gmk
+++ b/mps/code/fri4gc.gmk
@@ -15,8 +15,8 @@ LIBS = -lm -pthread
 
 include gc.gmk
 
-CFLAGSDEBUG = -g -ggdb
-CFLAGSOPT = -O -g -ggdb
+CFLAGSDEBUG = -g
+CFLAGSOPT = -O -g
 
 CC = cc
 
diff --git a/mps/code/poolawl.c b/mps/code/poolawl.c
index ca7954c5791..d7f0992c40b 100644
--- a/mps/code/poolawl.c
+++ b/mps/code/poolawl.c
@@ -792,9 +792,10 @@ static void AWLBlacken(Pool pool, TraceSet traceSet, Seg seg)
 
 
 /* awlScanObject -- scan a single object */
+/* base and limit are both offset by the header size */
 
 static Res awlScanObject(Arena arena, AWL awl, ScanState ss,
-                         FormatScanMethod scan, Addr base, Addr limit)
+                         Format format, Addr base, Addr limit)
 {
   Res res;
   Bool dependent;       /* is there a dependent object? */
@@ -804,7 +805,7 @@ static Res awlScanObject(Arena arena, AWL awl, ScanState ss,
   AVERT(Arena, arena);
   AVERT(AWL, awl);
   AVERT(ScanState, ss);
-  AVER(FUNCHECK(scan));
+  AVERT(Format, format);
   AVER(base != 0);
   AVER(base < limit);
 
@@ -817,7 +818,7 @@ static Res awlScanObject(Arena arena, AWL awl, ScanState ss,
       SegSetSummary(dependentSeg, RefSetUNIV);
   }
 
-  res = (*scan)(ss, base, limit);
+  res = (*format->scan)(ss, base, limit);
   if (res == ResOK)
     ss->scannedSize += AddrOffset(base, limit);
 
@@ -836,10 +837,12 @@ static Res awlScanSinglePass(Bool *anyScannedReturn,
 {
   Addr base, limit, bufferScanLimit;
   Addr p;
+  Addr hp;
   Arena arena;
   AWL awl;
   AWLSeg awlseg;
   Buffer buffer;
+  Format format;
 
   AVERT(ScanState, ss);
   AVERT(Pool, pool);
@@ -851,6 +854,9 @@ static Res awlScanSinglePass(Bool *anyScannedReturn,
   arena = PoolArena(pool);
   AVERT(Arena, arena);
 
+  format = pool->format;
+  AVERT(Format, format);
+
   awlseg = Seg2AWLSeg(seg);
   AVERT(AWLSeg, awlseg);
   *anyScannedReturn = FALSE;
@@ -878,17 +884,19 @@ static Res awlScanSinglePass(Bool *anyScannedReturn,
       p = AddrAdd(p, pool->alignment);
       continue;
     }
-    objectLimit = (*pool->format->skip)(p);
+    hp = AddrAdd(p, format->headerSize);
+    objectLimit = (format->skip)(hp);
     /* design.mps.poolawl.fun.scan.pass.object */
     if (scanAllObjects
         || (BTGet(awlseg->mark, i) && !BTGet(awlseg->scanned, i))) {
-      Res res = awlScanObject(arena, awl, ss, pool->format->scan,
-                              p, objectLimit);
+      Res res = awlScanObject(arena, awl, ss, pool->format,
+                              hp, objectLimit);
       if (res != ResOK)
         return res;
       *anyScannedReturn = TRUE;
       BTSet(awlseg->scanned, i);
     }
+    objectLimit = AddrSub(objectLimit, format->headerSize);
     AVER(p < objectLimit);
     p = AddrAlignUp(objectLimit, pool->alignment);
   }
@@ -954,7 +962,8 @@ static Res AWLScan(Bool *totalReturn, ScanState ss, Pool pool, Seg seg)
 
 static Res AWLFix(Pool pool, ScanState ss, Seg seg, Ref *refIO)
 {
-  Ref ref;
+  Ref clientRef;
+  Addr base;
   Index i;
   AWL awl;
   AWLSeg awlseg;
@@ -970,15 +979,23 @@ static Res AWLFix(Pool pool, ScanState ss, Seg seg, Ref *refIO)
   awlseg  = Seg2AWLSeg(seg);
   AVERT(AWLSeg, awlseg);
 
-  ref = *refIO;
-  i = awlIndexOfAddr(SegBase(seg), awl, ref);
-
+  clientRef = *refIO;
   ss->wasMarked = TRUE;
 
+  base = AddrSub((Addr)clientRef, pool->format->headerSize);
+  /* can get an ambiguous reference to close to the base of the
+   * segment, so when we subtract the header we are not in the
+   * segment any longer.  This isn't a real reference,
+   * so we can just skip it.  */
+  if (base < SegBase(seg)) {
+    return ResOK;
+  }
+  i = awlIndexOfAddr(SegBase(seg), awl, base);
+
   switch(ss->rank) {
   case RankAMBIG:
     /* not a real pointer if not aligned or not allocated */
-    if (!AddrIsAligned((Addr)ref, pool->alignment) || !BTGet(awlseg->alloc, i))
+    if (!AddrIsAligned(base, pool->alignment) || !BTGet(awlseg->alloc, i))
       return ResOK;
     /* falls through */
   case RankEXACT:
@@ -1012,6 +1029,7 @@ static void AWLReclaim(Pool pool, Trace trace, Seg seg)
   AWLSeg awlseg;
   Index i;
   Count oldFree;
+  Format format;
   Count preservedInPlaceCount = (Count)0;
   Size preservedInPlaceSize = (Size)0;
   Size freed; /* amount reclaimed, in bytes */
@@ -1025,6 +1043,8 @@ static void AWLReclaim(Pool pool, Trace trace, Seg seg)
   awlseg = Seg2AWLSeg(seg);
   AVERT(AWLSeg, awlseg);
 
+  format = pool->format;
+
   base = SegBase(seg);
 
   i = 0; oldFree = awlseg->free;
@@ -1046,7 +1066,9 @@ static void AWLReclaim(Pool pool, Trace trace, Seg seg)
         continue;
       }
     }
-    q = AddrAlignUp(pool->format->skip(p), pool->alignment);
+    q = format->skip(AddrAdd(p, format->headerSize));
+    q = AddrSub(q, format->headerSize);
+    q = AddrAlignUp(q, pool->alignment);
     j = awlIndexOfAddr(base, awl, q);
     AVER(j <= awlseg->grains);
     if (BTGet(awlseg->mark, i)) {
@@ -1123,6 +1145,7 @@ static void AWLWalk(Pool pool, Seg seg, FormattedObjectsStepMethod f,
   AWL awl;
   AWLSeg awlseg;
   Addr object, base, limit;
+  Format format;
 
   AVERT(Pool, pool);
   AVERT(Seg, seg);
@@ -1134,6 +1157,8 @@ static void AWLWalk(Pool pool, Seg seg, FormattedObjectsStepMethod f,
   awlseg = Seg2AWLSeg(seg);
   AVERT(AWLSeg, awlseg);
 
+  format = pool->format;
+
   base = SegBase(seg);
   object = base;
   limit = SegLimit(seg);
@@ -1162,7 +1187,10 @@ static void AWLWalk(Pool pool, Seg seg, FormattedObjectsStepMethod f,
       object = AddrAdd(object, pool->alignment);
       continue;
     }
-    next = AddrAlignUp((*pool->format->skip)(object), pool->alignment);
+    object = AddrAdd(object, format->headerSize);
+    next = format->skip(object);
+    next = AddrSub(next, format->headerSize);
+    next = AddrAlignUp(next, pool->alignment);
     if (BTGet(awlseg->mark, i) && BTGet(awlseg->scanned, i))
       (*f)(object, pool->format, pool, p, s);
     object = next;
diff --git a/mps/code/poollo.c b/mps/code/poollo.c
index 02db2634d9c..779c9d3e7e9 100644
--- a/mps/code/poollo.c
+++ b/mps/code/poollo.c
@@ -329,6 +329,7 @@ static void loSegReclaim(LOSeg loseg, Trace trace)
   Count bytesReclaimed = (Count)0;
   Seg seg;
   LO lo;
+  Format format;
   Count preservedInPlaceCount = (Count)0;
   Size preservedInPlaceSize = (Size)0;
 
@@ -341,6 +342,9 @@ static void loSegReclaim(LOSeg loseg, Trace trace)
   limit = SegLimit(seg);
   marked = FALSE;
 
+  format = LOPool(lo)->format;
+  AVERT(Format, format);
+
   /* i is the index of the current pointer,
    * p is the actual address that is being considered.
    * j and q act similarly for a pointer which is used to
@@ -370,7 +374,8 @@ static void loSegReclaim(LOSeg loseg, Trace trace)
       p = AddrAdd(p, LOPool(lo)->alignment);
       continue;
     }
-    q = (*LOPool(lo)->format->skip)(p);
+    q = (*format->skip)(AddrAdd(p, format->headerSize));
+    q = AddrSub(q, format->headerSize);
     if(BTGet(loseg->mark, i)) {
       marked = TRUE;
       ++preservedInPlaceCount;
@@ -409,6 +414,7 @@ static void LOWalk(Pool pool, Seg seg,
   LO lo;
   LOSeg loseg;
   Index i, limit;
+  Format format;
 
   AVERT(Pool, pool);
   AVERT(Seg, seg);
@@ -420,6 +426,9 @@ static void LOWalk(Pool pool, Seg seg,
   loseg = SegLOSeg(seg);
   AVERT(LOSeg, loseg);
 
+  format = pool->format;
+  AVERT(Format, format);
+
   base = SegBase(seg);
   limit = SegSize(seg) >> lo->alignShift;
   i = 0;
@@ -449,7 +458,9 @@ static void LOWalk(Pool pool, Seg seg,
       ++i;
       continue;
     }
-    next = (*pool->format->skip)(object);
+    object = AddrAdd(object, format->headerSize);
+    next = (*format->skip)(object);
+    next = AddrSub(object, format->headerSize);
     j = loIndexOfAddr(base, lo, next);
     AVER(i < j);
     (*f)(object, pool->format, pool, p, s);
@@ -474,9 +485,9 @@ static Res LOInit(Pool pool, va_list arg)
 
   format = va_arg(arg, Format);
   AVERT(Format, format);
- 
+
   lo = PoolPoolLO(pool);
- 
+
   pool->format = format;
   lo->poolStruct.alignment = format->alignment;
   lo->alignShift =
@@ -508,7 +519,7 @@ static void LOFinish(Pool pool)
 {
   LO lo;
   Ring node, nextNode;
- 
+
   AVERT(Pool, pool);
   lo = PoolPoolLO(pool);
   AVERT(LO, lo);
@@ -618,7 +629,7 @@ static void LOBufferEmpty(Pool pool, Buffer buffer, Addr init, Addr limit)
   seg = BufferSeg(buffer);
   AVERT(Seg, seg);
   AVER(init <= limit);
- 
+
   loseg = SegLOSeg(seg);
   AVERT(LOSeg, loseg);
   AVER(loseg->lo == lo);
@@ -657,7 +668,7 @@ static Res LOWhiten(Pool pool, Trace trace, Seg seg)
 {
   LO lo;
   unsigned long bits;
- 
+
   AVERT(Pool, pool);
   lo = PoolPoolLO(pool);
   AVERT(LO, lo);
@@ -689,14 +700,14 @@ static Res LOFix(Pool pool, ScanState ss, Seg seg, Ref *refIO)
 {
   LO lo;
   LOSeg loseg;
-  Ref ref;
+  Ref clientRef;
+  Addr base;
 
   AVERT_CRITICAL(Pool, pool);
   AVERT_CRITICAL(ScanState, ss);
   AVERT_CRITICAL(Seg, seg);
   AVER_CRITICAL(TraceSetInter(SegWhite(seg), ss->traces) != TraceSetEMPTY);
   AVER_CRITICAL(refIO != NULL);
-  ref = *refIO;
   lo = PARENT(LOStruct, poolStruct, pool);
   AVERT_CRITICAL(LO, lo);
   loseg = SegLOSeg(seg);
@@ -704,9 +715,19 @@ static Res LOFix(Pool pool, ScanState ss, Seg seg, Ref *refIO)
 
   ss->wasMarked = TRUE;         /* design.mps.fix.protocol.was-marked */
 
+  clientRef = *refIO;
+  base = AddrSub((Addr)clientRef, pool->format->headerSize);
+  /* can get an ambiguous reference to close to the base of the
+   * segment, so when we subtract the header we are not in the
+   * segment any longer.  This isn't a real reference,
+   * so we can just skip it.  */
+  if (base < SegBase(seg)) {
+    return ResOK;
+  }
+
   switch(ss->rank) {
   case RankAMBIG:
-    if(!AddrIsAligned(ref, PoolAlignment(pool))) {
+    if(!AddrIsAligned(base, PoolAlignment(pool))) {
       return ResOK;
     }
   /* fall through */
@@ -714,7 +735,7 @@ static Res LOFix(Pool pool, ScanState ss, Seg seg, Ref *refIO)
   case RankEXACT:
   case RankFINAL:
   case RankWEAK: {
-    Size i = AddrOffset(SegBase(seg), (Addr)ref) >> lo->alignShift;
+    Size i = AddrOffset(SegBase(seg), base) >> lo->alignShift;
 
     if(!BTGet(loseg->mark, i)) {
       ss->wasMarked = FALSE;  /* design.mps.fix.protocol.was-marked */