diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 53efa02b9a..f5bf2189a4 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -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)) - diff --git a/collects/ffi/unsafe/alloc.rkt b/collects/ffi/unsafe/alloc.rkt index 9de090e928..958939f293 100644 --- a/collects/ffi/unsafe/alloc.rkt +++ b/collects/ffi/unsafe/alloc.rkt @@ -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)) diff --git a/collects/ffi/unsafe/atomic.rkt b/collects/ffi/unsafe/atomic.rkt index d098dd890f..3030cb5d59 100644 --- a/collects/ffi/unsafe/atomic.rkt +++ b/collects/ffi/unsafe/atomic.rkt @@ -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 diff --git a/collects/ffi/unsafe/define.rkt b/collects/ffi/unsafe/define.rkt index 73975f038c..66874f613f 100644 --- a/collects/ffi/unsafe/define.rkt +++ b/collects/ffi/unsafe/define.rkt @@ -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 diff --git a/collects/racket/draw/font.rkt b/collects/racket/draw/font.rkt index 4616dacc0e..28fc4e5460 100644 --- a/collects/racket/draw/font.rkt +++ b/collects/racket/draw/font.rkt @@ -1,5 +1,6 @@ #lang scheme/base (require scheme/class + ffi/unsafe ffi/unsafe/atomic "syntax.ss" "pango.ss" diff --git a/collects/scribblings/inside/memory.scrbl b/collects/scribblings/inside/memory.scrbl index c9ab2bce15..09a571d380 100644 --- a/collects/scribblings/inside/memory.scrbl +++ b/collects/scribblings/inside/memory.scrbl @@ -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] diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 723f53f340..94c134b52d 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -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 diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 825838aa09..a5b01aca6a 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -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) -> # */ +#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); diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 102a0b8479..619069d7fc 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -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) -> # */ +@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; diff --git a/src/racket/gc/finalize.c b/src/racket/gc/finalize.c index acfecc8472..869b310b02 100644 --- a/src/racket/gc/finalize.c +++ b/src/racket/gc/finalize.c @@ -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) diff --git a/src/racket/gc2/README b/src/racket/gc2/README index d1b1dd12a5..8b69cccaaa 100644 --- a/src/racket/gc2/README +++ b/src/racket/gc2/README @@ -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 ----------------------- diff --git a/src/racket/gc2/commongc_internal.h b/src/racket/gc2/commongc_internal.h index daafe5129e..95d407ca80 100644 --- a/src/racket/gc2/commongc_internal.h +++ b/src/racket/gc2/commongc_internal.h @@ -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; diff --git a/src/racket/gc2/gc2.h b/src/racket/gc2/gc2.h index c694041c90..650f2b7400 100644 --- a/src/racket/gc2/gc2.h +++ b/src/racket/gc2/gc2.h @@ -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 */ /***************************************************************************/ diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 1509c3f1a7..23304c191c 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -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 diff --git a/src/racket/gc2/newgc.h b/src/racket/gc2/newgc.h index ddc16dd793..b71f8dc0c9 100644 --- a/src/racket/gc2/newgc.h +++ b/src/racket/gc2/newgc.h @@ -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; diff --git a/src/racket/gc2/weak.c b/src/racket/gc2/weak.c index 9f47efcf4f..98fb85f5ba 100644 --- a/src/racket/gc2/weak.c +++ b/src/racket/gc2/weak.c @@ -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; diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 0513b6edd2..e197f8e9f2 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -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 diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index e3e83804f3..ab853837bc 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -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 diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 217d796153..311522adab 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -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 diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 9900400399..5fd06f4498 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -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 diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index ec9c6b14b0..8feab219bb 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -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; diff --git a/src/racket/src/list.c b/src/racket/src/list.c index 6e4095334e..292ff636ef 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -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]); diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index c26ab87667..c510c8cf36 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -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) diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index ff4709b8d6..6d56ca6cb2 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -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); diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index bdc89f06b0..c2372ddf1f 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -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); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index 9865b62e37..06e0dbfc02 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -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; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 50b5236aa9..7de4e2fe2d 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -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) diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index ce562c9cb0..dc702e29ac 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -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);