suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add support for defining GC traversals through ffi/unsafe

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2016-02-27 20:33:50 -07:00
parent e4f0b69b72
commit 7d90b27524
22 changed files with 300 additions and 260 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

8
pkgs/racket-doc/scribblings/foreign/pointers.scrbl
View File

@ -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]{

4
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -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?])]{

43
pkgs/racket-doc/scribblings/inside/memory.scrbl
View File

@ -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])]{

40
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -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 ---

11
racket/src/foreign/foreign.c
View File

@ -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);

10
racket/src/foreign/foreign.rktc
View File

@ -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 */

61
racket/src/racket/gc2/newgc.c
View File

@ -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;

1
racket/src/racket/gc2/newgc.h
View File

@ -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;

32
racket/src/racket/include/mzwin.def
View File

@ -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

32
racket/src/racket/include/mzwin3m.def
View File

@ -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

32
racket/src/racket/include/racket.exp
View File

@ -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

32
racket/src/racket/include/racket3m.exp
View File

@ -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

4
racket/src/racket/include/scheme.h
View File

@ -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 */
/*========================================================================*/

2
racket/src/racket/src/schemef.h
View File

@ -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 */
/*========================================================================*/

35
racket/src/racket/src/schemex.h
View File

@ -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 */
/*========================================================================*/

32
racket/src/racket/src/schemex.inc
View File

@ -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;

32
racket/src/racket/src/schemexm.h
View File

@ -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)

3
racket/src/racket/src/schpriv.h
View File

@ -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__ */

4
racket/src/racket/src/schvers.h
View File

@ -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)

26
racket/src/racket/src/thread.c
View File

@ -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)

114
racket/src/racket/src/type.c
View File

@ -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