301.6

svn: r2272

src/a-list/c-headers/QDDrawingState.h

@@ -30,7 +30,6 @@ typedef struct {
 #if ALIST_USEAPPEARANCEMGR && TARGET_RT_MAC_CFM
 	ThemeDrawingState	themeState;		/* This is only needed if we're running under CFM. */
 #endif
-/*	PixPatHandle		backPixPatH, penPixPatH;		/* These may still memory leak like a sieve if you have patterns. */
 	PenState			penState;
 	RGBColor			backColor, foreColor;
 	TextStyle			textStyle;

src/mzscheme/gc2/Makefile.in

@@ -38,6 +38,7 @@ OBJS =  salloc.@LTO@ \
 	fun.@LTO@ \
 	hash.@LTO@ \
 	image.@LTO@ \
+	jit.@LTO@ \
 	list.@LTO@ \
 	module.@LTO@ \
 	network.@LTO@ \
@@ -78,6 +79,7 @@ XSRCS = $(XSRCDIR)/salloc.c \
 	$(XSRCDIR)/fun.c \
 	$(XSRCDIR)/hash.c \
 	$(XSRCDIR)/image.c \
+	$(XSRCDIR)/jit.c \
 	$(XSRCDIR)/list.c \
 	$(XSRCDIR)/module.c \
 	$(XSRCDIR)/network.c \
@@ -144,6 +146,8 @@ $(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP)
 	$(XFORM) $(XSRCDIR)/hash.c $(SRCDIR)/hash.c
 $(XSRCDIR)/image.c: ../src/image.@LTO@ $(XFORMDEP)
 	$(XFORM) $(XSRCDIR)/image.c $(SRCDIR)/image.c
+$(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP)
+	$(XFORM) $(XSRCDIR)/jit.c $(SRCDIR)/jit.c
 $(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP)
 	$(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c
 $(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP)
@@ -224,6 +228,8 @@ hash.@LTO@: $(XSRCDIR)/hash.c
 	$(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@
 image.@LTO@: $(XSRCDIR)/image.c
 	$(CC) $(CFLAGS) -c $(XSRCDIR)/image.c -o image.@LTO@
+jit.@LTO@: $(XSRCDIR)/jit.c
+	$(CC) $(CFLAGS) -c $(XSRCDIR)/jit.c -o jit.@LTO@
 list.@LTO@: $(XSRCDIR)/list.c
 	$(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@
 module.@LTO@: $(XSRCDIR)/module.c
@@ -277,7 +283,7 @@ main.@LTO@: $(XSRCDIR)/main.c
 
 gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/compact.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
        $(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/alloc_cache.c $(srcdir)/my_qsort.c \
-       $(srcdir)/weak.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
+       $(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
 	$(CC) $(CFLAGS) -c $(srcdir)/gc2.c -o gc2.@LTO@
 
 FOREIGN_OBJS = ../../foreign/gcc/libffi/src/*.@LTO@ ../../foreign/gcc/libffi/src/*/*.@LTO@

src/mzscheme/gc2/compact.c

@@ -370,7 +370,6 @@ static long mark_stackoflw;
 #endif
 
 static int fnl_weak_link_count;
-static int num_fnls;
 
 static int ran_final;
 static int running_finals;
@@ -488,7 +487,7 @@ void GC_register_traversers(Type_Tag tag, Size_Proc size, Mark_Proc mark, Fixup_
 /*                               root table                                   */
 /******************************************************************************/
 
-#include "roots.inc"
+#include "roots.c"
 
 void GC_register_thread(void *p, void *c)
 {
@@ -566,19 +565,16 @@ static int is_marked(void *p);
 /*                             finalization                                   */
 /******************************************************************************/
 
-typedef struct Fnl {
+static int is_finalizable_page(void *p)
-  char eager_level;
+{
-  char tagged;
+  MPage *page;
-  void *p;
+  page = find_page(p);
-  void (*f)(void *p, void *data);
+  return page && page->type;
-  void *data;
+}
-#if CHECKS
-  long size;
-#endif
-  struct Fnl *next;
-} Fnl;
 
-static Fnl *fnls, *run_queue, *last_in_queue;
+#include "fnls.c"
+
+static Fnl *run_queue, *last_in_queue;
 
 static void mark_finalizer(Fnl *fnl)
 {
@@ -618,102 +614,6 @@ static void fixup_finalizer(Fnl *fnl)
 #endif
 }
 
-void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *data), 
-		      void *data, void (**oldf)(void *p, void *data), 
-		      void **olddata)
-{
-  Fnl *fnl, *prev;
-
-  {
-    MPage *page;
-    page = find_page(p);
-    if (!page || !page->type) {
-      /* Never collected. Don't finalize it. */
-      if (oldf) *oldf = NULL;
-      if (olddata) *olddata = NULL;
-      return;
-    }
-  }
-
-  fnl = fnls;
-  prev = NULL;
-  while (fnl) {
-    if (fnl->p == p) {
-      if (oldf) *oldf = fnl->f;
-      if (olddata) *olddata = fnl->data;
-      if (f) {
-	fnl->f = f;
-	fnl->data = data;
-	fnl->eager_level = level;
-      } else {
-	if (prev)
-	  prev->next = fnl->next;
-	else
-	  fnls = fnl->next;
-	--num_fnls;
-	return;
-      }
-      return;
-    } else {
-      prev = fnl;
-      fnl = fnl->next;
-    }
-  }
-  
-  if (oldf) *oldf = NULL;
-  if (olddata) *olddata = NULL;
-
-  if (!f)
-    return;
-
-  /* Allcation might trigger GC, so we use park: */
-  park[0] = p;
-  park[1] = data;
-
-  fnl = (Fnl *)GC_malloc_atomic(sizeof(Fnl));
-
-  p = park[0];
-  park[0] = NULL;
-  data = park[1];
-  park[1] = NULL;
-
-  fnl->next = fnls;
-  fnl->p = p;
-  fnl->f = f;
-  fnl->data = data;
-  fnl->eager_level = level;
-  fnl->tagged = tagged;
-
-#if CHECKS
-  {
-    MPage *m;
-
-    m = find_page(p);
-
-    if (tagged) {
-      if (m->type != MTYPE_TAGGED) {
-	GCPRINT(GCOUTF, "Not tagged: %lx (%d)\n", 
-		(long)p, m->type);
-	CRASH(4);
-      }
-    } else {
-      if (m->type != MTYPE_XTAGGED) {
-	GCPRINT(GCOUTF, "Not xtagged: %lx (%d)\n", 
-		(long)p, m->type);
-	CRASH(5);
-      }
-      if (m->flags & MFLAG_BIGBLOCK)
-	fnl->size = m->u.size;
-      else
-	fnl->size = ((long *)p)[-1];
-    }
-  }
-#endif
-
-  fnls = fnl;
-  num_fnls++;
-}
-
 typedef struct Fnl_Weak_Link {
   void *p;
   int offset;
@@ -823,7 +723,7 @@ static int is_marked(void *p)
 }
 
 #if SEARCH
-void *search_for, *search_mark;
+void *search_for, *search_mark = 0x7;
 long search_size;
 
 void stop()
@@ -841,6 +741,7 @@ void stop()
 
 #if CHECKS
 static void **prev_ptr, **prev_prev_ptr, **prev_prev_prev_ptr;
+static void **prev_prev_prev_prev_ptr, **prev_prev_prev_prev_prev_ptr;
 static void **prev_var_stack;
 #endif
 
@@ -882,6 +783,8 @@ static void init_tagged_mpage(void **p, MPage *page)
 	GCFLUSHOUT();
 	CRASH(7);
       }
+      prev_prev_prev_prev_prev_ptr = prev_prev_prev_prev_ptr;
+      prev_prev_prev_prev_ptr = prev_prev_prev_ptr;
       prev_prev_prev_ptr = prev_prev_ptr;
       prev_prev_ptr = prev_ptr;
       prev_ptr = p;
@@ -898,6 +801,12 @@ static void init_tagged_mpage(void **p, MPage *page)
 	  size = size_proc(p);
       }
 
+#if CHECKS
+      if (size < 1) {
+	CRASH(57);
+      }
+#endif
+
       OFFSET_SET_SIZE_UNMASKED(offsets, offset, size);
       offset += size;
 
@@ -3044,7 +2953,7 @@ static void init(void)
 #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
-    GC_add_roots(&fnls, (char *)&fnls + sizeof(fnls) + 1);
+    GC_add_roots(&finalizers, (char *)&finalizers + sizeof(finalizers) + 1);
     GC_add_roots(&fnl_weaks, (char *)&fnl_weaks + sizeof(fnl_weaks) + 1);
     GC_add_roots(&run_queue, (char *)&run_queue + sizeof(run_queue) + 1);
     GC_add_roots(&last_in_queue, (char *)&last_in_queue + sizeof(last_in_queue) + 1);
@@ -3250,7 +3159,7 @@ static void gcollect(int full)
 
   {
     Fnl *f;
-    for (f = fnls; f; f = f->next) {
+    for (f = finalizers; f; f = f->next) {
 #if RECORD_MARK_SRC
       mark_src = f;
       mark_type = MTYPE_FINALIZER;
@@ -3309,7 +3218,7 @@ static void gcollect(int full)
     /* Propagate all marks. */
     propagate_all_mpages();
     
-    if ((did_fnls >= 3) || !fnls) {
+    if ((did_fnls >= 3) || !finalizers) {
       if (did_fnls == 3) {
 	/* Finish up ordered finalization */
 	Fnl *f, *next, *prev;
@@ -3318,7 +3227,7 @@ static void gcollect(int full)
 	/* Enqueue and mark level 3 finalizers that still haven't been marked. */
 	/* (Recursive marking is already done, though.) */
 	prev = NULL;
-	for (f = fnls; f; f = next) {
+	for (f = finalizers; f; f = next) {
 	  next = f->next;
 	  if (f->eager_level == 3) {
 	    if (!is_marked(f->p)) {
@@ -3332,7 +3241,7 @@ static void gcollect(int full)
 	      if (prev)
 		prev->next = next;
 	      else
-		fnls = next;
+		finalizers = next;
 	      
 	      f->eager_level = 0; /* indicates queued */
 	      
@@ -3394,7 +3303,7 @@ static void gcollect(int full)
 
 	/* Mark content of not-yet-marked finalized objects,
 	   but don't mark the finalized objects themselves. */	
-	for (f = fnls; f; f = f->next) {
+	for (f = finalizers; f; f = f->next) {
 	  if (f->eager_level == 3) {
 #if RECORD_MARK_SRC
 	    mark_src = f;
@@ -3420,7 +3329,7 @@ static void gcollect(int full)
 	/* Unordered finalization */
 	Fnl *f, *prev, *queue;
 
-	f = fnls;
+	f = finalizers;
 	prev = NULL;
 	queue = NULL;
 	
@@ -3433,7 +3342,7 @@ static void gcollect(int full)
 	      if (prev)
 		prev->next = next;
 	      else
-		fnls = next;
+		finalizers = next;
 	      
 	      f->eager_level = 0; /* indicates queued */
 	      
@@ -3480,7 +3389,7 @@ static void gcollect(int full)
   {
     Fnl *f;
     /* All finalized objects must be marked at this point. */
-    for (f = fnls; f; f = f->next) {
+    for (f = finalizers; f; f = f->next) {
       if (!is_marked(f->p))
 	CRASH(35);
     }
@@ -3609,7 +3518,7 @@ static void gcollect(int full)
 
     {
       Fnl *f;
-      for (f = fnls; f; f = f->next) {
+      for (f = finalizers; f; f = f->next) {
 #if CHECKS
 	fnl_count++;
 #endif
@@ -3655,6 +3564,8 @@ static void gcollect(int full)
 
   protect_old_mpages();
 
+  reset_finalizer_tree();
+
 #if (COMPACTING == NEVER_COMPACT)
 # define THRESH_FREE_LIST_DELTA (FREE_LIST_DELTA >> LOG_WORD_SIZE)
 #else
@@ -4177,6 +4088,11 @@ void GC_free(void *p)
   }
 }
 
+long GC_malloc_atomic_stays_put_threshold() 
+{ 
+  return BIGBLOCK_MIN_SIZE;
+}
+
 void GC_gcollect()
 {
   gcollect(1);
@@ -4834,7 +4750,7 @@ void GC_dump(void)
     Fnl *f;
     avoid_collection++;
     GCPRINT(GCOUTF, "Begin Finalizations\n");
-    for (f = fnls; f; f = f->next) {
+    for (f = finalizers; f; f = f->next) {
       print_out_pointer("==@ ", f->p);
     }
     GCPRINT(GCOUTF, "End Finalizations\n");

src/mzscheme/gc2/fnls.c

@@ -0,0 +1,145 @@
+
+/* 
+   Provides:
+      struct finalizer { ... } Fnl
+      GC_set_finalizer
+      reset_finalizer_tree
+      finalizers
+   Requires:
+      GC_weak_array_tag
+      is_finalizable_page(p)
+      park
+*/
+
+typedef struct finalizer {
+  char eager_level;
+  char tagged;
+  void *p;
+  GC_finalization_proc f;
+  void *data;
+#if CHECKS
+  long size;
+#endif
+  struct finalizer *next;
+  /* Patched after GC: */
+  struct finalizer *prev, *left, *right;
+} Fnl;
+
+static Fnl *finalizers, *splayed_finalizers;
+static int num_fnls;
+
+#define Tree Fnl
+#define Splay_Item(t) ((unsigned long)t->p)
+#include "../sgc/splay.c"
+
+void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *data), 
+		      void *data, void (**oldf)(void *p, void *data), 
+		      void **olddata)
+{
+  Fnl *fnl;
+
+  if (!is_finalizable_page(p)) {
+    /* Never collected. Don't finalize it. */
+    if (oldf) *oldf = NULL;
+    if (olddata) *olddata = NULL;
+    return;
+  }
+
+  splayed_finalizers = splay((unsigned long)p, splayed_finalizers);
+  fnl = splayed_finalizers;
+  if (fnl && (fnl->p == p)) {
+    if (oldf) *oldf = fnl->f;
+    if (olddata) *olddata = fnl->data;
+    if (f) {
+      fnl->f = f;
+      fnl->data = data;
+      fnl->eager_level = level;
+    } else {
+      if (fnl->prev)
+	fnl->prev->next = fnl->next;
+      else
+	finalizers = fnl->next;
+      if (fnl->next)
+	fnl->next->prev = fnl->prev;
+      --num_fnls;
+      splayed_finalizers = splay_delete((unsigned long)p, splayed_finalizers);
+    }
+    return;
+  }
+  
+  if (oldf) *oldf = NULL;
+  if (olddata) *olddata = NULL;
+
+  if (!f)
+    return;
+
+  /* Allcation might trigger GC, so we use park: */
+  park[0] = p;
+  park[1] = data;
+
+  fnl = (Fnl *)GC_malloc_atomic(sizeof(Fnl));
+
+  p = park[0];
+  park[0] = NULL;
+  data = park[1];
+  park[1] = NULL;
+
+  fnl->next = finalizers;
+  fnl->prev = NULL;
+  if (finalizers) {
+    finalizers->prev = fnl;
+  }
+
+  fnl->p = p;
+  fnl->f = f;
+  fnl->data = data;
+  fnl->eager_level = level;
+  fnl->tagged = tagged;
+
+#if CHECKS
+  {
+    MPage *m;
+
+    m = find_page(p);
+
+    if (tagged) {
+      if (m->type != MTYPE_TAGGED) {
+	GCPRINT(GCOUTF, "Not tagged: %lx (%d)\n", 
+		(long)p, m->type);
+	CRASH(4);
+      }
+    } else {
+      if (m->type != MTYPE_XTAGGED) {
+	GCPRINT(GCOUTF, "Not xtagged: %lx (%d)\n", 
+		(long)p, m->type);
+	CRASH(5);
+      }
+      if (m->flags & MFLAG_BIGBLOCK)
+	fnl->size = m->u.size;
+      else
+	fnl->size = ((long *)p)[-1];
+    }
+  }
+#endif
+
+  finalizers = fnl;
+  splayed_finalizers = splay_insert((unsigned long)p, fnl, splayed_finalizers);
+
+  num_fnls++;
+}
+
+static void reset_finalizer_tree()
+  /* After a GC, rebuild the splay tree, since object addresses
+     have moved. */
+{
+  Fnl *fnl, *prev = NULL;
+
+  splayed_finalizers = NULL;
+
+  for (fnl = finalizers; fnl; fnl = fnl->next) {
+    fnl->prev = prev;
+    splayed_finalizers = splay_insert((unsigned long)fnl->p, fnl, splayed_finalizers);
+    prev = fnl;
+  }
+}
+

src/mzscheme/gc2/gc2.h

@@ -188,6 +188,11 @@ GC2_EXTERN void GC_free_immobile_box(void **b);
    Allocate (or free) a non-GCed box containing a pointer to a GCed
    value.  The pointer is stored as the first longword of the box. */
 
+GC2_EXTERN long GC_malloc_atomic_stays_put_threshold();
+/*
+   Returns a minimum size for which atomic allocations generate
+   objects that never move. */
+
 /***************************************************************************/
 /* Memory tracing                                                          */
 /***************************************************************************/

src/mzscheme/gc2/newgc.c

@@ -402,6 +402,8 @@ void *GC_malloc_atomic_uncollectable(size_t s) { return malloc(s); }
 void *GC_malloc_allow_interior(size_t s) {return allocate_big(s, PAGE_ARRAY);}
 void GC_free(void *p) {}
 
+long GC_malloc_atomic_stays_put_threshold() { return gcWORDS_TO_BYTES(MAX_OBJECT_SIZEW); }
+
 /* this function resizes generation 0 to the closest it can get (erring high)
    to the size we've computed as ideal */
 inline static void resize_gen0(unsigned long new_size)
@@ -728,7 +730,7 @@ void GC_fixup_variable_stack(void **var_stack, long delta, void *limit)
 /* Routines for root sets                                                    */
 /*****************************************************************************/
 
-#include "roots.inc"
+#include "roots.c"
 
 #define traverse_roots(gcMUCK) {                                            \
     unsigned long j;                                                        \
@@ -806,58 +808,15 @@ inline static void repair_immobiles(void)
 /*****************************************************************************/
 /* finalizers                                                                */
 /*****************************************************************************/
-struct finalizer {
-  char eager_level;
-  char tagged;
-  void *p;
-  GC_finalization_proc f;
-  void *data;
-  struct finalizer *next;
-};
 
-static struct finalizer *finalizers = NULL;
+static int is_finalizable_page(void *p)
-static struct finalizer *run_queue = NULL, *last_in_queue = NULL;
-
-void GC_set_finalizer(void *p, int tagged, int level, 
-		      GC_finalization_proc f, void *data,
-		      GC_finalization_proc *oldf, void **olddata)
 {
-  struct mpage *page = find_page(p);
+  return (find_page(p) ? 1 : 0);
-  struct finalizer *fnl, *prev;
-
-  if(!page) {
-    if(oldf) *oldf = NULL;
-    if(olddata) *olddata = NULL;
-    return;
 }
 
-  for(fnl = finalizers, prev = NULL; fnl; prev = fnl, fnl = fnl->next)
+#include "fnls.c"
-    if(fnl->p == p) {
-      if(oldf) *oldf = fnl->f;
-      if(olddata) *olddata = fnl->data;
 
-      if(f) {
+static Fnl *run_queue, *last_in_queue;
-	fnl->f = f;
-	fnl->data = data;
-	fnl->eager_level = level;
-      } else {
-	if(prev) prev->next = fnl->next;
-	if(!prev) finalizers = fnl->next;
-      }
-      return;
-    }
-
-  if(oldf) *oldf = NULL;
-  if(olddata) *olddata = NULL;
-  if(!f) return;
-
-  park[0] = p; park[1] = data;
-  fnl = GC_malloc_atomic(sizeof(struct finalizer));
-  p = park[0]; data = park[1]; park[0] = park[1] = NULL;
-  fnl->p = p; fnl->f = f; fnl->data = data; fnl->eager_level = level;
-  fnl->tagged = tagged; fnl->next = finalizers;
-  finalizers = fnl;
-}
 
 inline static void mark_finalizer_structs(void)
 {
@@ -2390,6 +2349,7 @@ static void garbage_collect(int force_full)
   if (generations_available)
     protect_old_pages();
   flush_freed_pages();
+  reset_finalizer_tree();
 
   /* new we do want the allocator freaking if we go over half */
   in_unsafe_allocation_mode = 0;

src/mzscheme/gc2/roots.c

@@ -1,4 +1,13 @@
 
+/* 
+   Provides:
+      GC_add_roots
+      my_qsort
+      roots, roots_count
+   Requires:
+      WORD_SIZE
+*/
+
 #define ROOTS_PTR_ALIGNMENT WORD_SIZE
 #define ROOTS_PTR_TO_INT(x) ((unsigned long)x)
 

src/mzscheme/gc2/weak.c

@@ -62,8 +62,8 @@ static int mark_weak_array(void *p)
     data = a->data;
     for (i = a->count; i--; ) {
       if (data[i] 
-	  && (*(short *)(data[i]) != 45)
+	  && (*(short *)(data[i]) != 46)
-	  && (*(short *)(data[i]) != 55))
+	  && (*(short *)(data[i]) != 56))
 	CRASH(1);
     }
   }

src/mzscheme/include/scheme.h

@@ -156,11 +156,9 @@ typedef struct FSSpec mzFSSpec;
 
 #define MZ_EXTERN extern MZ_DLLSPEC
 
-#ifndef MZ_PRECISE_GC
 #if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386)
 # define MZ_USE_JIT
 #endif
-#endif
 
 /* Define _W64 for MSC if needed. */
 #if defined(_MSC_VER) && !defined(_W64)
@@ -790,7 +788,10 @@ typedef long mz_pre_jmp_buf[8];
 #endif
 
 #ifdef MZ_USE_JIT
-typedef struct { mz_pre_jmp_buf jb; void *stack_frame; } mz_one_jit_jmp_buf;
+typedef struct { 
+  mz_pre_jmp_buf jb; 
+  unsigned long stack_frame; /* declared as `long' to hide pointer from 3m xform */
+} mz_one_jit_jmp_buf;
 typedef mz_one_jit_jmp_buf mz_jit_jmp_buf[1];
 #else
 # define mz_jit_jmp_buf mz_pre_jmp_buf
@@ -799,7 +800,7 @@ typedef mz_one_jit_jmp_buf mz_jit_jmp_buf[1];
 #ifdef MZ_PRECISE_GC
 typedef struct {
   mz_jit_jmp_buf jb;
-  long gcvs; /* declared as `long' so it isn't pushed when on the stack! */
+  long gcvs; /* declared as `long' to hide pointer from 3m xform */
   long gcvs_cnt;
 } mz_jmp_buf;
 #else
@@ -880,6 +881,7 @@ typedef struct Scheme_Thread {
 
   mz_jmp_buf *error_buf;
   Scheme_Continuation_Jump_State cjs;
+  Scheme_Object *current_escape_cont_key;
 
   Scheme_Thread_Cell_Table *cell_values;
   Scheme_Config *init_config;

src/mzscheme/sgc/sgc.c

@@ -606,40 +606,40 @@ static Tree *next(Tree *node)
 static void remove_freepage(SectorFreepage *fp)
 {
   /* Remove fp from freelists: */
-  sector_freepage_by_start = delete(fp->start, sector_freepage_by_start);
+  sector_freepage_by_start = splay_delete(fp->start, sector_freepage_by_start);
-  sector_freepage_by_end = delete(fp->end, sector_freepage_by_end);
+  sector_freepage_by_end = splay_delete(fp->end, sector_freepage_by_end);
   sector_freepage_by_size = splay(fp->size, sector_freepage_by_size);
   if (TREE_FP(sector_freepage_by_size) == fp) {
     /* This was the representative for its size; remove it. */
-    sector_freepage_by_size = delete(fp->size, sector_freepage_by_size);
+    sector_freepage_by_size = splay_delete(fp->size, sector_freepage_by_size);
     if (fp->same_size) {
       SectorFreepage *same;
       same = TREE_FP(fp->same_size);
-      same->same_size = delete(same->start, fp->same_size);
+      same->same_size = splay_delete(same->start, fp->same_size);
-      sector_freepage_by_size = insert(same->size, &same->by_size, sector_freepage_by_size);
+      sector_freepage_by_size = splay_insert(same->size, &same->by_size, sector_freepage_by_size);
     }
   } else {
     /* Not the top-level representative; remove it from the representative's
        same_size tree */
     SectorFreepage *same;
     same = TREE_FP(sector_freepage_by_size);
-    same->same_size = delete(fp->start, same->same_size);
+    same->same_size = splay_delete(fp->start, same->same_size);
   }
 }
 
 static void add_freepage(SectorFreepage *naya)
 {
   naya->by_start.data = (void *)naya;
-  sector_freepage_by_start = insert(naya->start, &naya->by_start, sector_freepage_by_start);
+  sector_freepage_by_start = splay_insert(naya->start, &naya->by_start, sector_freepage_by_start);
   naya->by_end.data = (void *)naya;
-  sector_freepage_by_end = insert(naya->end, &naya->by_end, sector_freepage_by_end);
+  sector_freepage_by_end = splay_insert(naya->end, &naya->by_end, sector_freepage_by_end);
   naya->by_size.data = (void *)naya;
-  sector_freepage_by_size = insert(naya->size, &naya->by_size, sector_freepage_by_size);
+  sector_freepage_by_size = splay_insert(naya->size, &naya->by_size, sector_freepage_by_size);
   if (TREE_FP(sector_freepage_by_size) != naya) {
     /* This size was already in the tree; add it to the next_size list, instead */
     SectorFreepage *already = TREE_FP(sector_freepage_by_size);
     naya->by_start_per_size.data = (void *)naya;
-    already->same_size = insert(naya->start, &naya->by_start_per_size, already->same_size);
+    already->same_size = splay_insert(naya->start, &naya->by_start_per_size, already->same_size);
   } else
     naya->same_size = NULL;
 }

src/mzscheme/sgc/splay.c

@@ -41,12 +41,15 @@
        Addison-Wesley, 1993, pp 367-375.
 */
 
+#ifndef Tree
 typedef struct tree_node Tree;
 struct tree_node {
     Tree * left, * right;
     unsigned long item;
     void *data;
 };
+# define Splay_Item(t) t->item
+#endif
 
 static Tree * splay (unsigned long i, Tree * t) {
 /* Simple top down splay, not requiring i to be in the tree t.  */
@@ -57,9 +60,9 @@ static Tree * splay (unsigned long i, Tree * t) {
     l = r = &N;
 
     for (;;) {
-	if (i < t->item) {
+	if (i < Splay_Item(t)) {
 	    if (t->left == NULL) break;
-	    if (i < t->left->item) {
+	    if (i < Splay_Item(t->left)) {
 		y = t->left;                           /* rotate right */
 		t->left = y->right;
 		y->right = t;
@@ -69,9 +72,9 @@ static Tree * splay (unsigned long i, Tree * t) {
 	    r->left = t;                               /* link right */
 	    r = t;
 	    t = t->left;
-	} else if (i > t->item) {
+	} else if (i > Splay_Item(t)) {
 	    if (t->right == NULL) break;
-	    if (i > t->right->item) {
+	    if (i > Splay_Item(t->right)) {
 		y = t->right;                          /* rotate left */
 		t->right = y->left;
 		y->left = t;
@@ -92,21 +95,21 @@ static Tree * splay (unsigned long i, Tree * t) {
     return t;
 }
 
-static Tree * insert(unsigned long i, Tree * new, Tree * t) {
+static Tree * splay_insert(unsigned long i, Tree * new, Tree * t) {
 /* Insert i into the tree t, unless it's already there.    */
 /* Return a pointer to the resulting tree.                 */
-    new->item = i;
+    Splay_Item(new) = i;
     if (t == NULL) {
 	new->left = new->right = NULL;
 	return new;
     }
     t = splay(i,t);
-    if (i < t->item) {
+    if (i < Splay_Item(t)) {
 	new->left = t->left;
 	new->right = t;
 	t->left = NULL;
 	return new;
-    } else if (i > t->item) {
+    } else if (i > Splay_Item(t)) {
 	new->right = t->right;
 	new->left = t;
 	t->right = NULL;
@@ -117,13 +120,13 @@ static Tree * insert(unsigned long i, Tree * new, Tree * t) {
     }
 }
 
-static Tree * delete(unsigned long i, Tree * t) {
+static Tree * splay_delete(unsigned long i, Tree * t) {
 /* Deletes i from the tree if it's there.               */
 /* Return a pointer to the resulting tree.              */
     Tree * x;
     if (t==NULL) return NULL;
     t = splay(i,t);
-    if (i == t->item) {               /* found it */
+    if (i == Splay_Item(t)) {               /* found it */
 	if (t->left == NULL) {
 	    x = t->right;
 	} else {

src/mzscheme/src/Makefile.in

@@ -258,7 +258,7 @@ hash.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../inclu
 image.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
         $(srcdir)/../src/stypes.h  $(srcdir)/schvers.h
 jit.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
-        $(srcdir)/../src/stypes.h  $(srcdir)/schvers.h $(srcdir)/codetab.inc
+        $(srcdir)/../src/stypes.h  $(srcdir)/schvers.h $(srcdir)/codetab.inc $(srcdir)/mzmark.c
 list.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
         $(srcdir)/../src/stypes.h  
 module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

src/mzscheme/src/codetab.inc

@@ -2,23 +2,26 @@
 /* Implementation of the "symbol table" for mapping code
    pointers to function names. */
 
+#ifndef MZ_PRECISE_GC
 # ifdef USE_SENORA_GC
 # define GC_is_marked(p) GC_base(p)
 # else
 extern MZ_DLLIMPORT int GC_is_marked(void *);
 # endif
+#endif
 
 #define LOG_KEY_SIZE 4
 #define KEY_MASK ((1 << LOG_KEY_SIZE) - 1)
 #define KEY_COUNT (1 << LOG_KEY_SIZE)
 
-#define NODE_HEADER_SIZE 2
+/* In words: */
-
+#define NODE_HEADER_SIZE 3
 #define NODE_STARTS_OFFSET 1
 #define NODE_GCABLE_OFFSET 2
 
 static void **tree;
 
+static int do_clear_symbols(void **t, unsigned long start, int offset, unsigned long addr, int clearing);
 static int during_set;
 
 static void *find_symbol(unsigned long v)
@@ -44,6 +47,19 @@ static void *find_symbol(unsigned long v)
   return NULL;
 }
 
+static void **malloc_node()
+{
+  void **v;
+  v = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
+
+  /* Set low bit in each of STARTS and GCABLE so that they're not confused
+     for pointers: */
+  ((unsigned long *)v)[NODE_STARTS_OFFSET] = 0x1;
+  ((unsigned long *)v)[NODE_GCABLE_OFFSET] = 0x1;
+
+  return v;
+}
+
 static void add_symbol(unsigned long start, unsigned long end, void *value, int gc_able)
 {
   unsigned long k1, k2, split_t_start = 0, split_t_end = 0, i;
@@ -53,7 +69,7 @@ static void add_symbol(unsigned long start, unsigned long end, void *value, int
 
   if (!tree) {
     REGISTER_SO(tree);
-    tree = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
+    tree = malloc_node();
   }
 
   during_set++;
@@ -67,7 +83,7 @@ static void add_symbol(unsigned long start, unsigned long end, void *value, int
     if (offset) {
       val1 = t1[k1];
       if (!val1) {
-	val1 = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
+	val1 = malloc_node();
 	t1[k1] = val1;
       }
     } else
@@ -78,7 +94,7 @@ static void add_symbol(unsigned long start, unsigned long end, void *value, int
       /* Need to go deeper... */
       val2 = t2[k2];
       if (!val2) {
-	val2 = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
+	val2 = malloc_node();
 	t2[k2] = val2;
       }
     } else
@@ -103,10 +119,17 @@ static void add_symbol(unsigned long start, unsigned long end, void *value, int
   }
 
   /* Mark start bit: */
-  m = (1 << (k1 - NODE_HEADER_SIZE));
+  m = (1 << (k1 - NODE_HEADER_SIZE + 1));
-  ((unsigned short *)t1)[NODE_STARTS_OFFSET] |= m;
+  ((unsigned long *)t1)[NODE_STARTS_OFFSET] |= m;
+#ifndef MZ_PRECISE_GC
+  /* GCABLE flag indicates whether to check for GC later */
   if (gc_able)
-    ((unsigned short *)t1)[NODE_GCABLE_OFFSET] |= m;
+    ((unsigned long *)t1)[NODE_GCABLE_OFFSET] |= m;
+#else
+  /* GCABLE flag indicates whether it's been GCed: */
+  if (!value)
+    ((unsigned long *)t1)[NODE_GCABLE_OFFSET] |= m;
+#endif
 
   /* Fill in start and end: */
   t1[k1] = value;
@@ -145,9 +168,19 @@ static void add_symbol(unsigned long start, unsigned long end, void *value, int
   }
 
   --during_set;
+
+#ifdef MZ_PRECISE_GC
+  if (!value) {
+    /* Prune empty branches in the tree. Only do this if this
+       object is mapped deeply enough in the tree, otherwise
+       we end up scanning the whole tree. */
+    do_clear_symbols(tree, start, 0, 0, 0);
+  }
+#endif
 }
 
-static int do_clear_symbols(void **t, int offset, unsigned long addr, int clearing)
+static int do_clear_symbols(void **t, unsigned long start, int offset, unsigned long addr, int clearing)
+  /* If MZ_PRECISE_GC, then offset and addr are not used. */
 {
   int i, m, j;
   void *p, *val, **subt;
@@ -155,26 +188,44 @@ static int do_clear_symbols(void **t, int offset, unsigned long addr, int cleari
   /* Note: this function might be called  (via a GC callback)
      while add_symbol is running. */
 
-  for (i = 0; i < KEY_COUNT; i++) {
+  for (i = ((start >> offset) & KEY_MASK); i < KEY_COUNT; i++) {
-    m = (1 << i);
+    m = (1 << (i + 1));
-    if (((unsigned short *)t)[NODE_STARTS_OFFSET] & m) {
+    if (((unsigned long *)t)[NODE_STARTS_OFFSET] & m) {
       clearing = 0;
-      if (((unsigned short *)t)[NODE_GCABLE_OFFSET] & m) {
+      if (((unsigned long *)t)[NODE_GCABLE_OFFSET] & m) {
 	/* GCable pointer starts here */
+#ifndef MZ_PRECISE_GC
+	/* Conservative GC: GCable flag means use GC_is_marked */
 	p = (void *)(addr + (i << offset));
-	if (!GC_is_marked(p)) {
+	if (!GC_is_marked(p))
-	  /* Collected... */
-	  ((unsigned short *)t)[NODE_STARTS_OFFSET] -= m;
-	  ((unsigned short *)t)[NODE_GCABLE_OFFSET] -= m;
 	  clearing = 1;
+#else
+	/* Precise GC: GCable flag means it's gone */
+	clearing = 1;
+#endif
+	if (clearing) {
+	  /* Collected... */
+	  ((unsigned long *)t)[NODE_STARTS_OFFSET] -= m;
+	  ((unsigned long *)t)[NODE_GCABLE_OFFSET] -= m;
+	}
+      } else {
+#ifdef MZ_PRECISE_GC
+	return 0;
+#endif
       }
     }
-    }
+
+#ifdef MZ_PRECISE_GC
+    if (!clearing)
+      val = NULL;
+    else
+#endif
       val = t[i + NODE_HEADER_SIZE];
+
     if (val) {
       if (!*(Scheme_Type *)val) {
 	subt = (void **)val;
-	clearing = do_clear_symbols(subt, 
+	clearing = do_clear_symbols(subt, start,
 				    offset - LOG_KEY_SIZE,
 				    (addr + (i << offset)),
 				    clearing);
@@ -188,6 +239,12 @@ static int do_clear_symbols(void **t, int offset, unsigned long addr, int cleari
 	    t[i + NODE_HEADER_SIZE] = NULL;
 	  }
 	}
+#ifdef MZ_PRECISE_GC
+	if (!clearing) {
+	  /* Finished clearing the one item, so return. */
+	  return 0;
+	}
+#endif
       } else if (clearing)
 	t[i + NODE_HEADER_SIZE] = NULL;
     }
@@ -196,13 +253,17 @@ static int do_clear_symbols(void **t, int offset, unsigned long addr, int cleari
   return clearing;
 }
 
+#ifndef MZ_PRECISE_GC
+
 static void clear_symbols_for_collected()
 {
   if (tree) {
-    do_clear_symbols(tree, (JIT_WORD_SIZE * 8) - LOG_KEY_SIZE, 0, 0); 
+    do_clear_symbols(tree, 0, (JIT_WORD_SIZE * 8) - LOG_KEY_SIZE, 0, 0); 
   }
 }
 
+#endif
+
 /*============================================================*/
 /*                          testing                           */
 /*============================================================*/

src/mzscheme/src/fun.c

@@ -239,7 +239,7 @@ scheme_init_fun (Scheme_Env *env)
   o = scheme_make_prim_w_arity2(scheme_call_ec,
 				"call-with-escape-continuation",
 				1, 1,
-				0, -1),
+				0, -1);
   scheme_add_global_constant("call-with-escape-continuation", o, env);
   scheme_add_global_constant("call/ec", o, env);
 
@@ -2575,6 +2575,32 @@ static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump
   a->is_kill = b->is_kill;
 }
 
+static Scheme_Object *get_ec_marks_prefix()
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object *pr = scheme_null;
+  long findpos;
+  Scheme_Cont_Mark *find;
+
+  findpos = (long)MZ_CONT_MARK_STACK;
+
+  while (findpos--) {
+    long pos;
+
+    find = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
+    pos = findpos & SCHEME_MARK_SEGMENT_MASK;
+
+    if (find[pos].pos != MZ_CONT_MARK_POS)
+      break;
+
+    pr = scheme_make_pair(scheme_make_pair(find[pos].key,
+					   find[pos].val),
+			  pr);
+  }
+
+  return pr;
+}
+
 Scheme_Object *
 scheme_call_ec (int argc, Scheme_Object *argv[])
 {
@@ -2583,12 +2609,37 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
   Scheme_Thread *p1 = scheme_current_thread;
   Scheme_Object * volatile v;
   Scheme_Object *mark_key, *a[1];
-  Scheme_Cont_Frame_Data volatile cframe;
 
   scheme_check_proc_arity("call-with-escaping-continuation", 1,
 			  0, argc, argv);
 
-  mark_key = scheme_make_pair(scheme_false, scheme_false);
+  /* In tail position with respect to an existing
+     escape continuation? */
+  mark_key = p1->current_escape_cont_key;
+  if (mark_key && SAME_OBJ((Scheme_Object *)MZ_CONT_MARK_POS,
+			   SCHEME_CAR(mark_key))) {
+    /* Yes - reuse the old continuation */
+    cont = (Scheme_Escaping_Cont *)SCHEME_CDR(mark_key);
+
+    v = get_ec_marks_prefix();
+
+    if (!scheme_equal(v, cont->marks_prefix)) {
+      /* The continuation marks are different this time. 
+	 We need to clone the continuation, then change mark prefix. */
+      Scheme_Escaping_Cont *c2;
+      c2 = MALLOC_ONE_TAGGED(Scheme_Escaping_Cont);
+      memcpy(c2, cont, sizeof(Scheme_Escaping_Cont));
+      c2->marks_prefix = v;
+      cont = c2;
+    }
+
+    a[0] = (Scheme_Object *)cont;
+    SCHEME_USE_FUEL(1);
+    return scheme_tail_apply(argv[0], 1, a);
+  }
+
+  mark_key = scheme_make_pair((Scheme_Object *)MZ_CONT_MARK_POS, 
+			      scheme_false);
   
   cont = MALLOC_ONE_TAGGED(Scheme_Escaping_Cont);
   cont->so.type = scheme_escaping_cont_type;
@@ -2596,17 +2647,26 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
   cont->suspend_break = p1->suspend_break;
   copy_cjs(&cont->cjs, &p1->cjs);
 
+  SCHEME_CDR(mark_key) = (Scheme_Object *)cont;
+
+  v = get_ec_marks_prefix();
+  cont->marks_prefix = v;
+
   cont->saveerr = p1->error_buf;
   p1->error_buf = &newbuf;
 
   scheme_save_env_stack_w_thread(cont->envss, p1);
 
-  scheme_push_continuation_frame((Scheme_Cont_Frame_Data *)&cframe);
+  /* Don't push a continuation frame; argument function
+     is called as tail. */
   scheme_set_cont_mark(mark_key, scheme_true);
+  p1->current_escape_cont_key = mark_key;
 
   if (scheme_setjmp(newbuf)) {
     Scheme_Thread *p2 = scheme_current_thread;
-    if ((void *)p2->cjs.jumping_to_continuation == cont) {
+    if (p2->cjs.jumping_to_continuation
+	&& SAME_OBJ(p2->cjs.jumping_to_continuation->mark_key,
+		    cont->mark_key)) {
       int n = p2->cjs.num_vals;
       Scheme_Object **vs = p2->cjs.u.vals;
       v = p2->cjs.u.val;
@@ -2619,15 +2679,22 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
       scheme_longjmp(*cont->saveerr, 1);
     }
   } else {
+    /* Adjusting MZ_CONT_MARK_POS, we make the application appear to
+       be in tail position. The actual non-tailness is limited to a
+       single frame, since call_ec checks the current escape-cont key
+       as a continuation mark before getting here. */
+    MZ_CONT_MARK_POS -= 2;
+
     a[0] = (Scheme_Object *)cont;
     v = _scheme_apply_multi(argv[0], 1, a);
+
+    MZ_CONT_MARK_POS += 2;
   }
 
   p1 = scheme_current_thread;
 
   p1->error_buf = cont->saveerr;
-
+  p1->current_escape_cont_key = cont->envss.current_escape_cont_key;
-  scheme_pop_continuation_frame((Scheme_Cont_Frame_Data *)&cframe);
 
   return v;
 }
@@ -3022,10 +3089,23 @@ internal_call_cc (int argc, Scheme_Object *argv[])
     sub_cont = NULL;
   if (sub_cont && (sub_cont->ss.cont_mark_pos == MZ_CONT_MARK_POS)) {
     Scheme_Object *argv2[1];
+#ifdef MZ_USE_JIT
+    ret = scheme_native_stack_trace();
+#endif    
     /* Old cont is the same as this one, except that it may
        have different marks (not counting cont_key). */
     if ((sub_cont->cont_mark_shareable == (long)sub_cont->ss.cont_mark_stack)
-	&& (find_shareable_marks() == MZ_CONT_MARK_STACK)) {
+	&& (find_shareable_marks() == MZ_CONT_MARK_STACK)
+#ifdef MZ_USE_JIT
+	&& (SAME_OBJ(ret, sub_cont->native_trace)
+	    /* Maybe a single-function loop, where we re-allocated the
+	       last pair in the trace, but it's the same name: */
+	    || (SCHEME_PAIRP(ret)
+		&& SCHEME_PAIRP(sub_cont->native_trace)
+		&& SAME_OBJ(SCHEME_CAR(ret), SCHEME_CAR(sub_cont->native_trace))
+		&& SAME_OBJ(SCHEME_CDR(ret), SCHEME_CDR(sub_cont->native_trace))))
+#endif
+	) {
       /* Just use this one. */
       cont = sub_cont;
     } else {
@@ -3045,6 +3125,9 @@ internal_call_cc (int argc, Scheme_Object *argv[])
       cont->cont_mark_offset = offset;
       offset = find_shareable_marks();
       cont->cont_mark_shareable = offset;
+#ifdef MZ_USE_JIT
+      cont->native_trace = ret;
+#endif
     }
 
     argv2[0] = (Scheme_Object *)cont;
@@ -3095,6 +3178,11 @@ internal_call_cc (int argc, Scheme_Object *argv[])
     }
   }
 
+#ifdef MZ_USE_JIT
+  ret = scheme_native_stack_trace();
+  cont->native_trace = ret;
+#endif
+
   saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START, sub_cont);
   cont->runstack_copied = saved;
   {
@@ -3425,6 +3513,10 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
       find = seg;
     }
 
+    /* For econt, skip positions that match cmpos; the econt
+       record has a prefix to use, instead. */
+    
+    if (!econt || (find[pos].pos != cmpos)) {
       cache = find[pos].cache;
       if (cache) {
 	if (SCHEME_FALSEP(cache))
@@ -3463,11 +3555,32 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
 	last = pr;
       }
     }
+  }
+
+  if (econt) {
+    Scheme_Object *l, *a;
+    for (l = ((Scheme_Escaping_Cont *)econt)->marks_prefix; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+      Scheme_Cont_Mark_Chain *pr;
+      pr = MALLOC_ONE_RT(Scheme_Cont_Mark_Chain);
+      pr->so.type = scheme_cont_mark_chain_type;
+      a = SCHEME_CAR(l);
+      pr->key = SCHEME_CAR(a);
+      pr->val = SCHEME_CDR(a);
+      pr->pos = cmpos;
+      pr->next = first;
+      first = pr;
+    }
+  }
 
   if (just_chain)
     return (Scheme_Object *)first;
 
 #ifdef MZ_USE_JIT
+  if (cont)
+    nt = cont->native_trace;
+  else if (econt)
+    nt = ((Scheme_Escaping_Cont *)econt)->native_trace;
+  else
     nt = scheme_native_stack_trace();
 #else
   nt = NULL;

src/mzscheme/src/jit.c

@@ -26,6 +26,17 @@
 # define _CALL_DARWIN
 #endif
 
+/* Separate JIT_PRECISE_GC lets us test some 3m support 
+   in non-3m mode: */
+#ifdef MZ_PRECISE_GC
+# define JIT_PRECISE_GC
+#endif
+
+/* IMPORTANT! 3m arithmetic checking disabled for the whole file! */
+#ifdef MZ_PRECISE_GC
+END_XFORM_ARITH;
+#endif
+
 #include "lightning/lightning.h"
 
 #define JIT_LOG_WORD_SIZE 2
@@ -65,7 +76,8 @@ static void *get_stack_pointer_code;
 static void *stack_cache_pop_code;
 
 typedef struct {
-  jit_state js;
+  MZTAG_IF_REQUIRED
+  GC_CAN_IGNORE jit_state js;
   char *limit;
   int extra_pushed, max_extra_pushed;
   int depth, max_depth;
@@ -98,6 +110,11 @@ static void on_demand();
 static int generate_non_tail_mark_pos_prefix(mz_jit_state *jitter);
 static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter);
 
+#ifdef MZ_PRECISE_GC
+static void register_traversers(void);
+static void release_native_code(void *fnlized, void *p);
+#endif
+
 /* Tracking statistics: */
 #if 0
 # define NUM_CATEGORIES 23
@@ -173,11 +190,11 @@ static int mz_retain_it(mz_jit_state *jitter, void *v)
   return jitter->retained;
 }
 
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
 static void mz_load_retained(mz_jit_state *jitter, int rs, int retptr)
 {
   void *p;
-  p = jitter->retain_start + retptr;
+  p = jitter->retain_start + retptr - 1;
   (void)jit_movi_p(rs, p);
   jit_ldr_p(rs, rs);
 }
@@ -187,7 +204,8 @@ static void *generate_one(mz_jit_state *old_jitter,
 			  Generate_Proc generate,
 			  void *data,
 			  int gcable,
-			  void *save_ptr)
+			  void *save_ptr,
+			  Scheme_Native_Closure_Data *ndata)
 {
   mz_jit_state _jitter;
   mz_jit_state *jitter = &_jitter;
@@ -197,11 +215,24 @@ static void *generate_one(mz_jit_state *old_jitter,
   long size = JIT_BUFFER_INIT_SIZE, known_size = 0, size_pre_retained = 0, num_retained = 0, padding;
   int mappings_size = JIT_INIT_MAPPINGS_SIZE;
   int ok, max_extra_pushed = 0;
+#ifdef MZ_PRECISE_GC
+  Scheme_Object *fnl_obj;
+
+  if (ndata) {
+    /* When fnl_obj becomes inaccessible, code generated
+       here can be freed. */
+    fnl_obj = scheme_box(scheme_false);
+  } else
+    fnl_obj = NULL;
+#endif
 
   if (!jit_buffer_cache_registered) {
     jit_buffer_cache_registered = 1;
     REGISTER_SO(jit_buffer_cache);
     REGISTER_SO(stack_cache_stack);
+#ifdef MZ_PRECISE_GC
+    register_traversers();
+#endif
     /* printf("zap!\n"); */
   }
 
@@ -216,7 +247,11 @@ static void *generate_one(mz_jit_state *old_jitter,
       size = size_pre_retained + WORDS_TO_BYTES(num_retained);
       padding = 0;
       if (gcable) {
+#ifdef MZ_PRECISE_GC
+	buffer = malloc(size);
+#else
 	buffer = scheme_malloc(size);
+#endif
       } else {
 	buffer = malloc(size);
       }
@@ -242,16 +277,35 @@ static void *generate_one(mz_jit_state *old_jitter,
 	size = jit_buffer_cache_size;
 	jit_buffer_cache = NULL;
       } else {
+#ifdef MZ_PRECISE_GC
+	long minsz;
+	minsz = GC_malloc_atomic_stays_put_threshold();
+	if (size < minsz)
+	  size = minsz;
+	buffer = (char *)scheme_malloc_atomic(size);
+#else
 	buffer = scheme_malloc(size);
+#endif
       }
       size_pre_retained = size;
     }
       
     (void)jit_set_ip(buffer).ptr;
     jitter->limit = (char *)buffer + size_pre_retained - padding;
-    if (known_size)
+    if (known_size) {
       jitter->retain_start = (void *)jitter->limit;
-    else
+#ifdef MZ_PRECISE_GC
+      if (ndata) {
+	memset(jitter->retain_start, 0, num_retained * sizeof(void*));
+	ndata->retained = jitter->retain_start;
+	ndata->retain_count = num_retained;
+	SCHEME_BOX_VAL(fnl_obj) = scheme_make_integer(size_pre_retained);
+	GC_set_finalizer(fnl_obj, 1, 1,
+			 release_native_code, buffer,
+			 NULL, NULL);
+      }
+#endif
+    } else
       jitter->retain_start = NULL;
 
     jitter->mappings = mappings;
@@ -265,6 +319,11 @@ static void *generate_one(mz_jit_state *old_jitter,
     if (save_ptr) {
       mz_retain_it(jitter, save_ptr);
     }
+#ifdef MZ_PRECISE_GC
+    if (fnl_obj) {
+      mz_retain_it(jitter, fnl_obj);
+    }
+#endif
 
     jitter->limit = (char *)jitter->limit + padding;
     if (PAST_LIMIT() || (jitter->retain_start
@@ -1217,7 +1276,7 @@ static void *generate_shared_call(int num_rands, mz_jit_state *old_jitter, int m
   data.direct_prim = direct_prim;
   data.direct_native = direct_native;
 
-  return generate_one(old_jitter, do_generate_shared_call, &data, 0, NULL);
+  return generate_one(old_jitter, do_generate_shared_call, &data, 0, NULL, NULL);
 }
 
 static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, 
@@ -2019,7 +2078,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
       
       __START_SHORT_JUMPS__(branch_short);
 
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
       if (retptr) {
 	mz_load_retained(jitter, JIT_R1, retptr);
 	ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1);
@@ -2207,7 +2266,7 @@ static int generate_closure(Scheme_Closure_Data *data,
   JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
   mz_prepare(1);
   retptr = mz_retain(code);
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
   mz_load_retained(jitter, JIT_R0, retptr);
 #else
   (void)jit_movi_p(JIT_R0, code); /* !! */
@@ -2245,6 +2304,9 @@ Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *c)
   int max_let_depth = 0, i, count, is_method = 0;
 
   ndata = MALLOC_ONE_RT(Scheme_Native_Closure_Data);
+#ifdef MZTAG_REQUIRED
+  ndata->type = scheme_rt_native_code;
+#endif
   name = c->name;
   if (name && SCHEME_BOXP(name)) {
     name = SCHEME_BOX_VAL(name);
@@ -2300,7 +2362,7 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter)
   JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
   mz_prepare(1);
   retptr = mz_retain(ndata);
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
   mz_load_retained(jitter, JIT_R0, retptr);
 #else
   (void)jit_movi_p(JIT_R0, ndata); /* !! */
@@ -2442,9 +2504,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
     Scheme_Thread *p = scheme_current_thread;
     mz_jit_state *jitter_copy;
 
-    /* 3m FIXME: need precise handling of this copy: */
+    jitter_copy = MALLOC_ONE_RT(mz_jit_state);
-    jitter_copy = (mz_jit_state *)scheme_malloc(sizeof(jitter_copy));
     memcpy(jitter_copy, jitter, sizeof(mz_jit_state));
+#ifdef MZTAG_REQUIRED
+    jitter_copy->type = scheme_rt_jitter_data;
+#endif
 
     p->ku.k.p1 = (void *)obj;
     p->ku.k.p2 = (void *)jitter_copy;
@@ -3191,7 +3255,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       } else
 	retptr = 0;
 
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
       if (retptr)
 	mz_load_retained(jitter, JIT_R0, retptr);
       else
@@ -3378,7 +3442,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   __START_SHORT_JUMPS__(1);
   /* Load global array: */
   jit_ldxr_p(JIT_V1, JIT_RUNSTACK, JIT_R0);
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
   /* Save global-array index before we lose it: */
   mz_set_local_p(JIT_R0, JIT_LOCAL3);
 #endif
@@ -3389,7 +3453,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   CHECK_LIMIT();
   /* Syntax object is NULL, so we need to create it. */
   jit_ldxr_p(JIT_R0, JIT_V1, JIT_R2); /* put element at p in R0 */
-#ifndef MZ_PRECISE_GC
+#ifndef JIT_PRECISE_GC
   /* Save global array: */
   mz_set_local_p(JIT_V1, JIT_LOCAL3);
 #endif
@@ -3413,9 +3477,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   CHECK_LIMIT();
   jit_retval(JIT_R0);
   /* Restore global array into JIT_R1, and put computed element at i+p+1: */
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
   mz_get_local_p(JIT_R1, JIT_LOCAL3);
-  jit_ldxr_p(JIT_R1, JIT_RUNSTACK, JIT_R0);
+  jit_ldxr_p(JIT_R1, JIT_RUNSTACK, JIT_R1);
 #else
   mz_get_local_p(JIT_R1, JIT_LOCAL3);
 #endif
@@ -3805,7 +3869,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
     __END_SHORT_JUMPS__(cnt < 100);
   }
 
-#ifdef MZ_PRECISE_GC
+#ifdef JIT_PRECISE_GC
   /* Keeping the native-closure pointer on the runstack
      ensures that the code won't be GCed while we're running
      it. */
@@ -3841,6 +3905,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
       } else
 	mz_runstack_pushed(jitter, 1);
     }
+  } else {
+    mz_runstack_pushed(jitter, cnt);
   }
 
   LOG_IT(("PROC: %s\n", (data->name ? scheme_format_utf8("~s", 2, 1, &data->name, NULL) : "???")));
@@ -3884,7 +3950,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure_Data *ndata)
 
   gdata.data = data;
 
-  generate_one(NULL, do_generate_closure, &gdata, 1, data->name);
+  generate_one(NULL, do_generate_closure, &gdata, 1, data->name, ndata);
 
   if (gdata.max_depth > data->max_let_depth) {
     scheme_console_printf("Bad max depth!\n");
@@ -3956,16 +4022,22 @@ Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, in
 
   if (!jump_to_native_code) {
     /* Create shared code used for stack-overflow handling, etc.: */
-    generate_one(NULL, do_generate_common, NULL, 0, NULL);
+    generate_one(NULL, do_generate_common, NULL, 0, NULL, NULL);
   }
 
   if (!case_lam) {
     ndata = MALLOC_ONE_RT(Scheme_Native_Closure_Data);
+#ifdef MZTAG_REQUIRED
+    ndata->type = scheme_rt_native_code;
+#endif
   } else {
     Scheme_Native_Closure_Data_Plus_Case *ndatap;
     ndatap = MALLOC_ONE_RT(Scheme_Native_Closure_Data_Plus_Case);
     ndatap->case_lam = case_lam;
     ndata = (Scheme_Native_Closure_Data *)ndatap;
+#ifdef MZTAG_REQUIRED
+    ndata->type = scheme_rt_native_code_plus_case;
+#endif
   }
   ndata->code = on_demand_jit_code;
   ndata->u.tail_code = on_demand_jit_arity_code;
@@ -4091,7 +4163,7 @@ static void *generate_lambda_simple_arity_check(int num_params, int has_rest, in
   data.has_rest = has_rest;
   data.is_method = is_method;
 
-  return generate_one(NULL, do_generate_lambda_simple_arity_check, &data, !permanent, NULL);
+  return generate_one(NULL, do_generate_lambda_simple_arity_check, &data, !permanent, NULL, NULL);
 }
 
 static int generate_case_lambda_dispatch(mz_jit_state *jitter, Scheme_Case_Lambda *c, Scheme_Native_Closure_Data *ndata,
@@ -4204,7 +4276,7 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
   gdata.ndata = ndata;
   gdata.is_method = is_method;
 
-  generate_one(NULL, do_generate_case_lambda_dispatch, &gdata, 1, NULL);
+  generate_one(NULL, do_generate_case_lambda_dispatch, &gdata, 1, NULL, ndata);
 
   /* Generate arity table used by scheme_native_arity_check
      and scheme_get_native_arity: */
@@ -4495,6 +4567,10 @@ Scheme_Object *scheme_native_stack_trace(void)
   return first;
 }
 
+#ifdef MZ_XFORM
+START_XFORM_SKIP;
+#endif
+
 void scheme_flush_stack_cache()
 {
   void **p;
@@ -4511,7 +4587,7 @@ void scheme_jit_longjmp(mz_jit_jmp_buf b, int v)
   unsigned long limit;
   void **p;
 
-  limit = (unsigned long)b->stack_frame;
+  limit = b->stack_frame;
 
   while (stack_cache_stack_pos
 	 && STK_COMP((unsigned long)stack_cache_stack[stack_cache_stack_pos].stack_frame,
@@ -4528,12 +4604,55 @@ void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b)
 {
   void *p;
   p = &p;
-  b->stack_frame = p;
+  b->stack_frame = (unsigned long)p;
 }
 
+#ifdef MZ_XFORM
+END_XFORM_SKIP;
+#endif
+
 void scheme_clean_native_symtab(void)
 {
+#ifndef MZ_PRECISE_GC
   clear_symbols_for_collected();
+#endif
 }
 
+#ifdef MZ_PRECISE_GC
+static void release_native_code(void *fnlized, void *p)
+{
+  Scheme_Object *len;
+
+  len = SCHEME_BOX_VAL(fnlized);
+
+  /* Remove name mapping: */
+  add_symbol((unsigned long)p, (unsigned long)p + SCHEME_INT_VAL(len), NULL, 0);
+  /* Free memory: */
+  free(p);
+}
+#endif
+
+/**********************************************************************/
+/*                           Precise GC                               */
+/**********************************************************************/
+
+#ifdef MZ_PRECISE_GC
+
+START_XFORM_SKIP;
+
+#define MARKS_FOR_JIT_C
+#include "mzmark.c"
+
+static void register_traversers(void)
+{
+  GC_REG_TRAV(scheme_native_closure_type, native_closure);
+  GC_REG_TRAV(scheme_rt_jitter_data, mark_jit_state);
+  GC_REG_TRAV(scheme_rt_native_code, native_unclosed_proc);
+  GC_REG_TRAV(scheme_rt_native_code_plus_case, native_unclosed_proc_plus_case);
+}
+
+END_XFORM_SKIP;
+
+#endif /* MZ_PRECISE_GC */
+
 #endif /* MZ_USE_JIT */

src/mzscheme/src/mkmark.ss

@@ -38,13 +38,13 @@
     (let ([prefix (read-lines re:mark)]
 	  [mark (read-lines re:size)]
 	  [size (read-lines re:close)])
-      (printf "int ~a_SIZE(void *p) {~n" name)
+      (printf "static int ~a_SIZE(void *p) {~n" name)
       (print-lines prefix)
       (printf "  return~n")
       (print-lines size)
       (printf "}~n~n")
 
-      (printf "int ~a_MARK(void *p) {~n" name)
+      (printf "static int ~a_MARK(void *p) {~n" name)
       (print-lines prefix)
       (print-lines (map (lambda (s)
 			  (regexp-replace* 
@@ -59,7 +59,7 @@
       (print-lines size)
       (printf "}~n~n")
 
-      (printf "int ~a_FIXUP(void *p) {~n" name)
+      (printf "static int ~a_FIXUP(void *p) {~n" name)
       (print-lines prefix)
       (print-lines (map (lambda (s)
 			  (regexp-replace* 

src/mzscheme/src/mzmarksrc.c

@@ -341,6 +341,9 @@ cont_proc {
   gcMARK(c->orig_mark_segments);
   gcMARK(c->init_config);
   gcMARK(c->init_break_cell);
+#ifdef MZ_USE_JIT
+  gcMARK(c->native_trace);
+#endif
 
   MARK_jmpup(&c->buf);
   MARK_cjs(&c->cjs);
@@ -380,6 +383,10 @@ escaping_cont_proc {
   Scheme_Escaping_Cont *c = (Scheme_Escaping_Cont *)p;
 
   gcMARK(c->mark_key);
+  gcMARK(c->marks_prefix);
+#ifdef MZ_USE_JIT
+  gcMARK(c->native_trace);
+#endif
 
   MARK_cjs(&c->cjs);
   MARK_stack_state(&c->envss);
@@ -561,6 +568,8 @@ thread_val {
 
   MARK_cjs(&pr->cjs);
 
+  gcMARK(pr->current_escape_cont_key);
+
   gcMARK(pr->cell_values);
   gcMARK(pr->init_config);
   gcMARK(pr->init_break_cell);
@@ -1765,4 +1774,68 @@ END stxobj;
 
 /**********************************************************************/
 
+START jit;
+
+native_closure {
+  Scheme_Native_Closure *c = (Scheme_Native_Closure *)p;
+  int closure_size = ((Scheme_Native_Closure_Data *)GC_resolve(c->code))->closure_size;
+
+  if (closure_size < 0) {
+    closure_size = -(closure_size + 1);
+  }
+
+ mark:
+
+  {
+    int i = closure_size;
+    while (i--)
+      gcMARK(c->vals[i]);
+  }
+  gcMARK(c->code);
+  
+ size:
+  gcBYTES_TO_WORDS((sizeof(Scheme_Native_Closure)
+		    + (closure_size - 1) * sizeof(Scheme_Object *)));
+}
+
+mark_jit_state {
+ mark:
+  mz_jit_state *j = (mz_jit_state *)p;
+  gcMARK(j->mappings);
+ size:
+  gcBYTES_TO_WORDS(sizeof(mz_jit_state));
+}
+
+native_unclosed_proc {
+ mark:
+  Scheme_Native_Closure_Data *d = (Scheme_Native_Closure_Data *)p;
+  int i;
+
+  gcMARK(d->u2.name);
+  for (i = d->retain_count; i--; ) {
+    gcMARK(d->retained[i]);
+  }
+  if (d->closure_size < 0) {
+    gcMARK(d->u.arities);
+  }
+
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Native_Closure_Data));
+}
+
+native_unclosed_proc_plus_case {
+ mark:
+  Scheme_Native_Closure_Data_Plus_Case *d = (Scheme_Native_Closure_Data_Plus_Case *)p;
+
+  native_unclosed_proc_MARK(p);
+  gcMARK(d->case_lam);
+
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Native_Closure_Data_Plus_Case));
+}
+
+END jit;
+
+/**********************************************************************/
+
 #define GC_REG_TRAV(type, base) GC_register_traversers(type, base ## _SIZE, base ## _MARK, base ## _FIXUP, base ## _IS_CONST_SIZE, base ## _IS_ATOMIC)

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 853
+#define EXPECTED_PRIM_COUNT 855
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

src/mzscheme/src/schnapp.inc

@@ -59,7 +59,7 @@
 #if PRIM_CHECK_MULTI
   return _scheme_apply(rator, argc, argv);
 #else
-# ifdef PRIM_CHECK_VALUE
+# if PRIM_CHECK_VALUE
   return _scheme_apply_multi(rator, argc, argv);
 # else
   return _scheme_tail_apply(rator, argc, argv);

src/mzscheme/src/schpriv.h

@@ -881,6 +881,7 @@ typedef struct Scheme_Stack_State {
   Scheme_Saved_Stack *runstack_saved;
   MZ_MARK_POS_TYPE cont_mark_pos;
   MZ_MARK_STACK_TYPE cont_mark_stack;
+  Scheme_Object *current_escape_cont_key;
 } Scheme_Stack_State;
 
 typedef struct Scheme_Dynamic_Wind {
@@ -914,6 +915,9 @@ typedef struct Scheme_Cont {
   void *o_start;
   Scheme_Config *init_config;
   Scheme_Object *init_break_cell;
+#ifdef MZ_USE_JIT
+  Scheme_Object *native_trace;
+#endif
   struct Scheme_Overflow *save_overflow;
   mz_jmp_buf *savebuf; /* save old error buffer here */
 } Scheme_Cont;
@@ -923,6 +927,10 @@ typedef struct Scheme_Escaping_Cont {
   Scheme_Continuation_Jump_State cjs;
   Scheme_Object *mark_key;
   struct Scheme_Stack_State envss;
+#ifdef MZ_USE_JIT
+  Scheme_Object *native_trace;
+#endif
+  Scheme_Object *marks_prefix;
   mz_jmp_buf *saveerr;
   int suspend_break;
 } Scheme_Escaping_Cont;
@@ -934,11 +942,13 @@ int scheme_escape_continuation_ok(Scheme_Object *);
 #define scheme_save_env_stack_w_thread(ss, p) \
     (ss.runstack = MZ_RUNSTACK, ss.runstack_start = MZ_RUNSTACK_START, \
      ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS, \
-     ss.runstack_size = p->runstack_size, ss.runstack_saved = p->runstack_saved)
+     ss.runstack_size = p->runstack_size, ss.runstack_saved = p->runstack_saved, \
+     ss.current_escape_cont_key = p->current_escape_cont_key)
 #define scheme_restore_env_stack_w_thread(ss, p) \
     (MZ_RUNSTACK = ss.runstack, MZ_RUNSTACK_START = ss.runstack_start, \
      MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos, \
-     p->runstack_size = ss.runstack_size, p->runstack_saved = ss.runstack_saved)
+     p->runstack_size = ss.runstack_size, p->runstack_saved = ss.runstack_saved, \
+     p->current_escape_cont_key = ss.current_escape_cont_key)
 #define scheme_save_env_stack(ss) \
     scheme_save_env_stack_w_thread(ss, scheme_current_thread)
 #define scheme_restore_env_stack(ss) \
@@ -1566,7 +1576,8 @@ typedef struct Scheme_Native_Closure_Data {
     Scheme_Object *name;
   } u2;
 #ifdef MZ_PRECISE_GC
-  void *retain_start; /* up to arity_code */
+  void **retained; /* inside code */
+  mzshort retain_count;
 #endif
 } Scheme_Native_Closure_Data;
 

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 301
-#define MZSCHEME_VERSION_MINOR 5
+#define MZSCHEME_VERSION_MINOR 6
 
-#define MZSCHEME_VERSION "301.5" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "301.6" _MZ_SPECIAL_TAG

src/mzscheme/src/struct.c

@@ -81,6 +81,8 @@ static Scheme_Object *struct_type_p(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *struct_info(int argc, Scheme_Object *argv[]);
 static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[]);
+static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[]);
+static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[]);
 static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *struct_setter_p(int argc, Scheme_Object *argv[]);
@@ -367,6 +369,16 @@ scheme_init_struct (Scheme_Env *env)
 						       1, 1,
 						       mzNUM_ST_INFO, mzNUM_ST_INFO),
 			     env);
+  scheme_add_global_constant("struct-type-make-predicate",
+			     scheme_make_prim_w_arity(struct_type_pred,
+						      "struct-type-make-predicate",
+						      1, 1),
+			     env);
+  scheme_add_global_constant("struct-type-make-constructor",
+			     scheme_make_prim_w_arity(struct_type_constr,
+						      "struct-type-make-constructor",
+						      1, 1),
+			     env);
   scheme_add_global_constant("struct->vector",
 			     scheme_make_prim_w_arity(struct_to_vector,
 						      "struct->vector",
@@ -1160,26 +1172,37 @@ static Scheme_Object *struct_info(int argc, Scheme_Object *argv[])
   return scheme_values(2, a);
 }
 
-static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always)
+static Scheme_Object *check_type_and_inspector(const char *who, int always, int argc, Scheme_Object *argv[])
 {
-  Scheme_Struct_Type *stype, *parent;
+  Scheme_Object *insp;
-  Scheme_Object *insp, *ims;
+  Scheme_Struct_Type *stype;
-  int p;
 
   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_type_type))
-    scheme_wrong_type("struct-type-info", "struct-type", 0, argc, argv);
+    scheme_wrong_type(who, "struct-type", 0, argc, argv);
 
   stype = (Scheme_Struct_Type *)argv[0];
 
   insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
 
   if (!always && !scheme_is_subinspector(stype->inspector, insp)) {
-    scheme_arg_mismatch("struct-type-info", 
+    scheme_arg_mismatch(who, 
 			"current inspector cannot extract info for struct-type: ",
 			argv[0]);
-    return;
+    return NULL;
   }
 
+  return insp;
+}
+
+static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always)
+{
+  Scheme_Struct_Type *stype, *parent;
+  Scheme_Object *insp, *ims;
+  int p;
+
+  insp = check_type_and_inspector("struct-type-info", always, argc, argv);
+  stype = (Scheme_Struct_Type *)argv[0];
+
   /* Make sure generic accessor and mutator are created: */
   if (!stype->accessor) {
     Scheme_Object *p;
@@ -1234,6 +1257,34 @@ static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[])
   return scheme_values(mzNUM_ST_INFO, a);
 }
 
+static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[])
+{
+  Scheme_Struct_Type *stype;
+
+  check_type_and_inspector("struct-type-make-predicate", 0, argc, argv);
+  stype = (Scheme_Struct_Type *)argv[0];
+
+  return make_struct_proc(stype, 
+			  scheme_symbol_val(PRED_NAME(scheme_symbol_val(stype->name),
+						      SCHEME_SYM_LEN(stype->name))),
+			  SCHEME_PRED,
+			  stype->num_slots);
+}
+
+static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[])
+{
+  Scheme_Struct_Type *stype;
+
+  check_type_and_inspector("struct-type-make-constructor", 0, argc, argv);
+  stype = (Scheme_Struct_Type *)argv[0];
+
+  return make_struct_proc(stype, 
+			  scheme_symbol_val(CSTR_NAME(scheme_symbol_val(stype->name),
+						      SCHEME_SYM_LEN(stype->name))),
+			  SCHEME_CONSTR,
+			  stype->num_slots);
+}
+
 Scheme_Object *scheme_struct_to_vector(Scheme_Object *_s, Scheme_Object *unknown_val, Scheme_Object *insp)
 {
   Scheme_Structure *s;

src/mzscheme/src/stypes.h

@@ -209,6 +209,9 @@ enum {
   scheme_rt_parameterization,           /* 188 */
   scheme_rt_print_params,               /* 189 */
   scheme_rt_read_params,                /* 190 */
+  scheme_rt_native_code,                /* 191 */
+  scheme_rt_native_code_plus_case,      /* 192 */
+  scheme_rt_jitter_data,                /* 193 */
 #endif
 
   _scheme_last_type_

src/mzscheme/src/thread.c

@@ -2292,6 +2292,8 @@ static void thread_is_dead(Scheme_Thread *r)
   
   r->error_buf = NULL;
   r->overflow_buf = NULL;
+
+  r->spare_runstack = NULL;
 }
 
 static void remove_thread(Scheme_Thread *r)
@@ -3321,6 +3323,7 @@ static void raise_break(Scheme_Thread *p)
   Scheme_Ready_Fun block_check;
   Scheme_Needs_Wakeup_Fun block_needs_wakeup;
   Scheme_Object *a[1];
+  Scheme_Cont_Frame_Data cframe;
 
   p->external_break = 0;
 
@@ -3337,8 +3340,15 @@ static void raise_break(Scheme_Thread *p)
   
   a[0] = scheme_make_prim((Scheme_Prim *)raise_user_break);
 
+  /* Continuation frame ensures that this doesn't
+     look like it's in tail position with respect to
+     an existing escape continuation */
+  scheme_push_continuation_frame(&cframe);
+
   scheme_call_ec(1, a);
 
+  scheme_pop_continuation_frame(&cframe);
+
   /* Continue from break... */
   p->block_descriptor = block_descriptor;
   p->blocker = blocker;

src/mzscheme/src/type.c

@@ -356,6 +356,7 @@ static void MARK_stack_state(Scheme_Stack_State *ss)
   gcMARK(ss->runstack_start);
   ss->runstack = ss->runstack_start + (ss->runstack - old);
   gcMARK(ss->runstack_saved);
+  gcMARK(ss->current_escape_cont_key);
 }
 
 static void FIXUP_stack_state(Scheme_Stack_State *ss)
@@ -366,6 +367,7 @@ static void FIXUP_stack_state(Scheme_Stack_State *ss)
   gcFIXUP(ss->runstack_saved);
   gcFIXUP_TYPED_NOW(Scheme_Object **, ss->runstack_start);
   ss->runstack = ss->runstack_start + (ss->runstack - old);
+  gcFIXUP(ss->current_escape_cont_key);
 }
 
 static void MARK_jmpup(Scheme_Jumpup_Buf *buf)

src/worksp/gc2/make.ss

@@ -9,7 +9,7 @@
   (system s))
 
 (define accounting-gc? #t)
-(define opt-flags "/O2")
+(define opt-flags "/O2 /Oy-")
 (define re:only #f)
 
 (unless (directory-exists? "xsrc")
@@ -30,6 +30,7 @@
     "fun"
     "hash"
     "image"
+    "jit"
     "list"
     "module"
     "network"