add support for defining GC traversals through ffi/unsafe

Expose tagged allocation and a function that interprets a description
of tagged shapes. As a furst cut, the description can only specify
constant offsets for pointers within the object, but future extensions
are possible.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.4.0.9")
+(define version "6.4.0.10")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/foreign/pointers.scrbl

@@ -233,7 +233,7 @@ see @|InsideRacket|.
                                       ctype?) 
                                 @#,elem{absent}]
                  [cptr cpointer? @#,elem{absent}]
-                 [mode (one-of/c 'raw 'atomic 'nonatomic
+                 [mode (one-of/c 'raw 'atomic 'nonatomic 'tagged
                                  'atomic-interior 'interior
                                  'stubborn 'uncollectable 'eternal)
                        @#,elem{absent}]
@@ -266,6 +266,8 @@ specification is required at minimum:
   what allocation function to use.  It should be one of
   @indexed-racket['nonatomic] (uses @cpp{scheme_malloc} from
   Racket's C API), @indexed-racket['atomic]
+  (@cpp{scheme_malloc_atomic}), @indexed-racket['tagged]
+  (@cpp{scheme_malloc_tagged}), @indexed-racket['atomic]
   (@cpp{scheme_malloc_atomic}), @indexed-racket['stubborn]
   (@cpp{scheme_malloc_stubborn}), @indexed-racket['uncollectable]
   (@cpp{scheme_malloc_uncollectable}), @indexed-racket['eternal]
@@ -282,7 +284,9 @@ specification is required at minimum:
 
 If no mode is specified, then @racket['nonatomic] allocation is used
 when the type is a @racket[_gcpointer]- or @racket[_scheme]-based
-type, and @racket['atomic] allocation is used otherwise.}
+type, and @racket['atomic] allocation is used otherwise.
+
+@history[#:changed "6.4.0.10" @elem{Added the @racket['tagged] allocation mode.}]}
 
 
 @defproc[(free [cptr cpointer?]) void]{

pkgs/racket-doc/scribblings/foreign/types.scrbl

@@ -1055,7 +1055,7 @@ members.}
 
 @defproc[(_list-struct [#:alignment alignment (or/c #f 1 2 4 8 16) #f] 
                        [#:malloc-mode malloc-mode
-                                      (one-of/c 'raw 'atomic 'nonatomic
+                                      (one-of/c 'raw 'atomic 'nonatomic 'tagged
                                                  'atomic-interior 'interior
                                                  'stubborn 'uncollectable 'eternal)
                                       'atomic]
@@ -1085,7 +1085,7 @@ below for a more efficient approach.
                               #:define-unsafe)]
          #:contracts ([offset-expr exact-integer?]
                       [alignment-expr (or/c #f 1 2 4 8 16)]
-                      [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic
+                      [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic 'tagged
                                                   'atomic-interior 'interior
                                                   'stubborn 'uncollectable 'eternal)]
                       [prop-expr struct-type-property?])]{

pkgs/racket-doc/scribblings/inside/memory.scrbl

@@ -1130,6 +1130,49 @@ moved before it is fixed. With other implementations, an object might
 be moved after the fixup process, and the result is the location that
 the object will have after garbage collection finished.}
 
+
+@function[(void scheme_register_type_gc_shape [short type]
+                                              [intptr_t* shape])]{
+
+Like @cpp{GC_register_traversers}, but using a set of predefined
+functions that interpret @var{shape} to traverse a value. The
+@var{shape} array is a sequence of commands terminated with
+@cpp{SCHEME_GC_SHAPE_TERM}, where each command has a single argument.
+
+Commands:
+
+@itemlist[
+
+ @item{@tt{#define @cppdef{SCHEME_GC_SHAPE_TERM} 0} --- the terminator
+       command, which has no argument.}
+
+ @item{@tt{#define @cppdef{SCHEME_GC_SHAPE_PTR_OFFSET} 1} ---
+       specifies that a object tagged with @var{type} has a pointer
+       to be made visible to the garbage collector, where the command
+       argument is the offset from the beginning of the object.}
+
+ @item{@tt{#define @cppdef{SCHEME_GC_SHAPE_ADD_SIZE} 2} --- specifies
+       the allocated size of an object tagged with @var{type},
+       where the command argument is an amount to add to an
+       accumulated size; currently, size information is not used, but
+       it may be needed with future implementations of the garbage
+       collector.}
+
+]
+
+To improve forward compatibility, any other command is assumed to take
+a single argument and is ignored.
+
+A GC-shape registration is place-specific, even though
+@cpp{scheme_make_type} creates a type tag that spans places. If a
+traversal is already installed for @cpp{type} in the current place,
+the old traversal specification is replaced. The
+@cpp{scheme_register_type_gc_shape} function keeps its own copy of the
+array @var{shape}, so the array need not be retained.
+
+@history[#:added "6.4.0.10"]}
+
+
 @function[(Scheme_Object* scheme_add_gc_callback [Scheme_Object* pre_desc]
                                                  [Scheme_Object* post_desc])]{
 

pkgs/racket-test-core/tests/racket/foreign-test.rktl

@@ -1126,6 +1126,46 @@
 
 ;; ----------------------------------------
 
+(define scheme_make_type
+  (get-ffi-obj 'scheme_make_type #f (_fun _string -> _short)))
+(define scheme_register_type_gc_shape
+  (get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void)))
+
+(define SHAPE_STR_TERM       0)
+(define SHAPE_STR_PTR_OFFSET 1)
+
+(define-cstruct _tagged ([type-tag _short]
+                         [obj1 _racket]
+                         [non2 _intptr]
+                         [obj3 _racket]
+                         [non4 _intptr])
+  #:define-unsafe
+  #:malloc-mode 'tagged)
+
+(define t (scheme_make_type "new-type"))
+(scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset
+                                       SHAPE_STR_PTR_OFFSET tagged-obj3-offset
+                                       SHAPE_STR_TERM))
+
+(define obj1 (make-string 10))
+(define obj2 (make-bytes 12))
+(define obj3 (make-bytes 14))
+(define obj4 (make-string 16))
+
+(define obj2-addr (cast obj2 _racket _intptr))
+(define obj4-addr (cast obj4 _racket _intptr))
+
+(define o (make-tagged t obj1 obj2-addr obj3 obj4-addr))
+
+(collect-garbage)
+
+(eq? (tagged-obj1 o) obj1)
+(eq? (tagged-obj3 o) obj3)
+(= (tagged-non2 o) obj2-addr)
+(= (tagged-non4 o) obj4-addr)
+
+;; ----------------------------------------
+
 (report-errs)
 
 #| --- ignore everything below ---

racket/src/foreign/foreign.c

@@ -2628,6 +2628,7 @@ static Scheme_Object *eternal_sym;
 static Scheme_Object *interior_sym;
 static Scheme_Object *atomic_interior_sym;
 static Scheme_Object *raw_sym;
+static Scheme_Object *tagged_sym;
 static Scheme_Object *fail_ok_sym;
 
 /* (malloc num type cpointer mode) -> pointer */
@@ -2636,8 +2637,8 @@ static Scheme_Object *fail_ok_sym;
  * - type: malloc the size of this type (or num instances of it),
  * - cpointer: a source pointer to copy contents from,
  * - mode: a symbol for different allocation functions to use - one of
- *   'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'raw (the last
+ *   'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'tagged,
- *   one is for using the real malloc)
+ *   or 'raw (the last one is for using the real malloc)
  * - if an additional 'fail-ok flag is given, then scheme_malloc_fail_ok is
  *   used with the chosen malloc function
  * The arguments can be specified in any order at all since they are all
@@ -2687,7 +2688,8 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
                             "(or/c (and/c exact-nonnegative-integer? fixnum?)\n"
                             "      ctype?\n"
                             "      (or/c 'nonatomic 'stubborn 'uncollectable\n"
-                            "             'eternal 'interior 'atomic-interior 'raw)\n"
+                            "             'eternal 'interior 'atomic-interior\n"
+                            "             'tagged 'raw)\n"
                             "      'fail-on\n"
                             "      (and/c cpointer? (not/c #f)))",
                             i, argc, argv);
@@ -2707,6 +2709,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
   else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_atomic_allow_interior;
   else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
   else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
+  else if (SAME_OBJ(mode, tagged_sym))        mf = scheme_malloc_tagged;
   else {
     scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
     return NULL; /* hush the compiler */
@@ -4410,6 +4413,8 @@ void scheme_init_foreign_globals()
   atomic_interior_sym = scheme_intern_symbol("atomic-interior");
   MZ_REGISTER_STATIC(raw_sym);
   raw_sym = scheme_intern_symbol("raw");
+  MZ_REGISTER_STATIC(tagged_sym);
+  tagged_sym = scheme_intern_symbol("tagged");
   MZ_REGISTER_STATIC(fail_ok_sym);
   fail_ok_sym = scheme_intern_symbol("fail-ok");
   MZ_REGISTER_STATIC(abs_sym);

racket/src/foreign/foreign.rktc

@@ -1863,7 +1863,7 @@ static void* SCHEME2C(const char *who,
 /* Pointer type user functions */
 
 @defsymbols[nonatomic atomic stubborn uncollectable eternal
-            interior atomic-interior raw fail-ok]
+            interior atomic-interior raw tagged fail-ok]
 
 /* (malloc num type cpointer mode) -> pointer */
 /* The arguments for this function are:
@@ -1871,8 +1871,8 @@ static void* SCHEME2C(const char *who,
  * - type: malloc the size of this type (or num instances of it),
  * - cpointer: a source pointer to copy contents from,
  * - mode: a symbol for different allocation functions to use - one of
- *   'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'raw (the last
+ *   'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'tagged,
- *   one is for using the real malloc)
+ *   or 'raw (the last one is for using the real malloc)
  * - if an additional 'fail-ok flag is given, then scheme_malloc_fail_ok is
  *   used with the chosen malloc function
  * The arguments can be specified in any order at all since they are all
@@ -1920,7 +1920,8 @@ static void* SCHEME2C(const char *who,
                             "(or/c (and/c exact-nonnegative-integer? fixnum?)\n"
                             "      ctype?\n"
                             "      (or/c 'nonatomic 'stubborn 'uncollectable\n"
-                            "             'eternal 'interior 'atomic-interior 'raw)\n"
+                            "             'eternal 'interior 'atomic-interior\n"
+                            "             'tagged 'raw)\n"
                             "      'fail-on\n"
                             "      (and/c cpointer? (not/c #f)))", 
                             i, argc, argv);
@@ -1940,6 +1941,7 @@ static void* SCHEME2C(const char *who,
   else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_atomic_allow_interior;
   else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
   else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
+  else if (SAME_OBJ(mode, tagged_sym))        mf = scheme_malloc_tagged;
   else {
     scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
     return NULL; /* hush the compiler */

racket/src/racket/gc2/newgc.c

@@ -81,7 +81,7 @@ static int never_collect_incremental_on_minor = 0;
 /* Use a mark stack when recurring this deep or more: */
 #define MAX_RECUR_MARK_DEPTH 5
 
-/* the maximum number of tags to support for tagged objects */
+/* initial number of tags to support for tagged objects */
 #define NUMBER_OF_TAGS 512
 
 #if 0
@@ -692,9 +692,18 @@ static int master_wants_to_collect();
 #endif
 
 static void NewGC_initialize(NewGC *newgc, NewGC *inheritgc, NewGC *parentgc) {
+
+  if (inheritgc)
+    newgc->number_of_tags = inheritgc->number_of_tags;
+  else
+    newgc->number_of_tags = NUMBER_OF_TAGS;
+
+  newgc->mark_table  = ofm_malloc_zero(newgc->number_of_tags * sizeof(Mark2_Proc));
+  newgc->fixup_table = ofm_malloc_zero(newgc->number_of_tags * sizeof(Fixup2_Proc));
+    
   if (inheritgc) {
-    newgc->mark_table  = inheritgc->mark_table;
+    memcpy(newgc->mark_table, inheritgc->mark_table, newgc->number_of_tags * sizeof(Mark2_Proc));
-    newgc->fixup_table = inheritgc->fixup_table;
+    memcpy(newgc->fixup_table, inheritgc->fixup_table, newgc->number_of_tags * sizeof(Fixup2_Proc));
     newgc->avoid_collection = 0;
 #ifdef MZ_USE_PLACES
     newgc->parent_gc = parentgc;
@@ -703,8 +712,6 @@ static void NewGC_initialize(NewGC *newgc, NewGC *inheritgc, NewGC *parentgc) {
 #ifdef MZ_USE_PLACES
     NewGCMasterInfo_initialize();
 #endif
-    newgc->mark_table  = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark2_Proc)); 
-    newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup2_Proc)); 
 #ifdef NEWGC_BTC_ACCOUNT
     BTC_initialize_mark_table(newgc);
 #endif
@@ -892,7 +899,6 @@ void GC_register_traversers2(short tag, Size2_Proc size, Mark2_Proc mark,
                              Fixup2_Proc fixup, int constant_Size, int atomic)
 {
   NewGC *gc = GC_get_GC();
-
   int mark_tag = tag;
 
 #ifdef NEWGC_BTC_ACCOUNT
@@ -904,6 +910,25 @@ void GC_register_traversers2(short tag, Size2_Proc size, Mark2_Proc mark,
   atomic = 0;
 #endif
 
+  if (tag >= gc->number_of_tags) {
+    Mark2_Proc *mark_table;
+    Fixup2_Proc *fixup_table;
+    int sz = 2 * (int)tag;
+    
+    mark_table  = ofm_malloc_zero(sz * sizeof(Mark2_Proc));
+    fixup_table = ofm_malloc_zero(sz * sizeof(Fixup2_Proc));
+
+    memcpy(mark_table, gc->mark_table, gc->number_of_tags * sizeof(Mark2_Proc));
+    memcpy(fixup_table, gc->fixup_table, gc->number_of_tags * sizeof(Fixup2_Proc));
+
+    ofm_free(gc->mark_table, gc->number_of_tags * sizeof (Mark2_Proc));
+    ofm_free(gc->fixup_table, gc->number_of_tags * sizeof (Fixup2_Proc));
+
+    gc->mark_table = mark_table;
+    gc->fixup_table = fixup_table;
+    gc->number_of_tags = sz;
+  }
+
   gc->mark_table[mark_tag]  = atomic ? (Mark2_Proc)PAGE_ATOMIC : mark;
   gc->fixup_table[tag]      = fixup;
 }
@@ -1063,7 +1088,7 @@ void GC_write_barrier(void *p)
    important meaning. */
 #define MAX_OBJECT_SIZE  (APAGE_SIZE - ((PREFIX_WSIZE + 3) * WORD_SIZE))
 
-#define ASSERT_TAG(tag) GC_ASSERT((tag) >= 0 && (tag) <= NUMBER_OF_TAGS)
+#define ASSERT_TAG(gc, tag) GC_ASSERT((tag) >= 0 && (tag) <= (gc)->number_of_tags)
 #define ASSERT_VALID_OBJPTR(objptr) GC_ASSERT(!((intptr_t)(objptr) & CHECK_ALIGN_MASK))
 #define ASSERT_VALID_INFOPTR(objptr) GC_ASSERT(!(((intptr_t)(objptr) + sizeof(objhead)) & CHECK_ALIGN_MASK))
 
@@ -2774,7 +2799,7 @@ static void push_ptr(NewGC *gc, void *ptr, int inc_gen1)
     }
     if (alloc_type == PAGE_TAGGED) {
       short tag = *(short *)start;
-      ASSERT_TAG(tag);      
+      ASSERT_TAG(gc, tag);      
     }
   }
 #endif
@@ -3195,7 +3220,7 @@ static void mark_recur_or_push_ptr(struct NewGC *gc, void *p, int is_a_master_pa
       {
         const unsigned short tag = *(unsigned short*)p;
         Mark2_Proc markproc;
-        ASSERT_TAG(tag);
+        ASSERT_TAG(gc, tag);
         markproc = gc->mark_table[tag];
         if(((uintptr_t) markproc) >= PAGE_TYPES) {
           GC_ASSERT(markproc);
@@ -3533,7 +3558,7 @@ static inline void mark_traverse_object(NewGC *gc, void **start, void **end, int
       {
         const unsigned short tag = *(unsigned short*)start;
         Mark2_Proc markproc;
-        ASSERT_TAG(tag);
+        ASSERT_TAG(gc, tag);
         markproc = gc->mark_table[tag];
         if(((uintptr_t) markproc) >= PAGE_TYPES) {
           GC_ASSERT(markproc);
@@ -4236,7 +4261,7 @@ static void repair_mixed_page(NewGC *gc, mpage *page, void **end)
         {
           void *obj_start = OBJHEAD_TO_OBJPTR(start);
           unsigned short tag = *(unsigned short *)obj_start;
-          ASSERT_TAG(tag);
+          ASSERT_TAG(gc, tag);
           fixup_table[tag](obj_start, gc);
         }
         break;
@@ -4387,7 +4412,7 @@ static void repair_heap(NewGC *gc)
               if (fixup) {
                 void *obj_start = OBJHEAD_TO_OBJPTR(start);
                 unsigned short tag = *(unsigned short *)obj_start;
-                ASSERT_TAG(tag);
+                ASSERT_TAG(gc, tag);
                 fixup_table[tag](obj_start, gc);
               }
               start += info->size;
@@ -5785,6 +5810,9 @@ static void free_gc(NewGC *gc)
 
   mmu_flush_freed_pages(gc->mmu);
   mmu_free(gc->mmu);
+
+  ofm_free(gc->mark_table, gc->number_of_tags * sizeof(Mark2_Proc));
+  ofm_free(gc->fixup_table, gc->number_of_tags * sizeof(Fixup2_Proc));
 }
 
 void GC_free_all(void)
@@ -5795,9 +5823,6 @@ void GC_free_all(void)
 
   free_gc(gc);
 
-  ofm_free(gc->mark_table, NUMBER_OF_TAGS * sizeof (Mark2_Proc));
-  ofm_free(gc->fixup_table, NUMBER_OF_TAGS * sizeof (Fixup2_Proc));
-
   ofm_free(gc, sizeof(NewGC));
 }
 
@@ -5901,7 +5926,7 @@ void GC_dump_with_traces(int flags,
         if(!info->dead) {
           void *obj_start = OBJHEAD_TO_OBJPTR(start);
           unsigned short tag = *(unsigned short *)obj_start;
-          ASSERT_TAG(tag);
+          ASSERT_TAG(gc, tag);
           if (tag < MAX_DUMP_TAG) {
             counts[tag]++;
             sizes[tag] += info->size;
@@ -5924,7 +5949,7 @@ void GC_dump_with_traces(int flags,
       void **start = PAGE_START_VSS(page);
       void *obj_start = OBJHEAD_TO_OBJPTR(start);
       unsigned short tag = *(unsigned short *)obj_start;
-      ASSERT_TAG(tag);
+      ASSERT_TAG(gc, tag);
       if (tag < MAX_DUMP_TAG) {
         counts[tag]++;
         sizes[tag] += gcBYTES_TO_WORDS(page->size);
@@ -5952,7 +5977,7 @@ void GC_dump_with_traces(int flags,
             if (info->type == PAGE_TAGGED) {
               void *obj_start = OBJHEAD_TO_OBJPTR(start);
               unsigned short tag = *(unsigned short *)obj_start;
-              ASSERT_TAG(tag);
+              ASSERT_TAG(gc, tag);
               if (tag < MAX_DUMP_TAG) {
                 counts[tag]++;
                 sizes[tag] += info->size;

racket/src/racket/gc2/newgc.h

@@ -205,6 +205,7 @@ enum {
 typedef struct NewGC {
   Gen0 gen0;
   Gen_Half gen_half;
+  int number_of_tags;
   Mark2_Proc  *mark_table;   /* the table of mark procs */
   Fixup2_Proc *fixup_table;  /* the table of repair procs */
   PageMap page_maps;

racket/src/racket/include/mzwin.def

@@ -231,37 +231,7 @@ EXPORTS
  scheme_free_immobile_box
  scheme_add_gc_callback
  scheme_remove_gc_callback
- scheme_make_bucket_table
+ scheme_register_type_gc_shape
- scheme_add_to_table
- scheme_change_in_table
- scheme_lookup_in_table
- scheme_bucket_from_table
- scheme_bucket_table_equal
- scheme_clone_bucket_table
- scheme_clear_bucket_table
- scheme_make_hash_table
- scheme_make_hash_table_equal
- scheme_make_hash_table_eqv
- scheme_hash_set
- scheme_hash_get
- scheme_eq_hash_get
- scheme_hash_set_atomic
- scheme_hash_get_atomic
- scheme_hash_table_equal
- scheme_is_hash_table_equal
- scheme_is_hash_table_eqv
- scheme_clone_hash_table
- scheme_clear_hash_table
- scheme_make_hash_tree
- scheme_make_hash_tree_set
- scheme_hash_tree_set
- scheme_hash_tree_get
- scheme_eq_hash_tree_get
- scheme_hash_tree_next
- scheme_hash_tree_index
- scheme_hash_tree_equal
- scheme_is_hash_tree_equal
- scheme_is_hash_tree_eqv
  scheme_make_prim
  scheme_make_noneternal_prim
  scheme_make_prim_w_arity

racket/src/racket/include/mzwin3m.def

@@ -245,37 +245,7 @@ EXPORTS
  scheme_free_immobile_box
  scheme_add_gc_callback
  scheme_remove_gc_callback
- scheme_make_bucket_table
+ scheme_register_type_gc_shape
- scheme_add_to_table
- scheme_change_in_table
- scheme_lookup_in_table
- scheme_bucket_from_table
- scheme_bucket_table_equal
- scheme_clone_bucket_table
- scheme_clear_bucket_table
- scheme_make_hash_table
- scheme_make_hash_table_equal
- scheme_make_hash_table_eqv
- scheme_hash_set
- scheme_hash_get
- scheme_eq_hash_get
- scheme_hash_set_atomic
- scheme_hash_get_atomic
- scheme_hash_table_equal
- scheme_is_hash_table_equal
- scheme_is_hash_table_eqv
- scheme_clone_hash_table
- scheme_clear_hash_table
- scheme_make_hash_tree
- scheme_make_hash_tree_set
- scheme_hash_tree_set
- scheme_hash_tree_get
- scheme_eq_hash_tree_get
- scheme_hash_tree_next
- scheme_hash_tree_index
- scheme_hash_tree_equal
- scheme_is_hash_tree_equal
- scheme_is_hash_tree_eqv
  scheme_make_prim
  scheme_make_noneternal_prim
  scheme_make_prim_w_arity

racket/src/racket/include/racket.exp

@@ -247,37 +247,7 @@ scheme_malloc_immobile_box
 scheme_free_immobile_box
 scheme_add_gc_callback
 scheme_remove_gc_callback
-scheme_make_bucket_table
+scheme_register_type_gc_shape
-scheme_add_to_table
-scheme_change_in_table
-scheme_lookup_in_table
-scheme_bucket_from_table
-scheme_bucket_table_equal
-scheme_clone_bucket_table
-scheme_clear_bucket_table
-scheme_make_hash_table
-scheme_make_hash_table_equal
-scheme_make_hash_table_eqv
-scheme_hash_set
-scheme_hash_get
-scheme_eq_hash_get
-scheme_hash_set_atomic
-scheme_hash_get_atomic
-scheme_hash_table_equal
-scheme_is_hash_table_equal
-scheme_is_hash_table_eqv
-scheme_clone_hash_table
-scheme_clear_hash_table
-scheme_make_hash_tree
-scheme_make_hash_tree_set
-scheme_hash_tree_set
-scheme_hash_tree_get
-scheme_eq_hash_tree_get
-scheme_hash_tree_next
-scheme_hash_tree_index
-scheme_hash_tree_equal
-scheme_is_hash_tree_equal
-scheme_is_hash_tree_eqv
 scheme_make_prim
 scheme_make_noneternal_prim
 scheme_make_prim_w_arity

racket/src/racket/include/racket3m.exp

@@ -252,37 +252,7 @@ scheme_malloc_immobile_box
 scheme_free_immobile_box
 scheme_add_gc_callback
 scheme_remove_gc_callback
-scheme_make_bucket_table
+scheme_register_type_gc_shape
-scheme_add_to_table
-scheme_change_in_table
-scheme_lookup_in_table
-scheme_bucket_from_table
-scheme_bucket_table_equal
-scheme_clone_bucket_table
-scheme_clear_bucket_table
-scheme_make_hash_table
-scheme_make_hash_table_equal
-scheme_make_hash_table_eqv
-scheme_hash_set
-scheme_hash_get
-scheme_eq_hash_get
-scheme_hash_set_atomic
-scheme_hash_get_atomic
-scheme_hash_table_equal
-scheme_is_hash_table_equal
-scheme_is_hash_table_eqv
-scheme_clone_hash_table
-scheme_clear_hash_table
-scheme_make_hash_tree
-scheme_make_hash_tree_set
-scheme_hash_tree_set
-scheme_hash_tree_get
-scheme_eq_hash_tree_get
-scheme_hash_tree_next
-scheme_hash_tree_index
-scheme_hash_tree_equal
-scheme_is_hash_tree_equal
-scheme_is_hash_tree_eqv
 scheme_make_prim
 scheme_make_noneternal_prim
 scheme_make_prim_w_arity

racket/src/racket/include/scheme.h

@@ -1848,6 +1848,10 @@ extern void *scheme_malloc_envunbox(size_t);
 # define MZ_GC_UNREG()                   /* empty */
 #endif
 
+#define SCHEME_GC_SHAPE_TERM       0
+#define SCHEME_GC_SHAPE_PTR_OFFSET 1
+#define SCHEME_GC_SHAPE_ADD_SIZE   2
+
 /*========================================================================*/
 /*                   embedding configuration and hooks                    */
 /*========================================================================*/

racket/src/racket/src/schemef.h

@@ -484,6 +484,8 @@ MZ_EXTERN void scheme_free_immobile_box(void **b);
 MZ_EXTERN Scheme_Object *scheme_add_gc_callback(Scheme_Object *pre, Scheme_Object *post);
 MZ_EXTERN void scheme_remove_gc_callback(Scheme_Object *key);
 
+MZ_EXTERN void scheme_register_type_gc_shape(Scheme_Type type, intptr_t *shape_str);
+
 /*========================================================================*/
 /*                   basic Scheme value constructors                      */
 /*========================================================================*/

racket/src/racket/src/schemex.h

@@ -379,40 +379,7 @@ void **(*scheme_malloc_immobile_box)(void *p);
 void (*scheme_free_immobile_box)(void **b);
 Scheme_Object *(*scheme_add_gc_callback)(Scheme_Object *pre, Scheme_Object *post);
 void (*scheme_remove_gc_callback)(Scheme_Object *key);
-/*========================================================================*/
+void (*scheme_register_type_gc_shape)(Scheme_Type type, intptr_t *shape_str);
-/*                             hash tables                                */
-/*========================================================================*/
-Scheme_Bucket_Table *(*scheme_make_bucket_table)(intptr_t size_hint, int type);
-void (*scheme_add_to_table)(Scheme_Bucket_Table *table, const char *key, void *val, int);
-void (*scheme_change_in_table)(Scheme_Bucket_Table *table, const char *key, void *new_val);
-void *(*scheme_lookup_in_table)(Scheme_Bucket_Table *table, const char *key);
-Scheme_Bucket *(*scheme_bucket_from_table)(Scheme_Bucket_Table *table, const char *key);
-int (*scheme_bucket_table_equal)(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2);
-Scheme_Bucket_Table *(*scheme_clone_bucket_table)(Scheme_Bucket_Table *bt);
-void (*scheme_clear_bucket_table)(Scheme_Bucket_Table *bt);
-Scheme_Hash_Table *(*scheme_make_hash_table)(int type);
-Scheme_Hash_Table *(*scheme_make_hash_table_equal)();
-Scheme_Hash_Table *(*scheme_make_hash_table_eqv)();
-void (*scheme_hash_set)(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
-Scheme_Object *(*scheme_hash_get)(Scheme_Hash_Table *table, Scheme_Object *key);
-Scheme_Object *(*scheme_eq_hash_get)(Scheme_Hash_Table *table, Scheme_Object *key);
-void (*scheme_hash_set_atomic)(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
-Scheme_Object *(*scheme_hash_get_atomic)(Scheme_Hash_Table *table, Scheme_Object *key);
-int (*scheme_hash_table_equal)(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
-int (*scheme_is_hash_table_equal)(Scheme_Object *o);
-int (*scheme_is_hash_table_eqv)(Scheme_Object *o);
-Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *ht);
-void (*scheme_clear_hash_table)(Scheme_Hash_Table *ht);
-Scheme_Hash_Tree *(*scheme_make_hash_tree)(int kind);
-Scheme_Hash_Tree *(*scheme_make_hash_tree_set)(int kind);
-Scheme_Hash_Tree *(*scheme_hash_tree_set)(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val);
-Scheme_Object *(*scheme_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key);
-Scheme_Object *(*scheme_eq_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key);
-mzlonglong (*scheme_hash_tree_next)(Scheme_Hash_Tree *tree, mzlonglong pos);
-int (*scheme_hash_tree_index)(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
-int (*scheme_hash_tree_equal)(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
-int (*scheme_is_hash_tree_equal)(Scheme_Object *o);
-int (*scheme_is_hash_tree_eqv)(Scheme_Object *o);
 /*========================================================================*/
 /*                   basic Scheme value constructors                      */
 /*========================================================================*/

racket/src/racket/src/schemex.inc

@@ -278,37 +278,7 @@
   scheme_extension_table->scheme_free_immobile_box = scheme_free_immobile_box;
   scheme_extension_table->scheme_add_gc_callback = scheme_add_gc_callback;
   scheme_extension_table->scheme_remove_gc_callback = scheme_remove_gc_callback;
-  scheme_extension_table->scheme_make_bucket_table = scheme_make_bucket_table;
+  scheme_extension_table->scheme_register_type_gc_shape = scheme_register_type_gc_shape;
-  scheme_extension_table->scheme_add_to_table = scheme_add_to_table;
-  scheme_extension_table->scheme_change_in_table = scheme_change_in_table;
-  scheme_extension_table->scheme_lookup_in_table = scheme_lookup_in_table;
-  scheme_extension_table->scheme_bucket_from_table = scheme_bucket_from_table;
-  scheme_extension_table->scheme_bucket_table_equal = scheme_bucket_table_equal;
-  scheme_extension_table->scheme_clone_bucket_table = scheme_clone_bucket_table;
-  scheme_extension_table->scheme_clear_bucket_table = scheme_clear_bucket_table;
-  scheme_extension_table->scheme_make_hash_table = scheme_make_hash_table;
-  scheme_extension_table->scheme_make_hash_table_equal = scheme_make_hash_table_equal;
-  scheme_extension_table->scheme_make_hash_table_eqv = scheme_make_hash_table_eqv;
-  scheme_extension_table->scheme_hash_set = scheme_hash_set;
-  scheme_extension_table->scheme_hash_get = scheme_hash_get;
-  scheme_extension_table->scheme_eq_hash_get = scheme_eq_hash_get;
-  scheme_extension_table->scheme_hash_set_atomic = scheme_hash_set_atomic;
-  scheme_extension_table->scheme_hash_get_atomic = scheme_hash_get_atomic;
-  scheme_extension_table->scheme_hash_table_equal = scheme_hash_table_equal;
-  scheme_extension_table->scheme_is_hash_table_equal = scheme_is_hash_table_equal;
-  scheme_extension_table->scheme_is_hash_table_eqv = scheme_is_hash_table_eqv;
-  scheme_extension_table->scheme_clone_hash_table = scheme_clone_hash_table;
-  scheme_extension_table->scheme_clear_hash_table = scheme_clear_hash_table;
-  scheme_extension_table->scheme_make_hash_tree = scheme_make_hash_tree;
-  scheme_extension_table->scheme_make_hash_tree_set = scheme_make_hash_tree_set;
-  scheme_extension_table->scheme_hash_tree_set = scheme_hash_tree_set;
-  scheme_extension_table->scheme_hash_tree_get = scheme_hash_tree_get;
-  scheme_extension_table->scheme_eq_hash_tree_get = scheme_eq_hash_tree_get;
-  scheme_extension_table->scheme_hash_tree_next = scheme_hash_tree_next;
-  scheme_extension_table->scheme_hash_tree_index = scheme_hash_tree_index;
-  scheme_extension_table->scheme_hash_tree_equal = scheme_hash_tree_equal;
-  scheme_extension_table->scheme_is_hash_tree_equal = scheme_is_hash_tree_equal;
-  scheme_extension_table->scheme_is_hash_tree_eqv = scheme_is_hash_tree_eqv;
   scheme_extension_table->scheme_make_prim = scheme_make_prim;
   scheme_extension_table->scheme_make_noneternal_prim = scheme_make_noneternal_prim;
   scheme_extension_table->scheme_make_prim_w_arity = scheme_make_prim_w_arity;

racket/src/racket/src/schemexm.h

@@ -278,37 +278,7 @@
 #define scheme_free_immobile_box (scheme_extension_table->scheme_free_immobile_box)
 #define scheme_add_gc_callback (scheme_extension_table->scheme_add_gc_callback)
 #define scheme_remove_gc_callback (scheme_extension_table->scheme_remove_gc_callback)
-#define scheme_make_bucket_table (scheme_extension_table->scheme_make_bucket_table)
+#define scheme_register_type_gc_shape (scheme_extension_table->scheme_register_type_gc_shape)
-#define scheme_add_to_table (scheme_extension_table->scheme_add_to_table)
-#define scheme_change_in_table (scheme_extension_table->scheme_change_in_table)
-#define scheme_lookup_in_table (scheme_extension_table->scheme_lookup_in_table)
-#define scheme_bucket_from_table (scheme_extension_table->scheme_bucket_from_table)
-#define scheme_bucket_table_equal (scheme_extension_table->scheme_bucket_table_equal)
-#define scheme_clone_bucket_table (scheme_extension_table->scheme_clone_bucket_table)
-#define scheme_clear_bucket_table (scheme_extension_table->scheme_clear_bucket_table)
-#define scheme_make_hash_table (scheme_extension_table->scheme_make_hash_table)
-#define scheme_make_hash_table_equal (scheme_extension_table->scheme_make_hash_table_equal)
-#define scheme_make_hash_table_eqv (scheme_extension_table->scheme_make_hash_table_eqv)
-#define scheme_hash_set (scheme_extension_table->scheme_hash_set)
-#define scheme_hash_get (scheme_extension_table->scheme_hash_get)
-#define scheme_eq_hash_get (scheme_extension_table->scheme_eq_hash_get)
-#define scheme_hash_set_atomic (scheme_extension_table->scheme_hash_set_atomic)
-#define scheme_hash_get_atomic (scheme_extension_table->scheme_hash_get_atomic)
-#define scheme_hash_table_equal (scheme_extension_table->scheme_hash_table_equal)
-#define scheme_is_hash_table_equal (scheme_extension_table->scheme_is_hash_table_equal)
-#define scheme_is_hash_table_eqv (scheme_extension_table->scheme_is_hash_table_eqv)
-#define scheme_clone_hash_table (scheme_extension_table->scheme_clone_hash_table)
-#define scheme_clear_hash_table (scheme_extension_table->scheme_clear_hash_table)
-#define scheme_make_hash_tree (scheme_extension_table->scheme_make_hash_tree)
-#define scheme_make_hash_tree_set (scheme_extension_table->scheme_make_hash_tree_set)
-#define scheme_hash_tree_set (scheme_extension_table->scheme_hash_tree_set)
-#define scheme_hash_tree_get (scheme_extension_table->scheme_hash_tree_get)
-#define scheme_eq_hash_tree_get (scheme_extension_table->scheme_eq_hash_tree_get)
-#define scheme_hash_tree_next (scheme_extension_table->scheme_hash_tree_next)
-#define scheme_hash_tree_index (scheme_extension_table->scheme_hash_tree_index)
-#define scheme_hash_tree_equal (scheme_extension_table->scheme_hash_tree_equal)
-#define scheme_is_hash_tree_equal (scheme_extension_table->scheme_is_hash_tree_equal)
-#define scheme_is_hash_tree_eqv (scheme_extension_table->scheme_is_hash_tree_eqv)
 #define scheme_make_prim (scheme_extension_table->scheme_make_prim)
 #define scheme_make_noneternal_prim (scheme_extension_table->scheme_make_noneternal_prim)
 #define scheme_make_prim_w_arity (scheme_extension_table->scheme_make_prim_w_arity)

racket/src/racket/src/schpriv.h

@@ -4599,4 +4599,7 @@ void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo);
 Scheme_Object *scheme_place_async_channel_receive(Scheme_Object *ch);
 #endif
 
+void scheme_process_global_lock(void);
+void scheme_process_global_unlock(void);
+
 #endif /* __mzscheme_private__ */

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.4.0.9"
+#define MZSCHEME_VERSION "6.4.0.10"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 4
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 9
+#define MZSCHEME_VERSION_W 10
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/thread.c

@@ -2616,10 +2616,7 @@ void *scheme_register_process_global(const char *key, void *val)
   Proc_Global_Rec *pg;
   intptr_t len;
 
-#if defined(MZ_USE_MZRT)
+  scheme_process_global_lock();
-  if (process_global_lock)
-    mzrt_mutex_lock(process_global_lock);
-#endif
 
   for (pg = process_globals; pg; pg = pg->next) {
     if (!strcmp(pg->key, key)) {
@@ -2639,10 +2636,7 @@ void *scheme_register_process_global(const char *key, void *val)
     process_globals = pg;
   }
 
-#if defined(MZ_USE_MZRT)
+  scheme_process_global_unlock();
-  if (process_global_lock)
-    mzrt_mutex_unlock(process_global_lock);
-#endif
 
   return old_val;
 }
@@ -2654,6 +2648,22 @@ void scheme_init_process_globals(void)
 #endif
 }
 
+void scheme_process_global_lock(void)
+{
+#if defined(MZ_USE_MZRT)
+  if (process_global_lock)
+    mzrt_mutex_lock(process_global_lock);
+#endif
+}
+
+void scheme_process_global_unlock(void)
+{
+#if defined(MZ_USE_MZRT)
+  if (process_global_lock)
+    mzrt_mutex_unlock(process_global_lock);
+#endif
+}
+
 Scheme_Hash_Table *scheme_get_place_table(void)
 {
   if (!place_local_misc_table)

racket/src/racket/src/type.c

@@ -747,3 +747,117 @@ void scheme_register_traversers(void)
 END_XFORM_SKIP;
 
 #endif
+
+/***********************************************************************/
+
+#ifdef MZ_PRECISE_GC
+
+/* A shape string is a SCHEME_GC_SHAPE_TERM-terminated array of `intptr_t`s,
+   where each instruction is followed by a value. For now, the only
+   required instructions are SCHEME_GC_SHAPE_PTR_OFFSET, but other values
+   are tolerated and ignored for future extensions in case they become
+   necessary. */
+
+static int shape_str_array_size = 0;
+static intptr_t **shape_strs = NULL;
+
+START_XFORM_SKIP;
+
+static int shape_size(void *p, struct NewGC *gc) {
+#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS
+  intptr_t *shape_str = shape_strs[*(Scheme_Type *)p];
+  int sz = 0;
+  while (*shape_str != SCHEME_GC_SHAPE_TERM) {
+    if (shape_str[0] == SCHEME_GC_SHAPE_ADD_SIZE)
+      sz += shape_str[1];
+    shape_str += 2;
+  }
+#else
+  return 0;
+#endif
+}
+
+static int shape_mark(void *p, struct NewGC *gc) {
+#ifndef GC_NO_MARK_PROCEDURE_NEEDED
+  intptr_t *shape_str = shape_strs[*(Scheme_Type *)p];
+
+  while (*shape_str != SCHEME_GC_SHAPE_TERM) {
+    if (shape_str[0] == SCHEME_GC_SHAPE_PTR_OFFSET) {
+      gcMARK2(*(void **)((char *)p + shape_str[1]), gc);
+    }
+    shape_str += 2;
+  }
+
+# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
+  return 0;
+# else
+  return shape_size(p, gc);
+# endif
+#endif
+}
+
+static int shape_fixup(void *p, struct NewGC *gc) {
+#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
+  intptr_t *shape_str = shape_strs[*(Scheme_Type *)p];
+
+  while (*shape_str != SCHEME_GC_SHAPE_TERM) {
+    if (shape_str[0] == SCHEME_GC_SHAPE_PTR_OFFSET) {
+      gcFIXUP2(*(void **)((char *)p + shape_str[1]), gc);
+    }
+    shape_str += 2;
+  }
+
+# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
+  return 0;
+# else
+  return shape_size(p, gc);
+# endif
+#endif
+}
+
+END_XFORM_SKIP;
+
+void scheme_register_type_gc_shape(Scheme_Type type, intptr_t *shape_str)
+{
+  intptr_t len;
+  GC_CAN_IGNORE intptr_t *str;
+
+  for (len = 0; shape_str[len] != SCHEME_GC_SHAPE_TERM; len += 2) {
+  }
+  len++;
+
+  str = (intptr_t *)malloc(len * sizeof(intptr_t));
+  memcpy(str, shape_str, len * sizeof(intptr_t));
+
+  scheme_process_global_lock();
+
+  if (shape_str_array_size <= type) {
+    GC_CAN_IGNORE intptr_t **naya;
+    int sz = 2 * (type + 1);
+    naya = malloc(sz * sizeof(intptr_t *));
+    memset(naya, 0, sz * sizeof(intptr_t *));
+    if (shape_str_array_size) {
+      memcpy(naya, shape_strs, sizeof(intptr_t *) * shape_str_array_size);
+      free(shape_strs);
+    }
+    shape_strs = naya;
+    shape_str_array_size = sz;
+  }
+
+  if (shape_strs[type])
+    free(shape_strs[type]);
+  shape_strs[type] = str;
+  
+  scheme_process_global_unlock();
+
+  GC_register_traversers2(type, shape_size, shape_mark, shape_fixup, 1, 0);
+}
+
+#else
+
+void scheme_register_type_gc_shape(Scheme_Type type, intptr_t *shape_str)
+{
+  
+}
+
+#endif