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

overhaul GC finalization

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-25 06:17:24 -06:00
parent 73dd8cc697
commit 40a65a46d2
28 changed files with 203 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/ffi/unsafe.rkt
View File

@ -1473,10 +1473,11 @@
regexp-replace regexp-replace*)
(caar rs) str (cadar rs)) (cdr rs)))))
;; A facility for running finalizers using executors. #%foreign has a C-based
;; version that uses finalizers, but that leads to calling Scheme from the GC
;; which is not a good idea.
(define killer-executor (make-will-executor))
;; A facility for running finalizers using executors. The "stubborn" kind
;; of will executor is provided by '#%foreign, and it doesn't get GC'ed if
;; any finalizers are attached to it (while the normal kind can get GCed
;; even if a thread that is otherwise inaccessible is blocked on the executor).
(define killer-executor (make-stubborn-will-executor))
(define killer-thread #f)
(define* (register-finalizer obj finalizer)
@ -1487,4 +1488,3 @@
(thread (lambda ()
(let loop () (will-execute killer-executor) (loop))))))))
(will-register killer-executor obj finalizer))

7
collects/ffi/unsafe/alloc.rkt
View File

@ -1,7 +1,6 @@
#lang scheme/base
(require scheme/foreign
#lang racket/base
(require ffi/unsafe
"atomic.ss")
(unsafe!)
(provide allocator deallocator retainer
(rename-out [deallocator releaser]))
@ -42,7 +41,7 @@
(when ds
(if (null? (cdr ds))
(hash-remove! allocated v)
(hash-set! allocated (cdr ds)))))))
(hash-set! allocated v (cdr ds)))))))
end-atomic))
proc))

7
collects/ffi/unsafe/atomic.rkt
View File

@ -1,7 +1,6 @@
#lang scheme/base
(require scheme/foreign
(for-syntax scheme/base))
(unsafe!)
#lang racket/base
(require ffi/unsafe
(for-syntax racket/base))
(provide (protect-out start-atomic
end-atomic

7
collects/ffi/unsafe/define.rkt
View File

@ -1,8 +1,7 @@
#lang scheme/base
#lang racket/base
(require (for-syntax syntax/parse
scheme/base)
scheme/foreign)
(unsafe!)
racket/base)
ffi/unsafe)
(provide (protect-out define-ffi-definer)
provide-protected

1
collects/racket/draw/font.rkt
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require scheme/class
ffi/unsafe
ffi/unsafe/atomic
"syntax.ss"
"pango.ss"

8
collects/scribblings/inside/memory.scrbl
View File

@ -915,16 +915,16 @@ To remove an added finalizer, use @cpp{scheme_subtract_finalizer}.}
[void* data])]{
Installs a ``will''-like finalizer, similar to @scheme[will-register].
Scheme finalizers are called one at a time, requiring the collector
Will-like finalizers are called one at a time, requiring the collector
to prove that a value has become inaccessible again before calling
the next Racket finalizer. Finalizers registered with
the next will-like finalizer. Finalizers registered with
@cpp{scheme_register_finalizer} or @cpp{scheme_add_finalizer} are
not called until all Racket finalizers have been exhausted.
not called until all will-like finalizers have been exhausted.
See @cpp{scheme_register_finalizer}, above, for information about
the arguments.
There is currently no facility to remove a ``will''-like finalizer.}
There is currently no facility to remove a will-like finalizer.}
@function[(void scheme_add_finalizer_once
[void* p]

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Internal: weak boxes are cleared before non-will-like
finalizers; use late-weak boxes to get the old behavior
Version 5.0.2, October 2010
Changed body of `when', `unless', `cond' clauses, `case'
clauses, and `match' clauses to be internal-definition contexts

16
src/foreign/foreign.c
View File

@ -2963,7 +2963,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
{
/* put data in immobile, weak box */
void **tmp;
tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0));
tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1));
cl_cif_args->data = (struct immobile_box*)tmp;
}
# else /* MZ_PRECISE_GC undefined */
@ -3023,6 +3023,16 @@ static Scheme_Object *foreign_lookup_errno(int argc, Scheme_Object *argv[])
/*****************************************************************************/
/* (make-stubborn-will-executor) -> #<will-executor> */
#define MYNAME "make-stubborn-will-executor"
static Scheme_Object *foreign_make_stubborn_will_executor(int argc, Scheme_Object *argv[])
{
return scheme_make_stubborn_will_executor();
}
#undef MYNAME
/*****************************************************************************/
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
char *str;
@ -3189,6 +3199,8 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_saved_errno, "saved-errno", 0, 0), menv);
scheme_add_global("lookup-errno",
scheme_make_prim_w_arity(foreign_lookup_errno, "lookup-errno", 1, 1), menv);
scheme_add_global("make-stubborn-will-executor",
scheme_make_prim_w_arity(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
@ -3487,6 +3499,8 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "saved-errno", 0, 0), menv);
scheme_add_global("lookup-errno",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), menv);
scheme_add_global("make-stubborn-will-executor",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-stubborn-will-executor", 0, 0), menv);
scheme_add_global("_void", scheme_false, menv);
scheme_add_global("_int8", scheme_false, menv);
scheme_add_global("_uint8", scheme_false, menv);

9
src/foreign/foreign.rktc
View File

@ -2322,7 +2322,7 @@ void free_cl_cif_args(void *ignored, void *p)
{
/* put data in immobile, weak box */
void **tmp;
tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0));
tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1));
cl_cif_args->data = (struct immobile_box*)tmp;
}
}{
@ -2382,6 +2382,13 @@ static void save_errno_values(int kind)
/*****************************************************************************/
/* (make-stubborn-will-executor) -> #<will-executor> */
@cdefine[make-stubborn-will-executor 0]{
return scheme_make_stubborn_will_executor();
}
/*****************************************************************************/
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
char *str;

6
src/racket/gc/finalize.c
View File

@ -147,6 +147,12 @@ int GC_register_disappearing_link(void * * link)
return(GC_general_register_disappearing_link(link, base));
}
/* PLTSCHEME: GC_register_indirect_disappearing_link */
GC_API void GC_register_indirect_disappearing_link(void **link, void *obj)
{
GC_general_register_disappearing_link(link, obj);
}
/* PLTSCHEME: GC_register_late_disappearing_link */
static int late_dl; /* a stupid way to pass arguments (to minimize my changes). */
GC_API void GC_register_late_disappearing_link(void **link, void *obj)

