diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 3df9b82f06..3dc16b89f4 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/pkgs/racket-doc/scribblings/foreign/pointers.scrbl b/pkgs/racket-doc/scribblings/foreign/pointers.scrbl index 6abe97692e..86ddb160d0 100644 --- a/pkgs/racket-doc/scribblings/foreign/pointers.scrbl +++ b/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]{ diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index 3225084e58..0ef730aeb7 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/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?])]{ diff --git a/pkgs/racket-doc/scribblings/inside/memory.scrbl b/pkgs/racket-doc/scribblings/inside/memory.scrbl index eabedce650..0fcbc2b92d 100644 --- a/pkgs/racket-doc/scribblings/inside/memory.scrbl +++ b/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])]{ diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index d1398b493f..6ff8283dc4 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/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 --- diff --git a/racket/src/foreign/foreign.c b/racket/src/foreign/foreign.c index 805b571bdd..383e9589ae 100644 --- a/racket/src/foreign/foreign.c +++ b/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 - * one is for using the real malloc) + * 'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'tagged, + * 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); diff --git a/racket/src/foreign/foreign.rktc b/racket/src/foreign/foreign.rktc index 4581da12e6..7fa9356d56 100755 --- a/racket/src/foreign/foreign.rktc +++ b/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 - * one is for using the real malloc) + * 'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'tagged, + * 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 */ diff --git a/racket/src/racket/gc2/newgc.c b/racket/src/racket/gc2/newgc.c index 9a066c2b4a..d48559d745 100644 --- a/racket/src/racket/gc2/newgc.c +++ b/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; - newgc->fixup_table = inheritgc->fixup_table; + memcpy(newgc->mark_table, inheritgc->mark_table, newgc->number_of_tags * sizeof(Mark2_Proc)); + 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; diff --git a/racket/src/racket/gc2/newgc.h b/racket/src/racket/gc2/newgc.h index 8eef234122..e68b9bb822 100644 --- a/racket/src/racket/gc2/newgc.h +++ b/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; diff --git a/racket/src/racket/include/mzwin.def b/racket/src/racket/include/mzwin.def index ede22b69ab..316054f5d4 100644 --- a/racket/src/racket/include/mzwin.def +++ b/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_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_register_type_gc_shape scheme_make_prim scheme_make_noneternal_prim scheme_make_prim_w_arity diff --git a/racket/src/racket/include/mzwin3m.def b/racket/src/racket/include/mzwin3m.def index 8cada188d5..678a1629e3 100644 --- a/racket/src/racket/include/mzwin3m.def +++ b/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_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_register_type_gc_shape scheme_make_prim scheme_make_noneternal_prim scheme_make_prim_w_arity diff --git a/racket/src/racket/include/racket.exp b/racket/src/racket/include/racket.exp index 3cf3a31ea3..a7c4a20d9a 100644 --- a/racket/src/racket/include/racket.exp +++ b/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_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_register_type_gc_shape scheme_make_prim scheme_make_noneternal_prim scheme_make_prim_w_arity diff --git a/racket/src/racket/include/racket3m.exp b/racket/src/racket/include/racket3m.exp index b20a398a31..138f57f2ba 100644 --- a/racket/src/racket/include/racket3m.exp +++ b/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_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_register_type_gc_shape scheme_make_prim scheme_make_noneternal_prim scheme_make_prim_w_arity diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index 9db0aec8cf..271dc216bd 100644 --- a/racket/src/racket/include/scheme.h +++ b/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 */ /*========================================================================*/ diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index 3da9449b4e..8035743213 100644 --- a/racket/src/racket/src/schemef.h +++ b/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 */ /*========================================================================*/ diff --git a/racket/src/racket/src/schemex.h b/racket/src/racket/src/schemex.h index aaf03123f1..595cfe9f7b 100644 --- a/racket/src/racket/src/schemex.h +++ b/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); -/*========================================================================*/ -/* 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); +void (*scheme_register_type_gc_shape)(Scheme_Type type, intptr_t *shape_str); /*========================================================================*/ /* basic Scheme value constructors */ /*========================================================================*/ diff --git a/racket/src/racket/src/schemex.inc b/racket/src/racket/src/schemex.inc index 498a16334c..abd64bbff5 100644 --- a/racket/src/racket/src/schemex.inc +++ b/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_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_register_type_gc_shape = scheme_register_type_gc_shape; 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; diff --git a/racket/src/racket/src/schemexm.h b/racket/src/racket/src/schemexm.h index cfd3512112..83c8a4f78f 100644 --- a/racket/src/racket/src/schemexm.h +++ b/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_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_register_type_gc_shape (scheme_extension_table->scheme_register_type_gc_shape) #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) diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index fa695eab1f..adc01b96d7 100644 --- a/racket/src/racket/src/schpriv.h +++ b/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__ */ diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 910951a726..61762f55d9 100644 --- a/racket/src/racket/src/schvers.h +++ b/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) diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 18b1880e79..89a4c15f86 100644 --- a/racket/src/racket/src/thread.c +++ b/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) - if (process_global_lock) - mzrt_mutex_lock(process_global_lock); -#endif + scheme_process_global_lock(); 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) - if (process_global_lock) - mzrt_mutex_unlock(process_global_lock); -#endif + scheme_process_global_unlock(); 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) diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index fd6dd693c6..f0a2e1434d 100644 --- a/racket/src/racket/src/type.c +++ b/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