diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index f5bf2189a4..f1f0cb46ef 100644 --- a/collects/ffi/unsafe.rkt +++ b/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) diff --git a/collects/ffi/unsafe/alloc.rkt b/collects/ffi/unsafe/alloc.rkt index 958939f293..910f01fd0e 100644 --- a/collects/ffi/unsafe/alloc.rkt +++ b/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 diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index f5bffb686b..8163794e10 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/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) diff --git a/collects/tests/gracket/mem.rkt b/collects/tests/gracket/mem.rkt index 7e3603eee0..ae8d663ea8 100644 --- a/collects/tests/gracket/mem.rkt +++ b/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"))]) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index a5b01aca6a..a54113edea 100644 --- a/src/foreign/foreign.c +++ b/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) -> # */ +#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) -> # */ +#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); diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 619069d7fc..61c1eee040 100755 --- a/src/foreign/foreign.rktc +++ b/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) -> # */ +@cdefine[make-late-weak-box 1]{ + return scheme_make_late_weak_box(argv[0]); +} + +/* (make-late-weak-hasheq) -> # */ +@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) diff --git a/src/gracket/get-libs.rkt b/src/gracket/get-libs.rkt index 143b7d0c2b..4cfffe407e 100644 --- a/src/gracket/get-libs.rkt +++ b/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") diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index fc8bf4960a..365160cc4d 100644 --- a/src/racket/include/scheme.h +++ b/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; diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index 8feab219bb..41b01d9f47 100644 --- a/src/racket/src/hash.c +++ b/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; - scheme_weak_reference_indirect((void **)bucket->key, (void *)key); - scheme_weak_reference_indirect((void **)&bucket->val, (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; diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index dc702e29ac..60a828d734 100644 --- a/src/racket/src/thread.c +++ b/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; }