3m GC bug fixes and improvements, include backtrace support

svn: r3548

src/configure

@@ -870,7 +870,7 @@ Optional Features:
   --enable-sgcdebug       use Senora GC for debugging
   --enable-account        3m: use memory-accounting GC (enabled by default)
   --enable-compact        3m: use compact GC (no accounting)
-  --enable-backtrace      3m: compact plus backtrace info
+  --enable-backtrace      3m: support GC backtrace dumps
   --enable-float          include support for single-precision floats
   --enable-floatinstead   compile to use single-precision by default
   --enable-pthread        link MrEd with pthreads (sometimes needed for GL)
@@ -9170,8 +9170,7 @@ echo "$as_me:$LINENO: result: $mbsrtowcs" >&5
 echo "${ECHO_T}$mbsrtowcs" >&6
 
 if test "${enable_backtrace}" = "yes" ; then
-  enable_compact=yes
+  GC2OPTIONS="$GC2OPTIONS -DMZ_GC_BACKTRACE"
-  GC2OPTIONS="$GC2OPTIONS -DCOMPACT_BACKTRACE_GC"
 fi
 
 if test "${enable_compact}" = "yes" ; then

src/mred/mrmain.cxx

@@ -281,7 +281,7 @@ int main(int argc, char *argv[])
 #if defined(MZ_PRECISE_GC)
 # ifndef wx_msw
   stack_start = (void *)&__gc_var_stack__;
-  GC_init_type_tags(_scheme_last_type_, scheme_weak_box_type, scheme_ephemeron_type);
+  GC_init_type_tags(_scheme_last_type_, scheme_weak_box_type, scheme_ephemeron_type, scheme_rt_weak_array);
 # endif
   /* For Windows, WinMain inits the type tags. */
 #endif

src/mred/wxs/prefix.xci

@@ -1,6 +1,6 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif

src/mred/wxs/wxs_bmap.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_butn.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_chce.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_ckbx.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_cnvs.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_dc.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_evnt.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_fram.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_gage.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_gdi.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_glob.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_item.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_lbox.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_madm.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_mede.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_medi.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_menu.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_mio.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_misc.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_mpb.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_obj.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_panl.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_rado.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_slid.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_snip.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_styl.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_tabc.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mred/wxs/wxs_win.cxx

@@ -5,7 +5,7 @@
 #if defined(_MSC_VER)
 # include "wx.h"
 #endif
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X)
 # include "common.h"
 #endif
 

src/mzscheme/configure.ac

