level-2 finalization from ffi/unsafe and late-weak references

collects/ffi/unsafe.rkt

@@ -16,7 +16,8 @@
          _float _double _double*
          _bool _pointer _gcpointer _scheme (rename-out [_scheme _racket]) _fpointer function-ptr
          memcpy memmove memset
-         malloc-immobile-cell free-immobile-cell)
+         malloc-immobile-cell free-immobile-cell
+         make-late-weak-box make-late-weak-hasheq)
 
 (define-syntax define*
   (syntax-rules ()
@@ -1477,6 +1478,8 @@
 ;; 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).
+;; Also it registers level-2 finalizers (which are run after non-late weak
+;; boxes are cleared).
 (define killer-executor (make-stubborn-will-executor))
 (define killer-thread #f)
 

collects/ffi/unsafe/alloc.rkt

@@ -5,7 +5,7 @@
 (provide allocator deallocator retainer 
          (rename-out [deallocator releaser]))
 
-(define allocated (make-weak-hasheq))
+(define allocated (make-late-weak-hasheq))
 
 (define (deallocate v)
   ;; Called as a finalizer, we we assume that the

collects/mred/private/wx/cocoa/list-box.rkt

@@ -30,7 +30,7 @@
         (tell
          (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString 
                         (if wx (send wx get-row row) "???"))]
-               [font (send wx get-cell-font)])
+               [font (and wx (send wx get-cell-font))])
            (when font
              (tellv c setFont: font))
            c)

collects/tests/gracket/mem.rkt

@@ -4,7 +4,7 @@
 
 (define source-dir (current-load-relative-directory))
 
-(define num-times 8)
+(define num-times 80)
 (define num-threads 3)
 
 (define dump-stats? #f)
@@ -152,6 +152,7 @@
 
 	(when (and edit? insert?)
 	    (let ([e edit])
+              (send e begin-edit-sequence)
 	      (when load-file?
 		(send e load-file (build-path source-dir "mem.ss")))
 	      (let loop ([i 20])
@@ -163,7 +164,8 @@
 		(send e insert s))
 	      (send e insert #\newline)
 	      (send e insert "done")
-	      (send e set-modified #f)))
+	      (send e set-modified #f)
+              (send e end-edit-sequence)))
 	
 	(when menus?
 	  (let ([f (remember tag (make-object frame% "MB Frame 0"))])

src/foreign/foreign.c

@@ -3031,6 +3031,22 @@ static Scheme_Object *foreign_make_stubborn_will_executor(int argc, Scheme_Objec
 }
 #undef MYNAME
 
+/* (make-late-weak-box val) -> #<weak-box> */
+#define MYNAME "make-late-weak-box"
+static Scheme_Object *foreign_make_late_weak_box(int argc, Scheme_Object *argv[])
+{
+  return scheme_make_late_weak_box(argv[0]);
+}
+#undef MYNAME
+
+/* (make-late-weak-hasheq) -> #<hash> */
+#define MYNAME "make-late-weak-hasheq"
+static Scheme_Object *foreign_make_late_weak_hasheq(int argc, Scheme_Object *argv[])
+{
+  return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_late_weak_ptr);
+}
+#undef MYNAME
+
 /*****************************************************************************/
 
 void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
@@ -3201,6 +3217,10 @@ void scheme_init_foreign(Scheme_Env *env)
     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);
+  scheme_add_global("make-late-weak-box",
+    scheme_make_prim_w_arity(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), menv);
+  scheme_add_global("make-late-weak-hasheq",
+    scheme_make_prim_w_arity(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), menv);
   s = scheme_intern_symbol("void");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
@@ -3501,6 +3521,10 @@ void scheme_init_foreign(Scheme_Env *env)
    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("make-late-weak-box",
+   scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), menv);
+  scheme_add_global("make-late-weak-hasheq",
+   scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 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

@@ -2387,6 +2387,16 @@ static void save_errno_values(int kind)
   return scheme_make_stubborn_will_executor();
 }
 
+/* (make-late-weak-box val) -> #<weak-box> */
+@cdefine[make-late-weak-box 1]{
+  return scheme_make_late_weak_box(argv[0]);
+}
+
+/* (make-late-weak-hasheq) -> #<hash> */
+@cdefine[make-late-weak-hasheq 0]{
+  return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_late_weak_ptr);
+}
+
 /*****************************************************************************/
 
 void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)

src/gracket/get-libs.rkt

@@ -83,7 +83,7 @@
                     ["libglib-2.0-0.dll" 1110713]
                     ["libgobject-2.0-0.dll" 316586]
                     ["libgmodule-2.0-0.dll" 31692]
-                    ["libpangocairo-1.0-0.dll" 95189]
+                    ["libpangocairo-1.0-0.dll" 94625]
                     ["libpangowin32-1.0-0.dll" 102210]
                     ["libpangoft2-1.0-0.dll" 679322])])
        (if (getenv "PLT_WIN_GTK")

src/racket/include/scheme.h

@@ -824,7 +824,8 @@ typedef struct Scheme_Bucket_Table
   int size; /* power of 2 */
   int count;
   Scheme_Bucket **buckets;
-  char weak, with_home;
+  char weak; /* 1 => normal weak, 2 => late weak */
+  char with_home;
   void (*make_hash_indices)(void *v, long *h1, long *h2);
   int (*compare)(void *v1, void *v2);
   Scheme_Object *mutex;
@@ -835,7 +836,8 @@ enum {
   SCHEME_hash_string,
   SCHEME_hash_ptr,
   SCHEME_hash_bound_id,
-  SCHEME_hash_weak_ptr
+  SCHEME_hash_weak_ptr,
+  SCHEME_hash_late_weak_ptr
 };
 
 typedef struct Scheme_Env Scheme_Env;

src/racket/src/hash.c

@@ -541,7 +541,12 @@ scheme_make_bucket_table (int size, int type)
     table->buckets = ba;
   }
 
-  table->weak = (type == SCHEME_hash_weak_ptr);
+  if (type == SCHEME_hash_weak_ptr)
+    table->weak = 1;
+  else if (type == SCHEME_hash_late_weak_ptr)
+    table->weak = 2;
+  else
+    table->weak = 0;
   
   return table;
 }
@@ -714,15 +719,21 @@ 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, 0);
+      kb = GC_malloc_weak_box((void *)key, (void **)bucket, (void **)&bucket->val - (void **)bucket, 
+                              (table->weak > 1));
       bucket->key = (char *)kb;
 #else
       char *kb;
       kb = (char *)MALLOC_ONE_WEAK(void *);
       bucket->key = kb;
       *(void **)bucket->key = (void *)key;
+      if (table->weak > 1) {
+        scheme_late_weak_reference_indirect((void **)bucket->key, (void *)key);
+        scheme_late_weak_reference_indirect((void **)&bucket->val, (void *)key);
+      } else {
         scheme_weak_reference_indirect((void **)bucket->key, (void *)key);
         scheme_weak_reference_indirect((void **)&bucket->val, (void *)key);
+      }
 #endif
     } else
       bucket->key = (char *)key;

src/racket/src/thread.c

@@ -7371,14 +7371,15 @@ 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 (((WillExecutor *)argv[0])->is_stubborn)
+  if (((WillExecutor *)argv[0])->is_stubborn) {
     e = scheme_make_pair(argv[0], argv[2]);
-  else {
+    scheme_add_finalizer(argv[1], activate_will, e);
+  } 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);
   }
 
-  scheme_add_scheme_finalizer(argv[1], activate_will, e);
 
   return scheme_void;
 }