overhaul GC finalization

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
+;; A facility for running finalizers using executors. The "stubborn" kind
-;; version that uses finalizers, but that leads to calling Scheme from the GC
+;; of will executor is provided by '#%foreign, and it doesn't get GC'ed if
-;; which is not a good idea.
+;; any finalizers are attached to it (while the normal kind can get GCed
-(define killer-executor (make-will-executor))
+;; 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))
-

collects/ffi/unsafe/alloc.rkt

@@ -1,7 +1,6 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/foreign
+(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))
 

collects/ffi/unsafe/atomic.rkt

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

collects/ffi/unsafe/define.rkt

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

collects/racket/draw/font.rkt

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

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]

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

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

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

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)

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.)
+finalizers.) The `p' argument must point to the beginning of a tagged
-
+(if `tagged' is 1) or xtagged (if `tagged' is 0) object.
-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.
 
 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.
+object be finalized. Finally, level 3 finalizers are queued.
-
-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.)
 
 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
+The `p' object isn't actually collected when a finalizer is queued,
-provide GC_finalization_weak_ptr():
+since the finalizer will receive `p' as an argument. Weak references
-
+are cleared after level 1 fnalizers are queued, while "late weak box"
-  void GC_finalization_weak_ptr(void **p, int offset);
+references are cleared after level 2 finalizers are clear.
-
-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.
 
 Functions versus Macros
 -----------------------

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;
 

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

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);
+  TIME_STEP("marked");
-  propagate_marks_plus_ephemerons(gc);
+
+  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

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;

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;
+    wb->next = gc->weak_boxes[wb->is_late];
-    gc->weak_boxes = wb;
+    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;

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

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

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

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

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;

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

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)

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

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

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;

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)

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);
+  if (SCHEME_PAIRP(data)) {
-  proc = scheme_ephemeron_value(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. */
+  if (((WillExecutor *)argv[0])->is_stubborn)
-  e = scheme_make_ephemeron(argv[0], argv[2]);
+    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);