44
src/racket/gc2/README
View File

@ -146,6 +146,10 @@ Racket allocates the following kinds of memory objects:
`secondary + soffset' is zeroed, the `secondary' pointer in the
weak box should also be zeroed.
* Late Weak Box - A weak box that holds onto its reference until
level-2 finalizers are queued (see below). Late weak boxes are
created with GC_malloc_late_weak_box().
* Weak Array - The object has the following structure:
struct {
@ -206,12 +210,8 @@ This function installs a finalizer to be queued for invocation when
`p' would otherwise be collected. All ready finalizers should be
called at the end of a collection. (A finalization can trigger calls
back to the collector, but such a collection will not run more
finalizers.)
The `p' object isn't actually collected when a finalizer is queued,
since the finalizer will receive `p' as an argument. (Hence, weak
references aren't zeroed, either.) `p' must point to the beginning of
a tagged (if `tagged' is 1) or xtagged (if `tagged' is 0) object.
finalizers.) The `p' argument must point to the beginning of a tagged
(if `tagged' is 1) or xtagged (if `tagged' is 0) object.
The `level' argument refers to an ordering of finalizers. It can be 1,
2, or 3. During a collection, level 1 finalizers are queued first,
@ -220,36 +220,20 @@ traversed. Next, level 2 finalizers are queued in the same way. Thus,
if a level 1 object refers to a level 2 object, the level 1 object
will be queued for finalization, and only sometime after the finalizer
is run and the object is again no longer referenced can the level 2
object be finalized.
Level 3 finalizers are even later. Not only are they after level 1 and
2, but a level 3 finalizer is only enqueued if no other level-3
finalizer refers to the object. Note that cycles among level-3
finalizers can prevent finalization and collection. (But it's also
possible that other finalizers will break a finalization cycle among a
set of level 3 finalizers.)
object be finalized. Finally, level 3 finalizers are queued.
The `f' and `data' arguments define the finalizer closure to be called
for `p'. If a finalizer is already installed for `p', it is replaced,
and `oldf' and `olddata' are filled with the old closure. If `f' is
NULL, any existing finalizer is removed and no new one is
installed.
installed. The single-callback rulle applies across level 1 and level
2 finalizers (but scheme_register_finalizer(), etc., in "salloc.c" can
merge them).
To break cycles among level-3 finalizers, the collector must also
provide GC_finalization_weak_ptr():
void GC_finalization_weak_ptr(void **p, int offset);
This function registers the address of a "weak" pointer for level-3
finalization. When checking for references among level-3 finalized
objects, `*(p + offset)' is set to NULL. The mark procedure for the
object `p' will see the NULL value, preventing it from marking
whatever `p + object' normally references. After level-3 finalizers
are enqueued, `*(p + offset)' is reset to its original value (and
marked if the object `p' is already marked).
When the object `p' is collected, all weak pointer registrations are
removed automatically.
The `p' object isn't actually collected when a finalizer is queued,
since the finalizer will receive `p' as an argument. Weak references
are cleared after level 1 fnalizers are queued, while "late weak box"
references are cleared after level 2 finalizers are clear.
Functions versus Macros
-----------------------