@@ -44,7 +44,7 @@ AC_ARG_ENABLE(sgc, [  --enable-sgc            use Senora GC instead of the Boehm
 AC_ARG_ENABLE(sgcdebug, [  --enable-sgcdebug       use Senora GC for debugging])
 AC_ARG_ENABLE(account, [  --enable-account        3m: use memory-accounting GC (enabled by default)], , enable_account=yes)
 AC_ARG_ENABLE(compact, [  --enable-compact        3m: use compact GC (no accounting)])
-AC_ARG_ENABLE(backtrace, [  --enable-backtrace      3m: compact plus backtrace info])
+AC_ARG_ENABLE(backtrace, [  --enable-backtrace      3m: support GC backtrace dumps])
 
 AC_ARG_ENABLE(float, [  --enable-float          include support for single-precision floats])
 AC_ARG_ENABLE(floatinstead, [  --enable-floatinstead   compile to use single-precision by default])
@@ -666,8 +666,7 @@ fi
 AC_MSG_RESULT($mbsrtowcs)
 
 if test "${enable_backtrace}" = "yes" ; then
-  enable_compact=yes
+  GC2OPTIONS="$GC2OPTIONS -DMZ_GC_BACKTRACE"
-  GC2OPTIONS="$GC2OPTIONS -DCOMPACT_BACKTRACE_GC"
 fi
 
 if test "${enable_compact}" = "yes" ; then

src/mzscheme/gc2/README

@@ -1,6 +1,7 @@
 
 This README provides and overview of the precise GC interface used by
-MzScheme. The header file gc2.h provides additional documentation.
+MzScheme. The header files gc2.h and gc2_dump.h provide additional
+documentation.
 
 GC Architecture
 ---------------

src/mzscheme/gc2/backtrace.c

@@ -0,0 +1,110 @@
+/* 
+   Provides:
+      reset_object_traces
+      register_traced_object
+      print_traced_objects
+      print_out_pointer
+   Requires:
+      avoid_collection
+      trace_page_t
+      find_page 
+      trace_page_type
+       TRACE_PAGE_TAGGED
+       TRACE_PAGE_ARRAY
+       TRACE_PAGE_TAGGED_ARRAY
+       TRACE_PAGE_ATOMIC
+       TRACE_PAGE_XTAGGED
+       TRACE_PAGE_MALLOCFREE
+       TRACE_PAGE_BAD
+      trace_page_is_big
+      trace_backpointer
+*/
+
+
+# define MAX_FOUND_OBJECTS 5000
+static int found_object_count;
+static void *found_objects[MAX_FOUND_OBJECTS];
+
+static void reset_object_traces()
+{
+  found_object_count = 0;
+}
+
+static void register_traced_object(void *p)
+{
+  if (found_object_count < MAX_FOUND_OBJECTS) {
+    found_objects[found_object_count++] = p;
+  }
+}
+
+static void *print_out_pointer(const char *prefix, void *p,
+			       GC_get_type_name_proc get_type_name,
+			       GC_get_xtagged_name_proc get_xtagged_name,
+			       GC_print_tagged_value_proc print_tagged_value)
+{
+  trace_page_t *page;
+  const char *what;
+
+  page = find_page(p);
+  if (!page || (trace_page_type(page) == TRACE_PAGE_BAD)) {
+    GCPRINT(GCOUTF, "%s??? %p\n", prefix, p);
+    return NULL;
+  }
+
+  if (trace_page_type(page) == TRACE_PAGE_TAGGED) {
+    Type_Tag tag;
+    tag = *(Type_Tag *)p;
+    if ((tag >= 0) && get_type_name && get_type_name(tag)) {
+      print_tagged_value(prefix, p, 0, 0, 1000, "\n");
+    } else {
+      GCPRINT(GCOUTF, "%s<#%d> %p\n", prefix, tag, p);
+    }
+    what = NULL;
+  } else if (trace_page_type(page) == TRACE_PAGE_ARRAY) {
+    what = "ARRAY";
+  } else if (trace_page_type(page) == TRACE_PAGE_TAGGED_ARRAY) {
+    what = "TARRAY";
+  } else if (trace_page_type(page) == TRACE_PAGE_ATOMIC) {
+    what = "ATOMIC";
+  } else if (trace_page_type(page) == TRACE_PAGE_XTAGGED) {
+    if (get_xtagged_name)
+      what = get_xtagged_name(p);
+    else
+      what = "XTAGGED";
+  } else if (trace_page_type(page) == TRACE_PAGE_MALLOCFREE) {
+    what = "MALLOCED";
+  } else {
+    what = "?!?";
+  }
+
+  if (what) {
+    GCPRINT(GCOUTF, "%s%s%s %p\n", 
+	    prefix, what, 
+	    (trace_page_is_big(page) ? "b" : ""),
+	    p);
+  }
+
+  return trace_backpointer(page, p);
+}
+
+static void print_traced_objects(int path_length_limit,
+				 GC_get_type_name_proc get_type_name,
+				 GC_get_xtagged_name_proc get_xtagged_name,
+				 GC_print_tagged_value_proc print_tagged_value)
+{
+  int i;
+  avoid_collection++;
+  GCPRINT(GCOUTF, "Begin Trace\n");
+  for (i = 0; i < found_object_count; i++) {
+    void *p;
+    int limit = path_length_limit;
+    p = found_objects[i];
+    p = print_out_pointer("==* ", p, get_type_name, get_xtagged_name, print_tagged_value);
+    while (p && limit) {
+      p = print_out_pointer(" <- ", p, get_type_name, get_xtagged_name, print_tagged_value);
+      limit--;
+    }
+  }
+  GCPRINT(GCOUTF, "End Trace\n");
+  --avoid_collection;
+}

src/mzscheme/gc2/compact.c

@@ -82,6 +82,7 @@
 typedef short Type_Tag;
 
 #include "gc2.h"
+#include "gc2_dump.h"
 
 #define BYTEPTR(x) ((char *)x)
 
@@ -98,7 +99,7 @@ typedef short Type_Tag;
 #define KEEP_BACKPOINTERS 0
 #define DEFINE_MALLOC_FREE 0
 
-#ifdef COMPACT_BACKTRACE_GC
+#ifdef MZ_GC_BACKTRACE
 # undef KEEP_BACKPOINTERS
 # define KEEP_BACKPOINTERS 1
 #endif
@@ -160,8 +161,8 @@ void GC_set_variable_stack(void **p) { GC_variable_stack = p; }
 /********************* Type tags *********************/
 Type_Tag weak_box_tag = 42; /* set by client */
 Type_Tag ephemeron_tag = 42; /* set by client */
+Type_Tag weak_array_tag  = 42; /* set by client */
 
-#define gc_weak_array_tag 256
 #define gc_on_free_list_tag 257
 
 #define _num_tags_ 260
@@ -465,10 +466,11 @@ void GC_set_stack_base(void *base)
   stack_base = (unsigned long)base;
 }
 
-void GC_init_type_tags(int count, int weakbox, int ephemeron)
+void GC_init_type_tags(int count, int weakbox, int ephemeron, int weakarray)
 {
   weak_box_tag = weakbox;
   ephemeron_tag = ephemeron;
+  weak_array_tag = weakarray;
 }
 
 void GC_register_traversers(Type_Tag tag, Size_Proc size, Mark_Proc mark, Fixup_Proc fixup, 
@@ -2858,7 +2860,7 @@ static void check_ptr(void **a)
 	  || (!size_table[tag] 
 	      && (tag != weak_box_tag)
 	      && (tag != ephemeron_tag)
-	      && (tag != gc_weak_array_tag)
+	      && (tag != weak_array_tag)
 	      && (tag != gc_on_free_list_tag))) {
 	GCPRINT(GCOUTF, "bad tag: %d at %lx, references from %lx\n", tag, (long)p, (long)a);
 	GCFLUSHOUT();
@@ -2955,7 +2957,7 @@ static void init(void)
   if (!initialized) {
     GC_register_traversers(weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 1, 0);
     GC_register_traversers(ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 1, 0);
-    GC_register_traversers(gc_weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
+    GC_register_traversers(weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
 #if USE_FREELIST
     GC_register_traversers(gc_on_free_list_tag, size_on_free_list, size_on_free_list, size_on_free_list, 0, 0);
 #endif
@@ -4328,18 +4330,41 @@ static void check_not_freed(MPage *page, const void *p)
 static long dump_info_array[BIGBLOCK_MIN_SIZE];
 
 #if KEEP_BACKPOINTERS
-# define MAX_FOUND_OBJECTS 5000
+
-int GC_show_trace = 0;
+static void *trace_backpointer(MPage *page, void *p)
-int GC_show_finals = 0;
+{
-int GC_trace_for_tag = 57;
+
-int GC_path_length_limit = 1000;
+  if (page->flags & MFLAG_BIGBLOCK)
-static int found_object_count;
+    return (void *)page->backpointer_page;
-static void *found_objects[MAX_FOUND_OBJECTS];
+  else {
-void (*GC_for_each_found)(void *p) = NULL;
+    int offset;
-char *(*GC_get_xtagged_name)(void *p) = NULL;
+    offset = ((char *)p - (char *)page->block_start) >> LOG_WORD_SIZE;
+    if (page->type != MTYPE_TAGGED)
+      offset -= 1;
+    if (offset > 0)
+      return page->backpointer_page[offset];
+    else
+      return NULL; /* This shouldn't happen */
+  }
+}
+
+# define trace_page_t MPage
+# define trace_page_type(page) (page)->type
+# define TRACE_PAGE_TAGGED MTYPE_TAGGED
+# define TRACE_PAGE_ARRAY MTYPE_ARRAY
+# define TRACE_PAGE_TAGGED_ARRAY MTYPE_TAGGED_ARRAY
+# define TRACE_PAGE_ATOMIC MTYPE_ATOMIC
+# define TRACE_PAGE_XTAGGED MTYPE_XTAGGED
+# define TRACE_PAGE_MALLOCFREE MTYPE_MALLOCFREE
+# define TRACE_PAGE_BAD 0
+# define trace_page_is_big(page) ((page)->flags & MFLAG_BIGBLOCK)
+
+# include "backtrace.c"
+
 #endif
 
-static long scan_tagged_mpage(void **p, MPage *page)
+static long scan_tagged_mpage(void **p, MPage *page, short trace_for_tag,
+			      GC_for_each_found_proc for_each_found)
 {
   void **top, **bottom = p;
 
@@ -4373,15 +4398,13 @@ static long scan_tagged_mpage(void **p, MPage *page)
       dump_info_array[tag]++;
       dump_info_array[tag + _num_tags_] += size;
 
+      if (tag == trace_for_tag) {
 #if KEEP_BACKPOINTERS
-      if (tag == GC_trace_for_tag) {
+	register_traced_object(p);
-	if (found_object_count < MAX_FOUND_OBJECTS) {
-	  found_objects[found_object_count++] = p;
-	}
-	if (GC_for_each_found)
-	  GC_for_each_found(p);
-      }
 #endif
+	if (for_each_found)
+	  for_each_found(p);
+      }
 
       p += size;
 #if ALIGN_DOUBLES
@@ -4415,13 +4438,7 @@ static long scan_untagged_mpage(void **p, MPage *page)
   return MPAGE_WORDS;
 }
 
-/* HACK! */
-extern char *scheme_get_type_name(Type_Tag t);
-
 #if KEEP_BACKPOINTERS
-extern void scheme_print_tagged_value(const char *prefix, 
-				      void *v, int xtagged, unsigned long diff, int max_w,
-				      const char *suffix);
 
 int GC_is_tagged(void *p)
 {
@@ -4521,178 +4538,129 @@ void *GC_next_tagged_start(void *p)
   }
 }
 
-void *print_out_pointer(const char *prefix, void *p)
-{
-  MPage *page;
-  const char *what;
-
-  page = find_page(p);
-  if (!page || !page->type) {
-    GCPRINT(GCOUTF, "%s??? %p\n", prefix, p);
-    return NULL;
-  }
-
-  if (page->type == MTYPE_TAGGED) {
-    Type_Tag tag;
-    tag = *(Type_Tag *)p;
-    if ((tag >= 0) && (tag < _num_tags_) && scheme_get_type_name(tag)) {
-      scheme_print_tagged_value(prefix, p, 0, 0, 1000, "\n");
-    } else {
-      GCPRINT(GCOUTF, "%s<#%d> %p\n", prefix, tag, p);
-    }
-    what = NULL;
-  } else if (page->type == MTYPE_ARRAY) {
-    what = "ARRAY";
-  } else if (page->type == MTYPE_TAGGED_ARRAY) {
-    what = "TARRAY";
-  } else if (page->type == MTYPE_ATOMIC) {
-    what = "ATOMIC";
-  } else if (page->type == MTYPE_XTAGGED) {
-    if (GC_get_xtagged_name)
-      what = GC_get_xtagged_name(p);
-    else
-      what = "XTAGGED";
-  } else if (page->type == MTYPE_MALLOCFREE) {
-    what = "MALLOCED";
-  } else {
-    what = "?!?";
-  }
-
-  if (what) {
-    GCPRINT(GCOUTF, "%s%s%s %p\n", 
-	    prefix, what, 
-	    ((page->flags & MFLAG_BIGBLOCK) ? "b" : ""),
-	    p);
-  }
-
-  if (page->flags & MFLAG_BIGBLOCK)
-    p = (void *)page->backpointer_page;
-  else {
-    int offset;
-    offset = ((char *)p - (char *)page->block_start) >> LOG_WORD_SIZE;
-    if (what)
-      offset -= 1;
-    if (offset > 0)
-      p = page->backpointer_page[offset];
-    else
-      p = NULL; /* This shouldn't happen */
-  }
-
-  return p;
-}
 #endif
 
-void GC_dump(void)
+void GC_dump_with_traces(int flags,
+			 GC_get_type_name_proc get_type_name,
+			 GC_get_xtagged_name_proc get_xtagged_name,
+			 GC_for_each_found_proc for_each_found,
+			 short trace_for_tag,
+			 GC_print_tagged_value_proc print_tagged_value,
+			 int path_length_limit)
 {
   int i;
   long waste = 0;
 
+  if (!(flags & GC_DUMP_SHOW_TRACE))
+    trace_for_tag = -1;
 #if KEEP_BACKPOINTERS
-  found_object_count = 0;
+  reset_object_traces();
-  if (GC_for_each_found)
+#endif
+  if (for_each_found)
     avoid_collection++;
-#endif
 
-  GCPRINT(GCOUTF, "t=tagged a=atomic v=array x=xtagged g=tagarray\n");
+  if (flags & GC_DUMP_SHOW_DETAILS) {
-  GCPRINT(GCOUTF, "mpagesize=%ld  opagesize=%ld\n", (long)MPAGE_SIZE, (long)OPAGE_SIZE);
+    GCPRINT(GCOUTF, "t=tagged a=atomic v=array x=xtagged g=tagarray\n");
-  GCPRINT(GCOUTF, "[");
+    GCPRINT(GCOUTF, "mpagesize=%ld  opagesize=%ld\n", (long)MPAGE_SIZE, (long)OPAGE_SIZE);
-  for (i = 0; i < MAPS_SIZE; i++) {
+    GCPRINT(GCOUTF, "[");
-    if (i && !(i & 63))
+    for (i = 0; i < MAPS_SIZE; i++) {
-      GCPRINT(GCOUTF, "\n ");
+      if (i && !(i & 63))
+	GCPRINT(GCOUTF, "\n ");
 
-    if (mpage_maps[i])
+      if (mpage_maps[i])
-      GCPRINT(GCOUTF, "*");
+	GCPRINT(GCOUTF, "*");
-    else
+      else
-      GCPRINT(GCOUTF, "-");
+	GCPRINT(GCOUTF, "-");
-  }
+    }
-  GCPRINT(GCOUTF, "]\n");
+    GCPRINT(GCOUTF, "]\n");
-  for (i = 0; i < MAPS_SIZE; i++) {
+    for (i = 0; i < MAPS_SIZE; i++) {
-    MPage *maps = mpage_maps[i];
+      MPage *maps = mpage_maps[i];
-    if (maps) {
+      if (maps) {
-      int j;
+	int j;
-      GCPRINT(GCOUTF, "%.2x:\n ", i);
+	GCPRINT(GCOUTF, "%.2x:\n ", i);
-      for (j = 0; j < MAP_SIZE; j++) {
+	for (j = 0; j < MAP_SIZE; j++) {
-	if (j && !(j & 63))
+	  if (j && !(j & 63))
-	  GCPRINT(GCOUTF, "\n ");
+	    GCPRINT(GCOUTF, "\n ");
 
-	if (maps[j].type
+	  if (maps[j].type
 #if DEFINE_MALLOC_FREE
-	    && (maps[j].type != MTYPE_MALLOCFREE)
+	      && (maps[j].type != MTYPE_MALLOCFREE)
 #endif
-	    ) {
+	      ) {
-	  int c;
+	    int c;
 
-	  if (maps[j].flags & MFLAG_CONTINUED) 
+	    if (maps[j].flags & MFLAG_CONTINUED) 
-	    c = '.';
+	      c = '.';
-	  else {
+	    else {
-	    if (maps[j].type <= MTYPE_TAGGED)
+	      if (maps[j].type <= MTYPE_TAGGED)
-	      c = 't';
+		c = 't';
-	    else if (maps[j].type == MTYPE_TAGGED_ARRAY)
+	      else if (maps[j].type == MTYPE_TAGGED_ARRAY)
-	      c = 'g';
+		c = 'g';
-	    else if (maps[j].type == MTYPE_ATOMIC)
+	      else if (maps[j].type == MTYPE_ATOMIC)
-	      c = 'a';
+		c = 'a';
-	    else if (maps[j].type == MTYPE_XTAGGED)
+	      else if (maps[j].type == MTYPE_XTAGGED)
-	      c = 'x';
+		c = 'x';
-	    else
+	      else
-	      c = 'v';
+		c = 'v';
 	    
-	    if (maps[j].flags & MFLAG_BIGBLOCK)
+	      if (maps[j].flags & MFLAG_BIGBLOCK)
-	      c = c - ('a' - 'A');
+		c = c - ('a' - 'A');
-	  }
+	    }
 
-	  GCPRINT(GCOUTF, "%c", c);
+	    GCPRINT(GCOUTF, "%c", c);
-	} else {
+	  } else {
-	  GCPRINT(GCOUTF, "-");
+	    GCPRINT(GCOUTF, "-");
+	  }
 	}
+	GCPRINT(GCOUTF, "\n");
+      }
+    }
+
+    {
+      MPage *page;
+
+      GCPRINT(GCOUTF, "Block info: [type][modified?][age][refs-age]\n");
+      for (page = first, i = 0; page; page = page->next, i++) {
+	int c;
+
+	if (page->flags & MFLAG_CONTINUED) 
+	  c = '.';
+	else {
+	  if (page->type <= MTYPE_TAGGED)
+	    c = 't';
+	  else if (page->type == MTYPE_TAGGED_ARRAY)
+	    c = 'g';
+	  else if (page->type == MTYPE_ATOMIC)
+	    c = 'a';
+	  else if (page->type == MTYPE_XTAGGED)
+	    c = 'x';
+	  else
+	    c = 'v';
+	 
+	  if (page->flags & MFLAG_BIGBLOCK)
+	    c = c - ('a' - 'A');
+	}
+       
+	GCPRINT(GCOUTF, " %c%c%c%c",
+		c,
+		((page->flags & MFLAG_MODIFIED)
+		 ? 'M'
+		 : '_'),
+		((page->age < 10)
+		 ? (page->age + '0')
+		 : (page->age + 'a' - 10)),
+		((page->type == MTYPE_ATOMIC)
+		 ? '-'
+		 : ((page->refs_age < 10)
+		    ? (page->refs_age + '0')
+		    : (page->refs_age + 'a' - 10))));
+	if ((i % 10) == 9)
+	  GCPRINT(GCOUTF, "\n");
       }
       GCPRINT(GCOUTF, "\n");
     }
   }
 
-  {
-    MPage *page;
-
-    GCPRINT(GCOUTF, "Block info: [type][modified?][age][refs-age]\n");
-    for (page = first, i = 0; page; page = page->next, i++) {
-       int c;
-
-       if (page->flags & MFLAG_CONTINUED) 
-	 c = '.';
-       else {
-	 if (page->type <= MTYPE_TAGGED)
-	   c = 't';
-	 else if (page->type == MTYPE_TAGGED_ARRAY)
-	   c = 'g';
-	 else if (page->type == MTYPE_ATOMIC)
-	   c = 'a';
-	 else if (page->type == MTYPE_XTAGGED)
-	   c = 'x';
-	 else
-	   c = 'v';
-	 
-	 if (page->flags & MFLAG_BIGBLOCK)
-	   c = c - ('a' - 'A');
-       }
-       
-       GCPRINT(GCOUTF, " %c%c%c%c",
-	       c,
-	       ((page->flags & MFLAG_MODIFIED)
-		? 'M'
-		: '_'),
-	       ((page->age < 10)
-		? (page->age + '0')
-		: (page->age + 'a' - 10)),
-	       ((page->type == MTYPE_ATOMIC)
-		? '-'
-		: ((page->refs_age < 10)
-		   ? (page->refs_age + '0')
-		   : (page->refs_age + 'a' - 10))));
-      if ((i % 10) == 9)
-	GCPRINT(GCOUTF, "\n");
-    }
-    GCPRINT(GCOUTF, "\n");
-  }
-
   {
     int j;
 
@@ -4723,39 +4691,41 @@ void GC_dump(void)
 	  if (j >= NUM_TAGGED_SETS)
 	    used = scan_untagged_mpage(page->block_start, page); /* gets size counts */
 	  else
-	    used = scan_tagged_mpage(page->block_start, page); /* gets tag counts */
+	    used = scan_tagged_mpage(page->block_start, page, 
+				     trace_for_tag, for_each_found); /* gets tag counts */
 
 	  total += used;
 	  waste += (MPAGE_WORDS - used);
 	}
-#if KEEP_BACKPOINTERS
 	if ((page->flags & MFLAG_BIGBLOCK)
 	    && (page->type == kind)
-	    && (((GC_trace_for_tag >= (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE))
+	    && (((trace_for_tag >= (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE))
-		 && (page->u.size > GC_trace_for_tag))
+		 && (page->u.size > trace_for_tag))
-		|| (page->u.size == -GC_trace_for_tag))) {
+		|| (page->u.size == -trace_for_tag))) {
-	  if (found_object_count < MAX_FOUND_OBJECTS)
+#if KEEP_BACKPOINTERS
-	    found_objects[found_object_count++] = page->block_start;
+	  register_traced_object(page->block_start);
-	  if (GC_for_each_found)
-	    GC_for_each_found(page->block_start);
-	}
 #endif
+	  if (for_each_found)
+	    for_each_found(page->block_start);
+	}
       }
 
       if (j >= NUM_TAGGED_SETS) {
 	int k = 0;
-	GCPRINT(GCOUTF, "%s counts: ", name);
+	if (flags & GC_DUMP_SHOW_DETAILS) {
-	for (i = 0; i < (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE); i++) {
+	  GCPRINT(GCOUTF, "%s counts: ", name);
-	  if (dump_info_array[i]) {
+	  for (i = 0; i < (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE); i++) {
-	    k++;
+	    if (dump_info_array[i]) {
-	    if (k == 10) {
+	      k++;
-	      GCPRINT(GCOUTF, "\n    ");
+	      if (k == 10) {
-	      k = 0;
+		GCPRINT(GCOUTF, "\n    ");
+		k = 0;
+	      }
+	      GCPRINT(GCOUTF, " [%d:%ld]", i << LOG_WORD_SIZE, dump_info_array[i]);
 	    }
-	    GCPRINT(GCOUTF, " [%d:%ld]", i << LOG_WORD_SIZE, dump_info_array[i]);
 	  }
+	  GCPRINT(GCOUTF, "\n");
 	}
-	GCPRINT(GCOUTF, "\n");
       } else {
 	GCPRINT(GCOUTF, "Tag counts and sizes:\n");
 	GCPRINT(GCOUTF, "Begin MzScheme3m\n");
@@ -4763,10 +4733,14 @@ void GC_dump(void)
 	  if (dump_info_array[i]) {
 	    char *tn, buf[256];
 	    switch(i) {
-	    case gc_weak_array_tag: tn = "weak-array"; break;
 	    case gc_on_free_list_tag: tn = "freelist-elem"; break;
 	    default:
-	      tn = scheme_get_type_name((Type_Tag)i);
+	      if (i == weak_array_tag)
+		tn = "weak-array";
+	      else if (get_type_name)
+		tn = get_type_name((Type_Tag)i);
+	      else
+		tn = NULL;
 	      if (!tn) {
 		sprintf(buf, "unknown,%d", i);
 		tn = buf;
@@ -4779,7 +4753,7 @@ void GC_dump(void)
 	GCPRINT(GCOUTF, "End MzScheme3m\n");
       }
 
-      {
+      if (flags & GC_DUMP_SHOW_DETAILS) {
 	int did_big = 0;
 	for (page = first; page; page = page->next) {
 	  if ((page->type == kind) && (page->flags & MFLAG_BIGBLOCK) && !(page->flags & MFLAG_CONTINUED)) {
@@ -4826,34 +4800,26 @@ void GC_dump(void)
 	  (100.0 * ((double)page_reservations - memory_in_use)) / memory_in_use);
 
 #if KEEP_BACKPOINTERS
-  if (GC_show_trace) {
+  if (flags & GC_DUMP_SHOW_TRACE) {
-    avoid_collection++;
+    print_traced_objects(path_length_limit, get_type_name, get_xtagged_name, print_tagged_value);
-    GCPRINT(GCOUTF, "Begin Trace\n");
-    for (i = 0; i < found_object_count; i++) {
-      void *p;
-      int limit = GC_path_length_limit;
-      p = found_objects[i];
-      p = print_out_pointer("==* ", p);
-      while (p && limit) {
-	p = print_out_pointer(" <- ", p);
-	limit--;
-      }
-    }
-    GCPRINT(GCOUTF, "End Trace\n");
-    GC_trace_for_tag = 57;
-    --avoid_collection;
   }
-  if (GC_show_finals) {
+  if (flags & GC_DUMP_SHOW_FINALS) {
     Fnl *f;
     avoid_collection++;
     GCPRINT(GCOUTF, "Begin Finalizations\n");
     for (f = finalizers; f; f = f->next) {
-      print_out_pointer("==@ ", f->p);
+      print_out_pointer("==@ ", f->p, get_type_name, get_xtagged_name, print_tagged_value);
     }
     GCPRINT(GCOUTF, "End Finalizations\n");
     --avoid_collection;
   }
-  if (GC_for_each_found)
-    avoid_collection++;
 #endif
+  if (for_each_found)
+    --avoid_collection;
 }
+
+void GC_dump(void)
+{
+  GC_dump_with_traces(0, NULL, NULL, NULL, 0, NULL, 0);
+}
+

src/mzscheme/gc2/fnls.c

@@ -5,6 +5,7 @@
       GC_set_finalizer
       reset_finalizer_tree
       finalizers
+      num_fnls
    Requires:
       GC_weak_array_tag
       is_finalizable_page(p)

src/mzscheme/gc2/gc2.h

@@ -64,7 +64,7 @@ GC2_EXTERN void GC_add_roots(void *start, void *end);
    Called by MzScheme to install roots. The memory between
    `start' (inclusive) and `end' (exclusive) contains pointers. */
 
-GC2_EXTERN void GC_init_type_tags(int count, int weakbox, int ephemeron);
+GC2_EXTERN void GC_init_type_tags(int count, int weakbox, int ephemeron, int weakarray);
 /*
    Called by MzScheme to indicate the number of different type tags it
    uses, starting from 0. `count' is always less than 256. The weakbox

src/mzscheme/gc2/gc2_dump.h

@@ -0,0 +1,31 @@
+
+/* Extra headers for the GC2 tracing interface */
+
+#ifndef __mzscheme_gc_2_dump__
+#define __mzscheme_gc_2_dump__
+
+typedef char *(*GC_get_type_name_proc)(short t);
+typedef char *(*GC_get_xtagged_name_proc)(void *p);
+typedef void (*GC_for_each_found_proc)(void *p);
+
+typedef void (*GC_print_tagged_value_proc)(const char *prefix, 
+					   void *v, int xtagged, unsigned long diff, int max_w,
+					   const char *suffix);
+
+GC2_EXTERN void GC_dump_with_traces(int flags,
+				    GC_get_type_name_proc get_type_name,
+				    GC_get_xtagged_name_proc get_xtagged_name,
+				    GC_for_each_found_proc for_each_found,
+				    short trace_for_tag,
+				    GC_print_tagged_value_proc print_tagged_value,
+				    int path_length_limit);
+
+# define GC_DUMP_SHOW_DETAILS  0x1
+# define GC_DUMP_SHOW_TRACE    0x2
+# define GC_DUMP_SHOW_FINALS   0x4
+
+GC2_EXTERN int GC_is_tagged(void *p);
+GC2_EXTERN int GC_is_tagged_start(void *p);
+GC2_EXTERN void *GC_next_tagged_start(void *p);
+
+#endif

src/mzscheme/gc2/newgc.c

@@ -32,6 +32,7 @@
 #include <stdio.h>
 #include <string.h>
 #include "gc2.h"
+#include "gc2_dump.h"
 #include "../src/schpriv.h"
 
 #ifdef _WIN32
@@ -91,9 +92,6 @@
 /* the size of a page we use for the internal mark stack */
 #define STACK_PART_SIZE (1 * 1024 * 1024)
 
-/* the maximum number of pages to compact at any one time */
-#define MAX_PAGES_TO_COMPACT 25
-
 /* These are computed from the previous settings. You shouldn't mess with 
    them */
 #define PTR(x) ((void*)(x))
@@ -108,7 +106,7 @@
 #define WORD_SIZE (1 << LOG_WORD_SIZE)
 #define WORD_BITS (8 * WORD_SIZE)
 #define APAGE_SIZE (1 << LOG_APAGE_SIZE)
-#define GENERATIONS 2
+#define GENERATIONS 1
 
 /* the externals */
 void (*GC_collect_start_callback)(void);
@@ -238,7 +236,7 @@ struct mpage {                      /* BYTES: */
   unsigned char marked_on;          /* +  1 */
   unsigned char has_new;            /* +  1 */
   unsigned short live_size;         /* +  2 */
-  struct mpage *mirror;             /* +  4 */
+  void **backtrace;                 /* +  4 */
                                     /* = 28 bytes */
                                     /* = 28 / 4 = 7 words */
 };
@@ -331,6 +329,8 @@ static int gc_full = 0; /* a flag saying if this is a full/major collection */
 static Mark_Proc mark_table[NUMBER_OF_TAGS]; /* the table of mark procs */
 static Fixup_Proc fixup_table[NUMBER_OF_TAGS]; /* the talbe of repair procs */
 static unsigned long memory_in_use = 0; /* the amount of memory in use */
+static struct mpage *release_page = NULL;
+static int avoid_collection;
 
 /* These procedures modify or use the page map. The page map provides us very
    fast mappings from pointers to the page the reside on, if any. The page 
@@ -372,6 +372,13 @@ inline static struct mpage *find_page(void *p)
 }
 
 
+static size_t round_to_apage_size(size_t sizeb)
+{  
+  sizeb += APAGE_SIZE - 1;
+  sizeb -= sizeb & (APAGE_SIZE - 1);
+  return sizeb;
+}
+
 /* the core allocation functions */
 static void *allocate_big(size_t sizeb, int type)
 {
@@ -386,11 +393,15 @@ static void *allocate_big(size_t sizeb, int type)
   sizeb = gcWORDS_TO_BYTES(sizew);
 
   if((gen0_current_size + sizeb) >= gen0_max_size) {
-    garbage_collect(0);
+    if (!avoid_collection)
+      garbage_collect(0);
   }
   gen0_current_size += sizeb;
 
-  bpage = malloc_pages(sizeb, APAGE_SIZE);
+  /* We not only need APAGE_SIZE alignment, we 
+     need everything consisently mapped within an APAGE_SIZE
+     segment. So round up. */
+  bpage = malloc_pages(round_to_apage_size(sizeb), APAGE_SIZE);
   bpage->size = sizeb;
   bpage->big_page = 1;
   bpage->page_type = type;
@@ -423,7 +434,21 @@ inline static void *allocate(size_t sizeb, int type)
       newsize = gen0_alloc_page->size + sizeb;
 
       if(newsize > GEN0_PAGE_SIZE) {
-	if(gen0_alloc_page->next) gen0_alloc_page = gen0_alloc_page->next; else
+	if(gen0_alloc_page->next) 
+	  gen0_alloc_page = gen0_alloc_page->next; 
+	else if (avoid_collection) {
+	  struct mpage *work;
+
+	  work = malloc_pages(GEN0_PAGE_SIZE, APAGE_SIZE);
+	  work->size = GEN0_PAGE_SIZE;
+	  work->big_page = 1;
+	  gen0_alloc_page->prev = work;
+	  work->next = gen0_alloc_page;
+	  gen0_alloc_page = work;
+	  pagemap_add(work);
+	  work->size = HEADER_SIZEB;
+	  work->big_page = 0;
+	} else 
 	  garbage_collect(0);
 	goto alloc_retry;
       } else {
@@ -643,6 +668,85 @@ static void dump_heap(void)
 #define GCWARN(args) { GCPRINT args; GCFLUSHOUT(); }
 #define GCERR(args) { GCPRINT args; GCFLUSHOUT(); abort(); }
 
+/*****************************************************************************/
+/* Backtrace                                                                 */
+/*****************************************************************************/
+
+#if MZ_GC_BACKTRACE
+
+static void backtrace_new_page(struct mpage *page)
+{
+  /* This is a little wastefull for big pages, because we'll
+     only use the first few words: */
+  page->backtrace = (void **)malloc_pages(APAGE_SIZE, APAGE_SIZE);
+}
+
+static void free_backtrace(struct mpage *page)
+{
+  free_pages(page->backtrace, APAGE_SIZE);
+}
+
+static void *bt_source;
+static int bt_type;
+
+static void set_backtrace_source(void *source, int type)
+{
+  bt_source = source;
+  bt_type = type;
+}
+
+static void record_backtrace(struct mpage *page, void *ptr)
+/* ptr is after objhead */
+{
+  unsigned long delta;
+
+  delta = PPTR(ptr) - PPTR(page);
+  page->backtrace[delta - 1] = bt_source;
+  ((long *)page->backtrace)[delta] = bt_type;
+}
+
+static void copy_backtrace_source(struct mpage *to_page, void *to_ptr,
+				  struct mpage *from_page, void *from_ptr)
+/* ptrs are at objhead */
+{
+  unsigned long to_delta, from_delta;
+
+  to_delta = PPTR(to_ptr) - PPTR(to_page);
+  from_delta = PPTR(from_ptr) - PPTR(from_page);
+
+  to_page->backtrace[to_delta] = from_page->backtrace[from_delta];
+  to_page->backtrace[to_delta+1] = from_page->backtrace[from_delta+1];
+}
+
+static void *get_backtrace(struct mpage *page, void *ptr)
+/* ptr is after objhead */
+{
+  unsigned long delta;
+
+  if (page->big_page)
+    ptr = PTR(NUM(page) + HEADER_SIZEB);
+
+  delta = PPTR(ptr) - PPTR(page);
+  return page->backtrace[delta - 1];
+}
+
+
+# define BT_STACK      (PAGE_TYPES + 0)
+# define BT_ROOT       (PAGE_TYPES + 1)
+# define BT_FINALIZER  (PAGE_TYPES + 2)
+# define BT_WEAKLINK   (PAGE_TYPES + 3)
+# define BT_IMMOBILE   (PAGE_TYPES + 4)
+
+#else
+# define backtrace_new_page(page) /* */
+# define free_backtrace(page) /* */
+# define set_backtrace_source(ptr, type) /* */
+# define record_backtrace(page, ptr) /* */
+# define copy_backtrace_source(to_page, to_ptr, from_page, from_ptr) /* */
+#endif
+
+#define two_arg_no_op(a, b) /* */
+
 /*****************************************************************************/
 /* Routines dealing with various runtime execution stacks                    */
 /*                                                                           */
@@ -677,7 +781,6 @@ unsigned long GC_get_stack_base()
     long size, count;                                                 \
     void ***p, **a;                                                   \
                                                                       \
-    if(park[0]) operation(park[0]); if(park[1]) operation(park[1]);   \
     while(var_stack) {                                                \
       var_stack = (void **)((char *)var_stack + delta);               \
       if(var_stack == limit) return;                                  \
@@ -709,8 +812,6 @@ void GC_mark_variable_stack(void **var_stack, long delta, void *limit)
   long size, count;
   void ***p, **a;
 
-  if(park[0]) gcMARK(park[0]);
-  if(park[1]) gcMARK(park[1]);
   while (var_stack) {
     var_stack = (void **)((char *)var_stack + delta);
     if (var_stack == limit)
@@ -729,11 +830,13 @@ void GC_mark_variable_stack(void **var_stack, long delta, void *limit)
 	size -= 2;
 	a = (void **)((char *)a + delta);
 	while (count--) {
+	  set_backtrace_source(a, BT_STACK);
 	  gcMARK(*a);
 	  a++;
 	}
       } else {
 	a = (void **)((char *)a + delta);
+	set_backtrace_source(a, BT_STACK);
 	gcMARK(*a);
       }
       p++;
@@ -749,8 +852,6 @@ void GC_fixup_variable_stack(void **var_stack, long delta, void *limit)
   long size, count;
   void ***p, **a;
 
-  if(park[0]) gcFIXUP(park[0]);
-  if(park[1]) gcFIXUP(park[1]);
   while (var_stack) {
     var_stack = (void **)((char *)var_stack + delta);
     if (var_stack == limit)
@@ -791,26 +892,29 @@ void GC_fixup_variable_stack(void **var_stack, long delta, void *limit)
 
 #include "roots.c"
 
-#define traverse_roots(gcMUCK) {                                            \
+#define traverse_roots(gcMUCK, set_bt_src) {				    \
     unsigned long j;                                                        \
     if(roots) {                                                             \
       sort_and_merge_roots();                                               \
       for(j = 0; j < roots_count; j += 2) {                                 \
         void **start = (void**)roots[j];                                    \
         void **end = (void**)roots[j+1];                                    \
-        while(start < end) gcMUCK(*start++);                                \
+        while(start < end) {                                                \
+          set_bt_src(start, BT_ROOT);                                       \
+          gcMUCK(*start++);						    \
+        }                                                                   \
       }                                                                     \
     }                                                                       \
   }
 
 inline static void mark_roots() 
 {
-  traverse_roots(gcMARK);
+  traverse_roots(gcMARK, set_backtrace_source);
 }
 
 inline static void repair_roots()
 {
-  traverse_roots(gcFIXUP);
+  traverse_roots(gcFIXUP, two_arg_no_op);
 }
 
 /*****************************************************************************/
@@ -848,20 +952,22 @@ void GC_free_immobile_box(void **b)
   GCWARN((GCOUTF, "Attempted free of non-existent immobile box %p\n", b));
 }
 
-#define traverse_immobiles(gcMUCK) {                                        \
+#define traverse_immobiles(gcMUCK, set_bt_src) {			    \
     struct immobile_box *ib;                                                \
-    for(ib = immobile_boxes; ib; ib = ib->next)                             \
+    for(ib = immobile_boxes; ib; ib = ib->next) {			    \
+      set_bt_src(ib, BT_IMMOBILE);					    \
       gcMUCK(ib->p);                                                        \
+    }                                                                       \
   }
 
 inline static void mark_immobiles(void)
 {
-  traverse_immobiles(gcMARK);
+  traverse_immobiles(gcMARK, set_backtrace_source);
 }
 
 inline static void repair_immobiles(void)
 {
-  traverse_immobiles(gcFIXUP);
+  traverse_immobiles(gcFIXUP, two_arg_no_op);
 }
 
 /*****************************************************************************/
@@ -882,12 +988,16 @@ inline static void mark_finalizer_structs(void)
   struct finalizer *fnl;
 
   for(fnl = GC_resolve(finalizers); fnl; fnl = GC_resolve(fnl->next)) { 
+    set_backtrace_source(fnl, BT_FINALIZER);
     gcMARK(fnl->data); 
+    set_backtrace_source(&finalizers, BT_ROOT);
     gcMARK(fnl);
   }
   for(fnl = run_queue; fnl; fnl = fnl->next) {
+    set_backtrace_source(fnl, BT_FINALIZER);
     gcMARK(fnl->data);
     gcMARK(fnl->p);
+    set_backtrace_source(&run_queue, BT_ROOT);
     gcMARK(fnl);
   }
 }  
@@ -923,12 +1033,14 @@ inline static void check_finalizers(int level)
       GCDEBUG((DEBUGOUTF, 
 	       "CFNL: Level %i finalizer %p on %p queued for finalization.\n",
 	       work->eager_level, work, work->p));
+      set_backtrace_source(work, BT_FINALIZER);
       gcMARK(work->p);
       if(prev) prev->next = next;
       if(!prev) finalizers = next;
       if(last_in_queue) last_in_queue = last_in_queue->next = work;
       if(!last_in_queue) run_queue = last_in_queue = work;
       work->next = NULL;
+      --num_fnls;
 
       work = next;
     } else { 
@@ -950,6 +1062,7 @@ inline static void do_ordered_level3(void)
       GCDEBUG((DEBUGOUTF,
 	       "LVL3: %p is not marked. Marking payload (%p)\n", 
 	       temp, temp->p));
+      set_backtrace_source(temp, BT_FINALIZER);
       if(temp->tagged) mark_table[*(unsigned short*)temp->p](temp->p);
       if(!temp->tagged) GC_mark_xtagged(temp->p);
     }
@@ -979,8 +1092,10 @@ inline static void mark_weak_finalizer_structs(void)
   struct weak_finalizer *work;
 
   GCDEBUG((DEBUGOUTF, "MARKING WEAK FINALIZERS.\n"));
-  for(work = weak_finalizers; work; work = work->next)
+  for(work = weak_finalizers; work; work = work->next) {
+    set_backtrace_source(&weak_finalizers, BT_ROOT);
     gcMARK(work);
+  }
 }
 
 inline static void repair_weak_finalizer_structs(void)
@@ -1018,7 +1133,10 @@ inline static void reset_weak_finalizers(void)
   struct weak_finalizer *wfnl;
 
   for(wfnl = GC_resolve(weak_finalizers); wfnl; wfnl = GC_resolve(wfnl->next)) {
-    if(marked(wfnl->p)) gcMARK(wfnl->saved); 
+    if(marked(wfnl->p)) {
+      set_backtrace_source(wfnl, BT_WEAKLINK);
+      gcMARK(wfnl->saved); 
+    }
     *(void**)(NUM(GC_resolve(wfnl->p)) + wfnl->offset) = wfnl->saved;
     wfnl->saved = NULL;
   }
@@ -1028,7 +1146,7 @@ inline static void reset_weak_finalizers(void)
 /* weak boxes and arrays                                                     */
 /*****************************************************************************/
 
-static const unsigned short gc_weak_array_tag = 256;
+static unsigned short weak_array_tag;
 static unsigned short weak_box_tag;
 static unsigned short ephemeron_tag;
 
@@ -1478,6 +1596,7 @@ static void propagate_accounting_marks(void)
 
   while(pop_ptr(&p) && !kill_propagation_loop) {
     page = find_page(p);
+    set_backtrace_source(p, page->page_type);
     GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p, ptr %p\n", page, p));
     if(page->big_page)
       mark_acc_big_page(page);
@@ -1662,12 +1781,13 @@ void designate_modified(void *p)
 
 #include "sighand.c"
 
-void GC_init_type_tags(int count, int weakbox, int ephemeron)
+void GC_init_type_tags(int count, int weakbox, int ephemeron, int weakarray)
 {
   static int initialized = 0;
 
   weak_box_tag = weakbox;
   ephemeron_tag = ephemeron;
+  weak_array_tag = weakarray;
 
   if(!initialized) {
     initialized = 1;
@@ -1681,9 +1801,10 @@ void GC_init_type_tags(int count, int weakbox, int ephemeron)
 			   fixup_weak_box, 0, 0);
     GC_register_traversers(ephemeron_tag, size_ephemeron, mark_ephemeron,
 			   fixup_ephemeron, 0, 0);
-    GC_register_traversers(gc_weak_array_tag, size_weak_array, mark_weak_array,
+    GC_register_traversers(weak_array_tag, size_weak_array, mark_weak_array,
 			   fixup_weak_array, 0, 0);
     initialize_signal_handler();
+    GC_add_roots(&park, (char *)&park + sizeof(park) + 1);
   }
 }
 
@@ -1754,6 +1875,8 @@ void GC_mark(const void *const_p)
 	    gen0_big_pages = page->next;
 	  if(page->next) page->next->prev = page->prev;
 
+	  backtrace_new_page(page);
+
 	  page->next = pages[PAGE_BIG]; 
 	  page->prev = NULL;
 	  if(page->next) page->next->prev = page;
@@ -1764,6 +1887,7 @@ void GC_mark(const void *const_p)
 	}
 	
 	page->marked_on = 1;
+	record_backtrace(page, PTR(NUM(page) + HEADER_SIZEB));
 	GCDEBUG((DEBUGOUTF, "Marking %p on big page %p\n", p, page));
 	/* Finally, we want to add this to our mark queue, so we can 
 	   propagate its pointers */
@@ -1788,6 +1912,7 @@ void GC_mark(const void *const_p)
 	    page->marked_on = 1;
 	    page->previous_size = HEADER_SIZEB;
 	    page->live_size += ohead->size;
+	    record_backtrace(page, p);
 	    push_ptr(p);
 	  } else GCDEBUG((DEBUGOUTF, "Not marking %p (it's old; %p / %i)\n",
 			  p, page, page->previous_size));
@@ -1810,8 +1935,8 @@ void GC_mark(const void *const_p)
 	  size = gcWORDS_TO_BYTES(ohead->size);
 
 	  /* search for a page with the space to spare */
-	  while(work && ((work->size + size) >= APAGE_SIZE))
+	  if (work && ((work->size + size) >= APAGE_SIZE))
-	    work = work->next;
+	    work = NULL;
 
 	  /* now either fetch where we're going to put this object or make
 	     a new page if we couldn't find a page with space to spare */
@@ -1826,11 +1951,11 @@ void GC_mark(const void *const_p)
 	    work->page_type = type;
 	    work->size = work->previous_size = HEADER_SIZEB;
 	    work->marked_on = 1;
+	    backtrace_new_page(work);
 	    work->next = pages[type];
 	    work->prev = NULL;
-	    if(work->next) {
+	    if(work->next)
 	      work->next->prev = work;
-	    }
 	    pagemap_add(work);
 	    pages[type] = work;
 	    newplace = PTR(NUM(work) + HEADER_SIZEB);
@@ -1852,6 +1977,9 @@ void GC_mark(const void *const_p)
 	  /* drop the new location of the object into the forwarding space
 	     and into the mark queue */
 	  newplace = PTR(NUM(newplace) + WORD_SIZE);
+	  /* record why we marked this one (if enabled) */
+	  record_backtrace(work, newplace);
+	  /* set forwarding pointer */
 	  GCDEBUG((DEBUGOUTF,"Marking %p (moved to %p on page %p)\n", 
 		   p, newplace, work));
 	  *(void**)p = newplace;
@@ -1873,6 +2001,8 @@ inline static void internal_mark(void *p)
     void **start = PPTR(NUM(page) + HEADER_SIZEB + WORD_SIZE);
     void **end = PPTR(NUM(page) + page->size);
 
+    set_backtrace_source(start, page->page_type);
+
     switch(page->page_type) {
       case PAGE_TAGGED: mark_table[*(unsigned short*)start](start); break;
       case PAGE_ATOMIC: break;
@@ -1888,6 +2018,8 @@ inline static void internal_mark(void *p)
   } else {
     struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE);
     
+    set_backtrace_source(p, info->type);
+
     switch(info->type) {
       case PAGE_TAGGED: mark_table[*(unsigned short*)p](p); break;
       case PAGE_ATOMIC: break;
@@ -1960,7 +2092,7 @@ void GC_fixup(void *pp)
 }
 
 /*****************************************************************************/
-/* garbage collection                                                        */
+/* memory stats and traces                                                   */
 /*****************************************************************************/
 
 /* These collect information about memory usage, for use in GC_dump. */
@@ -1968,23 +2100,117 @@ static unsigned long peak_memory_use = 0;
 static unsigned long num_minor_collects = 0;
 static unsigned long num_major_collects = 0;
 
+#ifdef MZ_GC_BACKTRACE
+# define trace_page_t struct mpage
+# define trace_page_type(page) (page)->page_type
+# define TRACE_PAGE_TAGGED PAGE_TAGGED
+# define TRACE_PAGE_ARRAY PAGE_ARRAY
+# define TRACE_PAGE_TAGGED_ARRAY PAGE_TARRAY
+# define TRACE_PAGE_ATOMIC PAGE_ATOMIC
+# define TRACE_PAGE_XTAGGED PAGE_XTAGGED
+# define TRACE_PAGE_MALLOCFREE PAGE_TYPES
+# define TRACE_PAGE_BAD PAGE_TYPES
+# define trace_page_is_big(page) (page)->big_page
+# define trace_backpointer get_backtrace
+# include "backtrace.c"
+#else
+# define reset_object_traces() /* */
+# define register_traced_object(p) /* */
+# define print_traced_objects(x, y, q, z) /* */
+#endif
+
+#define MAX_DUMP_TAG 256
+
 static char *type_name[PAGE_TYPES] = { "tagged", "atomic", "array",
 				       "tagged array", "xtagged", "big" };
-void GC_dump(void)
+
+void GC_dump_with_traces(int flags,
+			 GC_get_type_name_proc get_type_name,
+			 GC_get_xtagged_name_proc get_xtagged_name,
+			 GC_for_each_found_proc for_each_found,
+			 short trace_for_tag,
+			 GC_print_tagged_value_proc print_tagged_value,
+			 int path_length_limit)
 {
   struct mpage *page;
   int i;
+  static unsigned long counts[MAX_DUMP_TAG], sizes[MAX_DUMP_TAG];
+
+  reset_object_traces();
+  if (for_each_found)
+    avoid_collection++;
+
+  /* Traverse tagged pages to count objects: */
+  for (i = 0; i < MAX_DUMP_TAG; i++) {
+    counts[i] = sizes[i] = 0;
+  }
+  for (page = pages[PAGE_TAGGED]; page; page = page->next) {
+    void **start = PPTR(NUM(page) + HEADER_SIZEB);
+    void **end = PPTR(NUM(page) + page->size);
+    
+    while(start < end) {
+      struct objhead *info = (struct objhead *)start;
+      if(!info->dead) {
+	unsigned short tag = *(unsigned short *)(start + 1);
+	if (tag < MAX_DUMP_TAG) {
+	  counts[tag]++;
+	  sizes[tag] += info->size;
+	}
+	if (tag == trace_for_tag) {
+	  register_traced_object(start + 1);
+	  if (for_each_found)
+	    for_each_found(start + 1);
+	}
+      }
+      start += info->size;
+    }
+  }
+  for (page = pages[PAGE_BIG]; page; page = page->next) {
+    if (page->page_type == PAGE_TAGGED) {
+      void **start = PPTR(NUM(page) + HEADER_SIZEB);
+      unsigned short tag = *(unsigned short *)(start + 1);
+      if (tag < MAX_DUMP_TAG) {
+	counts[tag]++;
+	sizes[tag] += page->size;
+      }
+      if ((tag == trace_for_tag)
+	  || (tag == -trace_for_tag)) {
+	register_traced_object(start + 1);
+	if (for_each_found)
+	  for_each_found(start + 1);
+      }
+    }
+  }
+
+  GCPRINT(GCOUTF, "Begin MzScheme3m\n");
+  for (i = 0; i < MAX_DUMP_TAG; i++) {
+    if (counts[i]) {
+      char *tn, buf[256];
+      if (get_type_name)
+	tn = get_type_name((Type_Tag)i);
+      else
+	tn = NULL;
+      if (!tn) {
+	sprintf(buf, "unknown,%d", i);
+	tn = buf;
+      }
+      GCPRINT(GCOUTF, "  %20.20s: %10ld %10ld\n", tn, counts[i], gcWORDS_TO_BYTES(sizes[i]));
+    }
+  }
+  GCPRINT(GCOUTF, "End MzScheme3m\n");
 
   GCWARN((GCOUTF, "Generation 0: %li of %li bytes used\n",
 	  gen0_current_size, gen0_max_size));
   
   for(i = 0; i < PAGE_TYPES; i++) {
-    unsigned long total_use = 0;
+    unsigned long total_use = 0, count = 0;
     
-    for(page = pages[i]; page; page = page->next)
+    for(page = pages[i]; page; page = page->next) {
       total_use += page->size;
-    GCWARN((GCOUTF, "Generation 1 [%s]: %li bytes used\n", 
+      count++;
-	    type_name[i], total_use));
+    }
+    GCWARN((GCOUTF, "Generation 1 [%s]: %li bytes used in %li pages\n", 
+	    type_name[i], total_use, count));
   }
 
   GCWARN((GCOUTF,"\n"));
@@ -1992,8 +2218,47 @@ void GC_dump(void)
   GCWARN((GCOUTF,"Peak memory use after a collection: %li\n",peak_memory_use));
   GCWARN((GCOUTF,"# of major collections: %li\n", num_major_collects));
   GCWARN((GCOUTF,"# of minor collections: %li\n", num_minor_collects));
+  GCWARN((GCOUTF,"# of installed finalizers: %i\n", num_fnls));
+  GCWARN((GCOUTF,"# of traced ephemerons: %i\n", num_last_seen_ephemerons));
+
+  if (flags & GC_DUMP_SHOW_TRACE) {
+    print_traced_objects(path_length_limit, get_type_name, get_xtagged_name, print_tagged_value);
+  }
+
+  if (for_each_found)
+    --avoid_collection;
 }
 
+void GC_dump(void)
+{
+  GC_dump_with_traces(0, NULL, NULL, NULL, 0, NULL, 0);
+}
+
+#ifdef MZ_GC_BACKTRACE
+
+int GC_is_tagged(void *p)
+{
+  struct mpage *page;
+  page = find_page(p);
+  return page && (page->page_type == PAGE_TAGGED);
+}
+
+int GC_is_tagged_start(void *p)
+{
+  return 0;
+}
+
+void *GC_next_tagged_start(void *p)
+{
+  return NULL;
+}
+
+#endif
+
+/*****************************************************************************/
+/* garbage collection                                                        */
+/*****************************************************************************/
+
 static void prepare_pages_for_collection(void)
 {
   struct mpage *work;
@@ -2075,15 +2340,44 @@ static void mark_backpointers(void)
   }
 }
 
-#define should_compact_page(lsize,tsize) ((lsize << 2) < tsize)
+struct mpage *allocate_compact_target(struct mpage *work)
+{
+  struct mpage *npage;
+
+  npage = malloc_dirty_pages(APAGE_SIZE, APAGE_SIZE);
+  npage->previous_size = npage->size = HEADER_SIZEB;
+  npage->generation = 1;
+  npage->back_pointers = 0;
+  npage->big_page = 0;
+  npage->page_type = work->page_type;
+  npage->marked_on = 1;
+  backtrace_new_page(npage);
+  /* Link in this new replacement page */
+  npage->prev = work;
+  npage->next = work->next;
+  work->next = npage;
+  if (npage->next)
+    npage->next->prev = npage;
+  
+  return npage;
+}
+
+/* Compact when 1/4 of the space between objects is unused: */
+#define should_compact_page(lsize,tsize) (lsize < (tsize - HEADER_SIZEB - (APAGE_SIZE >> 2)))
 
 inline static void do_heap_compact(void)
 {
-  int compactable_pages_left = MAX_PAGES_TO_COMPACT; 
   int i;
 
   for(i = 0; i < PAGE_BIG; i++) {
-    struct mpage *work = pages[i], *prev = NULL;
+    struct mpage *work = pages[i], *prev, *npage;
+
+    /* Start from the end: */
+    if (work) {
+      while (work->next)
+	work = work->next;
+    }
+    npage = work;
 
     while(work) {
       if(work->marked_on && !work->has_new) {
@@ -2091,66 +2385,70 @@ inline static void do_heap_compact(void)
 	if(should_compact_page(gcWORDS_TO_BYTES(work->live_size),work->size)) {
 	  void **start = PPTR(NUM(work) + HEADER_SIZEB);
 	  void **end = PPTR(NUM(work) + work->size);
-	  struct mpage *npage = malloc_dirty_pages(APAGE_SIZE, APAGE_SIZE);
 	  void **newplace;
+	  unsigned long avail;
 
 	  GCDEBUG((DEBUGOUTF, "Compacting page %p: new version at %p\n", 
 		   work, npage));
-	  /* Set up the basic page parameters */
+
-	  /* FIXME: ANY OTHER MAINTANENCE */
+	  if (npage == work) {
-	  npage->previous_size = npage->size = HEADER_SIZEB;
+	    /* Need to insert a page: */
-	  npage->generation = 1;
+	    npage = allocate_compact_target(work);
-	  npage->back_pointers = 0;
+	  }
-	  npage->big_page = 0;
+	  avail = gcBYTES_TO_WORDS(APAGE_SIZE - npage->size);
-	  npage->page_type = work->page_type;
+	  newplace = PPTR(NUM(npage) + npage->size);
-	  npage->marked_on = 1;
-	  npage->mirror = work;
-	  /* Link in this new replacement page */
-	  if(prev) prev->next = work->next; else pages[i] = work->next;
-	  if(work->next) work->next->prev = prev;
-	  npage->prev = NULL;
-	  npage->next = pages[i];
-	  if(npage->next) npage->next->prev = npage;
-	  pages[i] = npage;
-	  if(!prev) prev = npage;
-	  /* set up the traversal pointers */
-	  newplace = PPTR(NUM(npage) + HEADER_SIZEB);
-	  start = PPTR(NUM(work) + HEADER_SIZEB);
-	  end = PPTR(NUM(work) + work->size);
 
 	  while(start < end) {
-	    struct objhead *info = (struct objhead *)start;
+	    struct objhead *info;
-	    
+
+	    info = (struct objhead *)start;
+
 	    if(info->mark) {
+	      while (avail <= info->size) {
+		npage->size = NUM(newplace) - NUM(npage);
+		do {
+		  npage = npage->prev;
+		} while (!npage->marked_on || npage->has_new);
+		if (npage == work)
+		  npage = allocate_compact_target(work);
+		avail = gcBYTES_TO_WORDS(APAGE_SIZE - npage->size);
+		newplace = PPTR(NUM(npage) + npage->size);
+	      }
+
 	      GCDEBUG((DEBUGOUTF,"Moving size %i object from %p to %p\n",
 		       gcWORDS_TO_BYTES(info->size), start+1, newplace+1));
 	      memcpy(newplace, start, gcWORDS_TO_BYTES(info->size));
 	      info->moved = 1;
 	      *(PPTR(NUM(start) + WORD_SIZE)) = PTR(NUM(newplace) + WORD_SIZE);
+	      copy_backtrace_source(npage, newplace, work, start);
 	      newplace += info->size;
+	      avail -= info->size;
 	    }
-	    start += info->size;
+	    start += info->size;	    
 	  }
+	  npage->size = NUM(newplace) - NUM(npage);
+
+	  prev = work->prev;
+
+	  if(prev) prev->next = work->next; else pages[i] = work->next;
+	  if(work->next) work->next->prev = prev;
+
+	  work->next = release_page;
+	  release_page = work;
 
 	  /* add the old page to the page map so fixups can find forwards */
-	  pagemap_add(npage->mirror);
+	  pagemap_add(work);
-	  /* set the size */
+
-	  npage->size = NUM(newplace) - NUM(npage);
+	  work = prev;
-	  compactable_pages_left--;
-	  if(!compactable_pages_left)
-	    return;
-	  work = work->next;
 	} else { 
-	  prev = work;
+	  work = work->prev;
-	  work = work->next;
 	}
       } else {
 	/* Much as I'd like to free pages here, so that we can just have the
 	   relevant pages cached, that causes problems. Specifically, if a
-	   weak whatever has a pointer into this pace, we *cannot* reuse it
+	   weak whatever has a pointer into this page, we *cannot* reuse it
 	   yet, as we need that information to fix those bits later. */
-	prev = work;
+	work = work->prev;
-	work = work->next;
       }
     }
   }
@@ -2278,7 +2576,7 @@ static void clean_up_heap(void)
   for(work = gen0_big_pages; work; work = prev) {
     prev = work->next;
     pagemap_remove(work);
-    free_pages(work, work->size);
+    free_pages(work, round_to_apage_size(work->size));
   }
 
   for(i = 0; i < PAGE_TYPES; i++) {
@@ -2293,15 +2591,11 @@ static void clean_up_heap(void)
 	  if(prev) prev->next = next; else pages[i] = next;
 	  if(work->next) work->next->prev = prev;
 	  pagemap_remove(work);
-	  free_pages(work, work->big_page ? work->size : APAGE_SIZE);
+	  free_backtrace(work);
+	  free_pages(work, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE);
 	  work = next;
 	} else {
 	  pagemap_add(work);
-	  if(work->mirror) {
-	    pagemap_remove(work->mirror);
-	    free_pages(work->mirror, APAGE_SIZE);
-	    work->mirror = NULL;
-	  }
 	  work->back_pointers = work->marked_on = 0;
 	  prev = work; 
 	  work = work->next;
@@ -2318,6 +2612,15 @@ static void clean_up_heap(void)
     for(work = pages[i]; work; work = work->next)
       memory_in_use += work->size;
   }
+  
+  /* Free pages vacated by compaction: */
+  while (release_page) {
+    prev = release_page->next;
+    pagemap_remove(release_page);
+    free_backtrace(release_page);
+    free_pages(release_page, APAGE_SIZE);
+    release_page = prev;
+  }
 }
 
 static void protect_old_pages(void)
@@ -2360,7 +2663,7 @@ static void garbage_collect(int force_full)
      half the available memory */
   in_unsafe_allocation_mode = 1;
   unsafe_allocation_abort = gc_overmem_abort;
-  
+
   /* inform the system (if it wants us to) that we're starting collection */
   if(GC_collect_start_callback)
     GC_collect_start_callback();
@@ -2379,7 +2682,7 @@ static void garbage_collect(int force_full)
 
   /* now propagate/repair the marks we got from these roots, and do the
      finalizer passes */
-  mark_ready_ephemerons(); propagate_marks();
+  propagate_marks(); mark_ready_ephemerons(); propagate_marks(); 
   check_finalizers(1); mark_ready_ephemerons(); propagate_marks();
   check_finalizers(2); mark_ready_ephemerons(); propagate_marks();
   if(gc_full) zero_weak_finalizers();

src/mzscheme/gc2/vm_osx.c

@@ -221,7 +221,7 @@ kern_return_t catch_exception_raise(mach_port_t port,
 				    exception_data_t exception_data,
 				    mach_msg_type_number_t data_count)
 {
-#if  GENERATIONS
+#if GENERATIONS
   /* kernel return value is in exception_data[0], faulting address in
      exception_data[1] */
   if(exception_data[0] == KERN_PROTECTION_FAILURE) {

src/mzscheme/gc2/weak.c

@@ -10,8 +10,9 @@
       GC_malloc_ephemeron
       size_ephemeron, mark_ephemeron, fixup_ephemeron
       init_ephemerons mark_ready_ephemerons zero_remaining_ephemerons
+      num_last_seen_ephemerons
    Requires:
-      gc_weak_array_tag
+      weak_array_tag
       weak_box_tag
       ephemeron_tag
       is_marked(p)
@@ -107,7 +108,7 @@ void *GC_malloc_weak_array(size_t size_in_bytes, void *replace_val)
   replace_val = park[0];
   park[0] = NULL;
 
-  w->type = gc_weak_array_tag;
+  w->type = weak_array_tag;
   w->replace_val = replace_val;
   w->count = (size_in_bytes >> LOG_WORD_SIZE);
   
@@ -246,6 +247,8 @@ typedef struct GC_Ephemeron {
 
 static GC_Ephemeron *ephemerons;
 
+static int num_last_seen_ephemerons = 0;
+
 static int size_ephemeron(void *p)
 {
   return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron));
@@ -297,6 +300,7 @@ void *GC_malloc_ephemeron(void *k, void *v)
 
 void init_ephemerons() {
   ephemerons = NULL;
+  num_last_seen_ephemerons = 0;
 }
 
 static void mark_ready_ephemerons()
@@ -307,6 +311,7 @@ static void mark_ready_ephemerons()
     next = eph->next;
     if (is_marked(eph->key)) {
       gcMARK(eph->val);
+      num_last_seen_ephemerons++;
     } else {
       eph->next = waiting;
       waiting = eph;

src/mzscheme/gc2/xform.ss

@@ -57,7 +57,7 @@
       (current-library-collection-paths (list (build-path (current-directory) "xform-collects")))
       
       (error-print-width 100)
-      
+
       (dynamic-require '(lib "xform-mod.ss" "xform") #f))
 
     ;; Otherwise, we assume that it's ok to use the collects

src/mzscheme/main.c

@@ -267,7 +267,7 @@ static int main_after_dlls(int argc, MAIN_char **MAIN_argv)
 
 #if defined(MZ_PRECISE_GC)
   stack_start = (void *)&__gc_var_stack__;
-  GC_init_type_tags(_scheme_last_type_, scheme_weak_box_type, scheme_ephemeron_type);
+  GC_init_type_tags(_scheme_last_type_, scheme_weak_box_type, scheme_ephemeron_type, scheme_rt_weak_array);
 #endif
 
   scheme_set_stack_base(stack_start, 1);

src/mzscheme/src/salloc.c

@@ -425,6 +425,8 @@ typedef struct {
 
 #ifdef MZ_PRECISE_GC
 
+#include "../gc2/gc2_dump.h"
+
 START_XFORM_SKIP;
 
 #define MARKS_FOR_SALLOC_C
@@ -920,7 +922,7 @@ static void count_managed(Scheme_Custodian *m, int *c, int *a, int *u, int *t,
 #endif
 
 #if defined(MZ_PRECISE_GC)
-# ifdef COMPACT_BACKTRACE_GC
+# ifdef MZ_GC_BACKTRACE
 #  define MZ_PRECISE_GC_TRACE 1
 # else
 #  define MZ_PRECISE_GC_TRACE 0
@@ -930,12 +932,7 @@ static void count_managed(Scheme_Custodian *m, int *c, int *a, int *u, int *t,
 #endif
 
 #if MZ_PRECISE_GC_TRACE
-extern int GC_show_trace;
+char *(*GC_get_xtagged_name)(void *p) = NULL;
-extern int GC_show_finals;
-extern int GC_trace_for_tag;
-extern int GC_path_length_limit;
-extern void (*GC_for_each_found)(void *p);
-
 static Scheme_Object *cons_accum_result;
 static void cons_onto_list(void *p)
 {
@@ -947,9 +944,6 @@ static void cons_onto_list(void *p)
 
 # ifdef MZ_PRECISE_GC
 START_XFORM_SKIP;
-extern int GC_is_tagged(void *p);
-extern int GC_is_tagged_start(void *p);
-extern void *GC_next_tagged_start(void *p);
 #  ifdef DOS_FILE_SYSTEM
 extern void gc_fprintf(int ignored, const char *c, ...);
 #   define object_console_printf gc_fprintf
@@ -976,7 +970,7 @@ static int check_home(Scheme_Object *o)
 #endif
 }
 
-void scheme_print_tagged_value(const char *prefix, 
+static void print_tagged_value(const char *prefix, 
 			       void *v, int xtagged, unsigned long diff, int max_w,
 			       const char *suffix)
 {
@@ -1134,6 +1128,19 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 #ifdef USE_TAGGED_ALLOCATION
   void *initial_trace_root = NULL;
   int (*inital_root_skip)(void *, size_t) = NULL;
+#endif
+#if MZ_PRECISE_GC_TRACE
+  int trace_for_tag = 0;
+  int flags = 0;
+  int path_length_limit = 1000;
+  GC_for_each_found_proc for_each_found = NULL;
+#else
+# define flags 0
+# define trace_for_tag 0
+# define path_length_limit 1000
+# define for_each_found NULL
+# define GC_get_xtagged_name NULL
+# define print_tagged_value NULL
 #endif
 
   scheme_start_atomic();
@@ -1342,10 +1349,6 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 #else
 
 # if MZ_PRECISE_GC_TRACE
-  GC_trace_for_tag = -1;
-  GC_show_trace = 0;
-  GC_show_finals = 0;
-  GC_for_each_found = NULL;
   cons_accum_result = scheme_void;
   if (c && SCHEME_SYMBOLP(p[0])) {
     Scheme_Object *sym;
@@ -1361,14 +1364,14 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
       void *tn;
       tn = scheme_get_type_name(i);
       if (tn && !strcmp(tn, s)) {
-	GC_trace_for_tag = i;
+	trace_for_tag = i;
-	GC_show_trace = 1;
+	flags |= GC_DUMP_SHOW_TRACE;
 	break;
       }
     }
 
     if (!strcmp("fnl", s))
-      GC_show_finals = 1;
+      flags |= GC_DUMP_SHOW_FINALS;
 
     if (!strcmp("peek", s) && (c == 3)) {
       long n;
@@ -1399,21 +1402,30 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
       return scheme_make_integer_value((long)p[1]);
     }
   } else if (SCHEME_INTP(p[0])) {
-    GC_trace_for_tag = SCHEME_INT_VAL(p[0]);
+    trace_for_tag = SCHEME_INT_VAL(p[0]);
-    GC_show_trace = 1;
+    flags |= GC_DUMP_SHOW_TRACE;
   }
   if ((c > 1) && SCHEME_INTP(p[1]))
-    GC_path_length_limit = SCHEME_INT_VAL(p[1]);
+    path_length_limit = SCHEME_INT_VAL(p[1]);
   else if ((c > 1) && SCHEME_SYMBOLP(p[1]) && !strcmp("cons", SCHEME_SYM_VAL(p[1]))) {
-    GC_for_each_found = cons_onto_list;
+    for_each_found = cons_onto_list;
     cons_accum_result = scheme_null;
-    GC_show_trace = 0;
+    flags -= (flags & GC_DUMP_SHOW_TRACE);
-  } else
+  }
-    GC_path_length_limit = 1000;
   scheme_console_printf("Begin Dump\n");
 #endif
 
+# ifdef MZ_PRECISE_GC
+  GC_dump_with_traces(flags, 
+		      scheme_get_type_name,
+		      GC_get_xtagged_name,
+		      for_each_found,
+		      trace_for_tag,
+		      print_tagged_value,
+		      path_length_limit);
+# else
   GC_dump();
+# endif
 #endif
 
   if (scheme_external_dump_info)
@@ -1455,9 +1467,9 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 		|| (home == tagged_atomic)
 		|| (home == tagged_uncollectable)
 		|| (home == tagged_eternal))) {
-	  scheme_print_tagged_value("\n  ->", v, 0, diff, max_w, "");
+	  print_tagged_value("\n  ->", v, 0, diff, max_w, "");
 	} else
-	  scheme_print_tagged_value("\n  ->", v, 1, diff, max_w, "");
+	  print_tagged_value("\n  ->", v, 1, diff, max_w, "");
       }
       scheme_console_printf("\n");
     }

src/mzscheme/src/stxobj.c

@@ -253,7 +253,7 @@ typedef struct {
   int pos;
 } Wrap_Pos;
 
-static void WRAP_POS_SET_FIRST(Wrap_Pos *w)
+XFORM_NONGCING static void WRAP_POS_SET_FIRST(Wrap_Pos *w)
 {
   if (!SCHEME_NULLP(w->l)) {
     Scheme_Object *a;
@@ -269,7 +269,7 @@ static void WRAP_POS_SET_FIRST(Wrap_Pos *w)
   }
 }
 
-static
+XFORM_NONGCING static
 #ifndef NO_INLINE_KEYWORD
 MSC_IZE(inline)
 #endif
@@ -309,7 +309,7 @@ void DO_WRAP_POS_INC(Wrap_Pos *w)
 
 /* Walking backwards through one chunk: */
 
-static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k)
+XFORM_NONGCING static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k)
 {
   Scheme_Object *a;
   a = SCHEME_CAR(k);

src/mzscheme/src/stypes.h

@@ -156,66 +156,68 @@ enum {
 #ifdef MZTAG_REQUIRED
   _scheme_last_normal_type_,            /* 137 */
 
-  scheme_rt_comp_env,                   /* 138 */
+  scheme_rt_weak_array,                 /* 138 */
-  scheme_rt_constant_binding,           /* 139 */
+
-  scheme_rt_resolve_info,               /* 140 */
+  scheme_rt_comp_env,                   /* 139 */
-  scheme_rt_optimize_info,              /* 141 */
+  scheme_rt_constant_binding,           /* 140 */
-  scheme_rt_compile_info,               /* 142 */
+  scheme_rt_resolve_info,               /* 141 */
-  scheme_rt_cont_mark,                  /* 143 */
+  scheme_rt_optimize_info,              /* 142 */
-  scheme_rt_saved_stack,                /* 144 */
+  scheme_rt_compile_info,               /* 143 */
-  scheme_rt_reply_item,                 /* 145 */
+  scheme_rt_cont_mark,                  /* 144 */
-  scheme_rt_closure_info,               /* 146 */
+  scheme_rt_saved_stack,                /* 145 */
-  scheme_rt_overflow,                   /* 147 */
+  scheme_rt_reply_item,                 /* 146 */
-  scheme_rt_dyn_wind_cell,              /* 148 */
+  scheme_rt_closure_info,               /* 147 */
-  scheme_rt_dyn_wind_info,              /* 149 */
+  scheme_rt_overflow,                   /* 148 */
-  scheme_rt_dyn_wind,                   /* 150 */
+  scheme_rt_dyn_wind_cell,              /* 149 */
-  scheme_rt_dup_check,                  /* 151 */
+  scheme_rt_dyn_wind_info,              /* 150 */
-  scheme_rt_thread_memory,              /* 152 */
+  scheme_rt_dyn_wind,                   /* 151 */
-  scheme_rt_input_file,                 /* 153 */
+  scheme_rt_dup_check,                  /* 152 */
-  scheme_rt_input_fd,                   /* 154 */
+  scheme_rt_thread_memory,              /* 153 */
-  scheme_rt_oskit_console_input,        /* 155 */
+  scheme_rt_input_file,                 /* 154 */
-  scheme_rt_tested_input_file,          /* 156 */
+  scheme_rt_input_fd,                   /* 155 */
-  scheme_rt_tested_output_file,         /* 157 */
+  scheme_rt_oskit_console_input,        /* 156 */
-  scheme_rt_indexed_string,             /* 158 */
+  scheme_rt_tested_input_file,          /* 157 */
-  scheme_rt_output_file,                /* 159 */
+  scheme_rt_tested_output_file,         /* 158 */
-  scheme_rt_load_handler_data,          /* 160 */
+  scheme_rt_indexed_string,             /* 159 */
-  scheme_rt_pipe,                       /* 161 */
+  scheme_rt_output_file,                /* 160 */
-  scheme_rt_beos_process,               /* 162 */
+  scheme_rt_load_handler_data,          /* 161 */
-  scheme_rt_system_child,               /* 163 */
+  scheme_rt_pipe,                       /* 162 */
-  scheme_rt_tcp,                        /* 164 */
+  scheme_rt_beos_process,               /* 163 */
-  scheme_rt_write_data,                 /* 165 */
+  scheme_rt_system_child,               /* 164 */
-  scheme_rt_tcp_select_info,            /* 166 */
+  scheme_rt_tcp,                        /* 165 */
-  scheme_rt_namespace_option,           /* 167 */
+  scheme_rt_write_data,                 /* 166 */
-  scheme_rt_param_data,                 /* 168 */
+  scheme_rt_tcp_select_info,            /* 167 */
-  scheme_rt_will,                       /* 169 */
+  scheme_rt_namespace_option,           /* 168 */
-  scheme_rt_will_registration,          /* 170 */
+  scheme_rt_param_data,                 /* 169 */
-  scheme_rt_struct_proc_info,           /* 171 */
+  scheme_rt_will,                       /* 170 */
-  scheme_rt_linker_name,                /* 172 */
+  scheme_rt_will_registration,          /* 171 */
-  scheme_rt_param_map,                  /* 173 */
+  scheme_rt_struct_proc_info,           /* 172 */
-  scheme_rt_finalization,               /* 174 */
+  scheme_rt_linker_name,                /* 173 */
-  scheme_rt_finalizations,              /* 175 */
+  scheme_rt_param_map,                  /* 174 */
-  scheme_rt_cpp_object,                 /* 176 */
+  scheme_rt_finalization,               /* 175 */
-  scheme_rt_cpp_array_object,           /* 177 */
+  scheme_rt_finalizations,              /* 176 */
-  scheme_rt_stack_object,               /* 178 */
+  scheme_rt_cpp_object,                 /* 177 */
-  scheme_rt_preallocated_object,        /* 179 */
+  scheme_rt_cpp_array_object,           /* 178 */
-  scheme_thread_hop_type,               /* 180 */
+  scheme_rt_stack_object,               /* 179 */
-  scheme_rt_srcloc,                     /* 181 */
+  scheme_rt_preallocated_object,        /* 180 */
-  scheme_rt_evt,                        /* 182 */
+  scheme_thread_hop_type,               /* 181 */
-  scheme_rt_syncing,                    /* 183 */
+  scheme_rt_srcloc,                     /* 182 */
-  scheme_rt_comp_prefix,                /* 184 */
+  scheme_rt_evt,                        /* 183 */
-  scheme_rt_user_input,                 /* 185 */
+  scheme_rt_syncing,                    /* 184 */
-  scheme_rt_user_output,                /* 186 */
+  scheme_rt_comp_prefix,                /* 185 */
-  scheme_rt_compact_port,               /* 187 */
+  scheme_rt_user_input,                 /* 186 */
-  scheme_rt_read_special_dw,            /* 188 */
+  scheme_rt_user_output,                /* 187 */
-  scheme_rt_regwork,                    /* 189 */
+  scheme_rt_compact_port,               /* 188 */
-  scheme_rt_buf_holder,                 /* 190 */
+  scheme_rt_read_special_dw,            /* 189 */
-  scheme_rt_parameterization,           /* 191 */
+  scheme_rt_regwork,                    /* 190 */
-  scheme_rt_print_params,               /* 192 */
+  scheme_rt_buf_holder,                 /* 191 */
-  scheme_rt_read_params,                /* 193 */
+  scheme_rt_parameterization,           /* 192 */
-  scheme_rt_native_code,                /* 194 */
+  scheme_rt_print_params,               /* 193 */
-  scheme_rt_native_code_plus_case,      /* 195 */
+  scheme_rt_read_params,                /* 194 */
-  scheme_rt_jitter_data,                /* 196 */
+  scheme_rt_native_code,                /* 195 */
-  scheme_rt_module_exports,             /* 197 */
+  scheme_rt_native_code_plus_case,      /* 196 */
+  scheme_rt_jitter_data,                /* 197 */
+  scheme_rt_module_exports,             /* 198 */
 #endif
 
   _scheme_last_type_

src/wxmac/include/base/common.h

@@ -359,4 +359,6 @@ extern CGrafPtr wxGetGrafPtr(void);
 #define wheelEvt 43
 #define mouseMenuDown 44
 
+#include "wx_obj.h"
+
 #endif // wxb_commonh

src/wxmac/include/base/wx_obj.h

@@ -11,8 +11,6 @@
 #ifndef wxb_objh
 #define wxb_objh
 
-#include "common.h"
-
 #ifdef IN_CPROTO
 typedef       void    *wxObject ;
 #else

src/wxmac/src/base/wb_obj.cc

@@ -14,7 +14,7 @@
 #endif
 #endif
 
-#include "wx_obj.h"
+#include "common.h"
 #include "wx_types.h"
 
 int wx_object_count;

src/wxmac/src/base/wb_types.cc

@@ -14,6 +14,7 @@
 #endif
 #endif
 
+#include "common.h"
 #include "wx_utils.h"
 #include "wx_types.h"
 

src/wxmac/src/mac/wxBorderArea.cc

@@ -8,6 +8,7 @@
 // Copyright:  (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved.
 ///////////////////////////////////////////////////////////////////////////////
 
+#include "common.h"
 #include "wxBorderArea.h"
 #include "wxRectBorder.h"
 

src/wxmac/src/mac/wxLabelArea.cc

@@ -8,6 +8,7 @@
 // Copyright:  (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved.
 ///////////////////////////////////////////////////////////////////////////////
 
+#include "common.h"
 #include "wxLabelArea.h"
 #include "wx_messg.h"
 #include "wx_gdi.h"

src/wxmac/src/mac/wxMacDC.cc

@@ -9,6 +9,7 @@
 ///////////////////////////////////////////////////////////////////////////////
 
 
+#include "common.h"
 #include "wx_obj.h"
 #include "wxMacDC.h"
 

src/wxmac/src/mac/wxScrollArea.cc

@@ -8,6 +8,7 @@
 // Copyright:  (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved.
 ///////////////////////////////////////////////////////////////////////////////
 
+#include "common.h"
 #include "wxScrollArea.h"
 #include "wx_sbar.h"
 #include "wx_utils.h"

src/wxmac/src/mac/wx_area.cc

@@ -8,6 +8,7 @@
 // Copyright:  (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved.
 ///////////////////////////////////////////////////////////////////////////////
 
+#include "common.h"
 #include "wx_area.h"
 #include "wx_win.h"
 #include "wx_frame.h"

src/wxmac/src/mac/wx_dc.cc

@@ -8,9 +8,7 @@
 // Copyright:  (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved.
 ///////////////////////////////////////////////////////////////////////////////
 
-#ifndef WX_CARBON
+#include "common.h"
-# include <QuickDraw.h>
-#endif
 #include "wx_gdi.h"
 #include "wx_dc.h"
 

src/wxmac/src/mac/wximgfil.cc

@@ -10,6 +10,7 @@
 // not responsible for what this might do to your macintosh, use at your own risk
 // sorry I do not have time to add more comments, but hope this is of some use
 
+#include "common.h"
 #include "wx_gdi.h"
 #include "wx_canvs.h"
 #include "wx_dc.h"

src/wxwindow/src/msw/wx_main.cxx

@@ -196,7 +196,7 @@ int wxWinMain(int wm_is_mred,
 
 #if defined(MZ_PRECISE_GC)
   mzscheme_stack_start = (void *)&__gc_var_stack__;
-  GC_init_type_tags(_scheme_last_type_, scheme_weak_box_type, scheme_ephemeron_type);
+  GC_init_type_tags(_scheme_last_type_, scheme_weak_box_type, scheme_ephemeron_type, scheme_rt_weak_array);
 #endif
 
   scheme_set_stack_base(mzscheme_stack_start, 1);