2
src/racket/gc2/commongc_internal.h
View File

@ -30,7 +30,7 @@ typedef struct GC_Weak_Box {
void *val;
/* The rest is up to us: */
void **secondary_erase;
int soffset;
int soffset, is_late;
struct GC_Weak_Box *next;
} GC_Weak_Box;

6
src/racket/gc2/gc2.h
View File

@ -242,7 +242,7 @@ GC2_EXTERN void GC_free(void *);
Lets the collector optionally reverse an allocation immediately.
[Generally a no-op.] */
GC2_EXTERN void *GC_malloc_weak_box(void *p, void **secondary, int soffset);
GC2_EXTERN void *GC_malloc_weak_box(void *p, void **secondary, int soffset, int is_late);
/*
Allocate a weak box. See README for details. */
@ -282,10 +282,6 @@ GC2_EXTERN void GC_set_finalizer(void *p, int tagged, int level,
/*
See README for details. */
GC2_EXTERN void GC_finalization_weak_ptr(void **p, int offset);
/*
See README for details. */
/***************************************************************************/
/* Cooperative GC */
/***************************************************************************/

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

@ -1911,89 +1911,6 @@ inline static void check_finalizers(NewGC *gc, int level)
}
}
inline static void do_ordered_level3(NewGC *gc)
{
struct finalizer *temp;
Mark2_Proc *mark_table = gc->mark_table;
for(temp = GC_resolve(gc->finalizers); temp; temp = GC_resolve(temp->next))
if(!marked(gc, temp->p)) {
GCDEBUG((DEBUGOUTF,
"LVL3: %p is not marked. Marking payload (%p)\n",
temp, temp->p));
set_backtrace_source(temp, BT_FINALIZER);
if(temp->tagged) mark_table[*(unsigned short*)temp->p](temp->p, gc);
if(!temp->tagged) GC_mark_xtagged(temp->p);
}
}
void GC_finalization_weak_ptr(void **p, int offset)
{
NewGC *gc = GC_get_GC();
Weak_Finalizer *wfnl;
gc->park[0] = p; wfnl = GC_malloc_atomic(sizeof(Weak_Finalizer));
p = gc->park[0]; gc->park[0] = NULL;
wfnl->p = p; wfnl->offset = offset * sizeof(void*); wfnl->saved = NULL;
wfnl->next = gc->weak_finalizers; gc->weak_finalizers = wfnl;
}
inline static void mark_weak_finalizer_structs(NewGC *gc)
{
Weak_Finalizer *work;
GCDEBUG((DEBUGOUTF, "MARKING WEAK FINALIZERS.\n"));
for(work = gc->weak_finalizers; work; work = work->next) {
set_backtrace_source(&gc->weak_finalizers, BT_ROOT);
gcMARK2(work, gc);
}
}
inline static void repair_weak_finalizer_structs(NewGC *gc)
{
Weak_Finalizer *work;
Weak_Finalizer *prev;
gcFIXUP2(gc->weak_finalizers, gc);
work = gc->weak_finalizers; prev = NULL;
while(work) {
gcFIXUP2(work->next, gc);
if(!marked(gc, work->p)) {
if(prev) prev->next = work->next;
if(!prev) gc->weak_finalizers = work->next;
work = GC_resolve(work->next);
} else {
gcFIXUP2(work->p, gc);
prev = work;
work = work->next;
}
}
}
inline static void zero_weak_finalizers(NewGC *gc)
{
Weak_Finalizer *wfnl;
for(wfnl = GC_resolve(gc->weak_finalizers); wfnl; wfnl = GC_resolve(wfnl->next)) {
wfnl->saved = *(void**)(NUM(GC_resolve(wfnl->p)) + wfnl->offset);
*(void**)(NUM(GC_resolve(wfnl->p)) + wfnl->offset) = NULL;
}
}
inline static void reset_weak_finalizers(NewGC *gc)
{
Weak_Finalizer *wfnl;
for(wfnl = GC_resolve(gc->weak_finalizers); wfnl; wfnl = GC_resolve(wfnl->next)) {
if(marked(gc, wfnl->p)) {
set_backtrace_source(wfnl, BT_WEAKLINK);
gcMARK2(wfnl->saved, gc);
}
*(void**)(NUM(GC_resolve(wfnl->p)) + wfnl->offset) = wfnl->saved;
wfnl->saved = NULL;
}
}
/*****************************************************************************/
/* weak boxes and arrays */
/*****************************************************************************/
@ -4152,7 +4069,6 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master)
mark_backpointers(gc);
TIME_STEP("backpointered");
mark_finalizer_structs(gc);
mark_weak_finalizer_structs(gc);
TIME_STEP("pre-rooted");
mark_roots(gc);
mark_immobiles(gc);
@ -4175,16 +4091,12 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master)
check_finalizers(gc, 1);
propagate_marks_plus_ephemerons(gc);
check_finalizers(gc, 2);
propagate_marks_plus_ephemerons(gc);
TIME_STEP("marked");
zero_weak_boxes(gc, 0);
zero_weak_arrays(gc);
zero_remaining_ephemerons(gc);
if(gc->gc_full) zero_weak_finalizers(gc);
do_ordered_level3(gc); propagate_marks(gc);
check_finalizers(gc, 3); propagate_marks(gc);
if(gc->gc_full) {
reset_weak_finalizers(gc);
propagate_marks(gc);
}
#ifndef NEWGC_BTC_ACCOUNT
/* we need to clear out the stack pages. If we're doing memory accounting,
though, we might as well leave them up for now and let the accounting
@ -4194,14 +4106,17 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master)
clear_stack_pages(gc);
#endif
TIME_STEP("marked");
zero_weak_boxes(gc);
zero_weak_arrays(gc);
zero_remaining_ephemerons(gc);
TIME_STEP("zeroed");
check_finalizers(gc, 2);
propagate_marks(gc);
zero_weak_boxes(gc, 1);
check_finalizers(gc, 3);
propagate_marks(gc);
TIME_STEP("finalized2");
if(gc->gc_full)
#ifdef MZ_USE_PLACES
if (premaster_or_place_gc(gc) || switching_master)
@ -4217,7 +4132,6 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master)
#endif
TIME_STEP("cleaned");
repair_finalizer_structs(gc);
repair_weak_finalizer_structs(gc);
repair_roots(gc);
repair_immobiles(gc);
#ifdef MZ_USE_PLACES

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

@ -68,13 +68,6 @@ typedef struct MarkSegment {
void **top;
} MarkSegment;
typedef struct Weak_Finalizer {
void *p;
int offset;
void *saved;
struct Weak_Finalizer *next;
} Weak_Finalizer;
typedef struct GC_Thread_Info {
void *thread;
int owner;
@ -154,7 +147,6 @@ typedef struct NewGC {
/* Finalization */
Fnl *run_queue;
Fnl *last_in_queue;
Weak_Finalizer *weak_finalizers;
struct NewGC *primoridal_gc;
unsigned long max_heap_size;
@ -239,7 +231,7 @@ typedef struct NewGC {
Roots roots;
GC_Weak_Array *weak_arrays;
GC_Weak_Box *weak_boxes;
GC_Weak_Box *weak_boxes[2];
GC_Ephemeron *ephemerons;
int num_last_seen_ephemerons;
struct MMU *mmu;

25
src/racket/gc2/weak.c
View File

@ -143,8 +143,8 @@ static int mark_weak_box(void *p, struct NewGC *gc)
gcMARK2(wb->secondary_erase, gc);
if (wb->val) {
wb->next = gc->weak_boxes;
gc->weak_boxes = wb;
wb->next = gc->weak_boxes[wb->is_late];
gc->weak_boxes[wb->is_late] = wb;
}
return gcBYTES_TO_WORDS(sizeof(GC_Weak_Box));
@ -160,7 +160,7 @@ static int fixup_weak_box(void *p, struct NewGC *gc)
return gcBYTES_TO_WORDS(sizeof(GC_Weak_Box));
}
void *GC_malloc_weak_box(void *p, void **secondary, int soffset)
void *GC_malloc_weak_box(void *p, void **secondary, int soffset, int is_late)
{
GCTYPE *gc = GC_get_GC();
GC_Weak_Box *w;
@ -179,25 +179,38 @@ void *GC_malloc_weak_box(void *p, void **secondary, int soffset)
w->type = gc->weak_box_tag;
w->val = p;
w->secondary_erase = secondary;
w->is_late = is_late;
w->soffset = soffset;
return w;
}
static void init_weak_boxes(GCTYPE *gc) {
gc->weak_boxes = NULL;
gc->weak_boxes[0] = NULL;
gc->weak_boxes[1] = NULL;
}
static void zero_weak_boxes(GCTYPE *gc)
static void zero_weak_boxes(GCTYPE *gc, int is_late)
{
GC_Weak_Box *wb;
wb = gc->weak_boxes;
wb = gc->weak_boxes[is_late];
while (wb) {
if (!is_marked(gc, wb->val)) {
wb->val = NULL;
if (wb->secondary_erase) {
void **p;
mpage *page;
/* it's possible for the secondary to be in an old generation
and therefore on an mprotected page: */
page = pagemap_find_page(gc->page_maps, wb->secondary_erase);
if (page->mprotected) {
page->mprotected = 0;
mmu_write_unprotect_page(gc->mmu, page->addr, APAGE_SIZE);
GC_MP_CNT_INC(mp_mark_cnt);
}
p = (void **)GC_resolve(wb->secondary_erase);
*(p + wb->soffset) = NULL;
wb->secondary_erase = NULL;

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

@ -189,6 +189,8 @@ EXPORTS
scheme_strdup
scheme_strdup_eternal
scheme_malloc_fail_ok
scheme_late_weak_reference
scheme_late_weak_reference_indirect
scheme_weak_reference
scheme_weak_reference_indirect
scheme_unweak_reference
@ -562,9 +564,11 @@ EXPORTS
scheme_unbox
scheme_set_box
scheme_make_weak_box
scheme_make_late_weak_box
scheme_make_ephemeron
scheme_ephemeron_value
scheme_ephemeron_key
scheme_make_stubborn_will_executor
scheme_load
scheme_load_extension
scheme_register_extension_global

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

@ -198,6 +198,8 @@ EXPORTS
scheme_strdup
scheme_strdup_eternal
scheme_malloc_fail_ok
scheme_late_weak_reference
scheme_late_weak_reference_indirect
scheme_weak_reference
scheme_weak_reference_indirect
scheme_unweak_reference
@ -578,9 +580,11 @@ EXPORTS
scheme_unbox
scheme_set_box
scheme_make_weak_box
scheme_make_late_weak_box
scheme_make_ephemeron
scheme_ephemeron_value
scheme_ephemeron_key
scheme_make_stubborn_will_executor
scheme_load
scheme_load_extension
scheme_register_extension_global

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

@ -201,6 +201,8 @@ scheme_calloc
scheme_strdup
scheme_strdup_eternal
scheme_malloc_fail_ok
scheme_late_weak_reference
scheme_late_weak_reference_indirect
scheme_weak_reference
scheme_weak_reference_indirect
scheme_unweak_reference
@ -579,9 +581,11 @@ scheme_box
scheme_unbox
scheme_set_box
scheme_make_weak_box
scheme_make_late_weak_box
scheme_make_ephemeron
scheme_ephemeron_value
scheme_ephemeron_key
scheme_make_stubborn_will_executor
scheme_load
scheme_load_extension
scheme_register_extension_global

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

@ -206,6 +206,8 @@ scheme_calloc
scheme_strdup
scheme_strdup_eternal
scheme_malloc_fail_ok
scheme_late_weak_reference
scheme_late_weak_reference_indirect
scheme_weak_reference
scheme_weak_reference_indirect
scheme_unweak_reference
@ -586,9 +588,11 @@ scheme_box
scheme_unbox
scheme_set_box
scheme_make_weak_box
scheme_make_late_weak_box
scheme_make_ephemeron
scheme_ephemeron_value
scheme_ephemeron_key
scheme_make_stubborn_will_executor
scheme_load
scheme_load_extension
scheme_register_extension_global

2
src/racket/src/hash.c
View File

@ -714,7 +714,7 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
if (table->weak) {
#ifdef MZ_PRECISE_GC
void *kb;
kb = GC_malloc_weak_box((void *)key, (void **)bucket, (void **)&bucket->val - (void **)bucket);
kb = GC_malloc_weak_box((void *)key, (void **)bucket, (void **)&bucket->val - (void **)bucket, 0);
bucket->key = (char *)kb;
#else
char *kb;

20
src/racket/src/list.c
View File

@ -3068,7 +3068,7 @@ static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[])
Scheme_Object *scheme_make_weak_box(Scheme_Object *v)
{
#ifdef MZ_PRECISE_GC
return (Scheme_Object *)GC_malloc_weak_box(v, NULL, 0);
return (Scheme_Object *)GC_malloc_weak_box(v, NULL, 0, 0);
#else
Scheme_Small_Object *obj;
@ -3083,6 +3083,24 @@ Scheme_Object *scheme_make_weak_box(Scheme_Object *v)
#endif
}
Scheme_Object *scheme_make_late_weak_box(Scheme_Object *v)
{
#ifdef MZ_PRECISE_GC
return (Scheme_Object *)GC_malloc_weak_box(v, NULL, 0, 1);
#else
Scheme_Small_Object *obj;
obj = MALLOC_ONE_TAGGED_WEAK(Scheme_Small_Object);
obj->iso.so.type = scheme_weak_box_type;
obj->u.ptr_val = v;
scheme_late_weak_reference((void **)(void *)&obj->u.ptr_val);
return (Scheme_Object *)obj;
#endif
}
static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[])
{
return scheme_make_weak_box(argv[0]);

25
src/racket/src/salloc.c
View File

@ -82,6 +82,7 @@ void **GC_variable_stack;
#ifndef MZ_PRECISE_GC
extern MZ_DLLIMPORT void GC_register_late_disappearing_link(void **link, void *obj);
extern MZ_DLLIMPORT void GC_register_indirect_disappearing_link(void **link, void *obj);
#endif
SHARED_OK static int use_registered_statics;
@ -1197,7 +1198,7 @@ START_XFORM_SKIP;
END_XFORM_SKIP;
#define GC_register_eager_finalizer(o, level, f, d, of, od) GC_set_finalizer(o, 1, level, f, d, of, od)
#define GC_register_finalizer(o, f, d, of, od) GC_set_finalizer(o, 1, 3, f, d, of, od)
#define GC_register_finalizer(o, f, d, of, od) GC_set_finalizer(o, 1, 1, f, d, of, od)
#endif
@ -1304,11 +1305,16 @@ static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
if (oldf) {
if (oldf != do_next_finalization) {
/* This happens if an extenal use of GC_ routines conflicts with us. */
scheme_warning("warning: non-Racket finalization on object dropped!");
scheme_warning("warning: non-Racket finalization on object dropped! %lx %lx",
(long)oldf, (long)olddata);
} else {
*fns_ptr = *(Finalizations **)olddata;
save_fns_ptr = (Finalizations **)olddata;
*save_fns_ptr = NULL;
if (prim && (*fns_ptr)->scheme_first) {
/* Reset level back to 1: */
GC_register_eager_finalizer(v, 1, do_next_finalization, fns_ptr, NULL, NULL);
}
}
} else if (rmve) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
@ -1384,6 +1390,17 @@ static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
}
#ifndef MZ_PRECISE_GC
void scheme_late_weak_reference(void **p)
{
scheme_late_weak_reference_indirect(p, *p);
}
void scheme_late_weak_reference_indirect(void **p, void *v)
{
if (GC_base(v) == v)
GC_register_late_disappearing_link(p, v);
}
void scheme_weak_reference(void **p)
{
scheme_weak_reference_indirect(p, *p);
@ -1392,7 +1409,7 @@ void scheme_weak_reference(void **p)
void scheme_weak_reference_indirect(void **p, void *v)
{
if (GC_base(v) == v)
GC_register_late_disappearing_link(p, v);
GC_register_indirect_disappearing_link(p, v);
}
void scheme_unweak_reference(void **p)
@ -1430,7 +1447,7 @@ void scheme_register_finalizer(void *p, void (*f)(void *p, void *data),
void *data, void (**oldf)(void *p, void *data),
void **olddata)
{
add_finalizer(p, f, data, 0, 1, oldf, olddata, 0, 0);
add_finalizer(p, f, data, 1, 1, oldf, olddata, 0, 0);
}
void scheme_remove_all_finalization(void *p)

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

@ -402,6 +402,8 @@ MZ_EXTERN char *scheme_strdup_eternal(const char *str);
MZ_EXTERN void *scheme_malloc_fail_ok(void *(*f)(size_t), size_t);
#ifndef MZ_PRECISE_GC
MZ_EXTERN void scheme_late_weak_reference(void **p);
MZ_EXTERN void scheme_late_weak_reference_indirect(void **p, void *v);
MZ_EXTERN void scheme_weak_reference(void **p);
MZ_EXTERN void scheme_weak_reference_indirect(void **p, void *v);
MZ_EXTERN void scheme_unweak_reference(void **p);
@ -1093,11 +1095,14 @@ MZ_EXTERN Scheme_Object *scheme_unbox(Scheme_Object *obj);
MZ_EXTERN void scheme_set_box(Scheme_Object *b, Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_make_weak_box(Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_make_late_weak_box(Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_make_ephemeron(Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN Scheme_Object *scheme_ephemeron_value(Scheme_Object *o);
MZ_EXTERN Scheme_Object *scheme_ephemeron_key(Scheme_Object *o);
MZ_EXTERN Scheme_Object *scheme_make_stubborn_will_executor();
MZ_EXTERN Scheme_Object *scheme_load(const char *file);
MZ_EXTERN Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env);
MZ_EXTERN void scheme_register_extension_global(void *ptr, long size);

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

@ -323,6 +323,8 @@ char *(*scheme_strdup)(const char *str);
char *(*scheme_strdup_eternal)(const char *str);
void *(*scheme_malloc_fail_ok)(void *(*f)(size_t), size_t);
#ifndef MZ_PRECISE_GC
void (*scheme_late_weak_reference)(void **p);
void (*scheme_late_weak_reference_indirect)(void **p, void *v);
void (*scheme_weak_reference)(void **p);
void (*scheme_weak_reference_indirect)(void **p, void *v);
void (*scheme_unweak_reference)(void **p);
@ -905,9 +907,11 @@ Scheme_Object *(*scheme_box)(Scheme_Object *v);
Scheme_Object *(*scheme_unbox)(Scheme_Object *obj);
void (*scheme_set_box)(Scheme_Object *b, Scheme_Object *v);
Scheme_Object *(*scheme_make_weak_box)(Scheme_Object *v);
Scheme_Object *(*scheme_make_late_weak_box)(Scheme_Object *v);
Scheme_Object *(*scheme_make_ephemeron)(Scheme_Object *key, Scheme_Object *val);
Scheme_Object *(*scheme_ephemeron_value)(Scheme_Object *o);
Scheme_Object *(*scheme_ephemeron_key)(Scheme_Object *o);
Scheme_Object *(*scheme_make_stubborn_will_executor)();
Scheme_Object *(*scheme_load)(const char *file);
Scheme_Object *(*scheme_load_extension)(const char *filename, Scheme_Env *env);
void (*scheme_register_extension_global)(void *ptr, long size);

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

@ -226,6 +226,8 @@
scheme_extension_table->scheme_strdup_eternal = scheme_strdup_eternal;
scheme_extension_table->scheme_malloc_fail_ok = scheme_malloc_fail_ok;
#ifndef MZ_PRECISE_GC
scheme_extension_table->scheme_late_weak_reference = scheme_late_weak_reference;
scheme_extension_table->scheme_late_weak_reference_indirect = scheme_late_weak_reference_indirect;
scheme_extension_table->scheme_weak_reference = scheme_weak_reference;
scheme_extension_table->scheme_weak_reference_indirect = scheme_weak_reference_indirect;
scheme_extension_table->scheme_unweak_reference = scheme_unweak_reference;
@ -634,9 +636,11 @@
scheme_extension_table->scheme_unbox = scheme_unbox;
scheme_extension_table->scheme_set_box = scheme_set_box;
scheme_extension_table->scheme_make_weak_box = scheme_make_weak_box;
scheme_extension_table->scheme_make_late_weak_box = scheme_make_late_weak_box;
scheme_extension_table->scheme_make_ephemeron = scheme_make_ephemeron;
scheme_extension_table->scheme_ephemeron_value = scheme_ephemeron_value;
scheme_extension_table->scheme_ephemeron_key = scheme_ephemeron_key;
scheme_extension_table->scheme_make_stubborn_will_executor = scheme_make_stubborn_will_executor;
scheme_extension_table->scheme_load = scheme_load;
scheme_extension_table->scheme_load_extension = scheme_load_extension;
scheme_extension_table->scheme_register_extension_global = scheme_register_extension_global;

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

@ -226,6 +226,8 @@
#define scheme_strdup_eternal (scheme_extension_table->scheme_strdup_eternal)
#define scheme_malloc_fail_ok (scheme_extension_table->scheme_malloc_fail_ok)
#ifndef MZ_PRECISE_GC
#define scheme_late_weak_reference (scheme_extension_table->scheme_late_weak_reference)
#define scheme_late_weak_reference_indirect (scheme_extension_table->scheme_late_weak_reference_indirect)
#define scheme_weak_reference (scheme_extension_table->scheme_weak_reference)
#define scheme_weak_reference_indirect (scheme_extension_table->scheme_weak_reference_indirect)
#define scheme_unweak_reference (scheme_extension_table->scheme_unweak_reference)
@ -634,9 +636,11 @@
#define scheme_unbox (scheme_extension_table->scheme_unbox)
#define scheme_set_box (scheme_extension_table->scheme_set_box)
#define scheme_make_weak_box (scheme_extension_table->scheme_make_weak_box)
#define scheme_make_late_weak_box (scheme_extension_table->scheme_make_late_weak_box)
#define scheme_make_ephemeron (scheme_extension_table->scheme_make_ephemeron)
#define scheme_ephemeron_value (scheme_extension_table->scheme_ephemeron_value)
#define scheme_ephemeron_key (scheme_extension_table->scheme_ephemeron_key)
#define scheme_make_stubborn_will_executor (scheme_extension_table->scheme_make_stubborn_will_executor)
#define scheme_load (scheme_extension_table->scheme_load)
#define scheme_load_extension (scheme_extension_table->scheme_load_extension)
#define scheme_register_extension_global (scheme_extension_table->scheme_register_extension_global)

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

@ -270,7 +270,7 @@ typedef struct {
Scheme_Custodian *val;
} Scheme_Custodian_Weak_Box;
# define MALLOC_MREF() (Scheme_Custodian_Reference *)scheme_make_weak_box(NULL)
# define MALLOC_MREF() (Scheme_Custodian_Reference *)scheme_make_late_weak_box(NULL)
# define CUSTODIAN_FAM(x) ((Scheme_Custodian_Weak_Box *)x)->val
# define xCUSTODIAN_FAM(x) SCHEME_BOX_VAL(x)
#else
@ -1432,7 +1432,7 @@ Scheme_Custodian_Reference *scheme_add_managed(Scheme_Custodian *m, Scheme_Objec
}
#ifdef MZ_PRECISE_GC
b = scheme_make_weak_box(NULL);
b = scheme_make_late_weak_box(NULL);
#else
b = MALLOC_ONE_WEAK(Scheme_Object*);
#endif
@ -1833,7 +1833,7 @@ static Scheme_Object *make_custodian_box(int argc, Scheme_Object *argv[])
/* 3m */
{
Scheme_Object *wb, *pr, *prev;
wb = GC_malloc_weak_box(cb, NULL, 0);
wb = GC_malloc_weak_box(cb, NULL, 0, 1);
pr = scheme_make_raw_pair(wb, cb->cust->cust_boxes);
cb->cust->cust_boxes = pr;
cb->cust->num_cust_boxes++;
@ -7279,6 +7279,7 @@ typedef struct WillExecutor {
Scheme_Object so;
Scheme_Object *sema;
ActiveWill *first, *last;
int is_stubborn;
} WillExecutor;
static void activate_will(void *o, void *data)
@ -7287,8 +7288,13 @@ static void activate_will(void *o, void *data)
WillExecutor *w;
Scheme_Object *proc;
w = (WillExecutor *)scheme_ephemeron_key(data);
proc = scheme_ephemeron_value(data);
if (SCHEME_PAIRP(data)) {
w = (WillExecutor *)SCHEME_CAR(data);
proc = SCHEME_CDR(data);
} else {
w = (WillExecutor *)scheme_ephemeron_key(data);
proc = scheme_ephemeron_value(data);
}
if (w) {
a = MALLOC_ONE_RT(ActiveWill);
@ -7335,6 +7341,17 @@ static Scheme_Object *make_will_executor(int argc, Scheme_Object **argv)
w->first = NULL;
w->last = NULL;
w->sema = sema;
w->is_stubborn = 0;
return (Scheme_Object *)w;
}
Scheme_Object *scheme_make_stubborn_will_executor()
{
WillExecutor *w;
w = (WillExecutor *)make_will_executor(0, NULL);
w->is_stubborn = 1;
return (Scheme_Object *)w;
}
@ -7354,8 +7371,12 @@ static Scheme_Object *register_will(int argc, Scheme_Object **argv)
scheme_wrong_type("will-register", "will-executor", 0, argc, argv);
scheme_check_proc_arity("will-register", 1, 2, argc, argv);
/* If we lose track of the will executor, then drop the finalizer. */
e = scheme_make_ephemeron(argv[0], argv[2]);
if (((WillExecutor *)argv[0])->is_stubborn)
e = scheme_make_pair(argv[0], argv[2]);
else {
/* If we lose track of the will executor, then drop the finalizer. */
e = scheme_make_ephemeron(argv[0], argv[2]);
}
scheme_add_scheme_finalizer(argv[1], activate_will, e);