diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index d958c8ea45..a371abc34c 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -775,6 +775,11 @@ (super-tell #:type _void dealloc)))] [_ (error "oops")]) '())] + [(async ...) + (if (eq? (syntax-e id) 'dealloc) + ;; so that objects can be destroyed in foreign threads: + #'(#:async-apply apply-directly) + #'())] [in-cls (if in-class? #'(object-get-class cls) #'cls)] @@ -792,13 +797,16 @@ [super-tell do-super-tell]) body0 body ... dealloc-body ...))) - (_fun #:atomic? atomic? #:keep save-method! _id _id arg-type ... -> rt) + (_fun #:atomic? atomic? #:keep save-method! async ... + _id _id arg-type ... -> rt) (generate-layout rt (list arg-id ...)))))))))] [else (raise-syntax-error #f "bad method form" stx #'m)]))])) +(define (apply-directly f) (f)) + (define methods (make-hasheq)) (define (save-method! m) ;; Methods are never GCed, since classes are never unregistered diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index d9d37610a7..153b821b18 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -31,10 +31,9 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (values ; as-objc-allocation - ;; We're leaving guages for now. There's some problem - ;; releasing gauges through a finalizer. My guess is that - ;; it has something to do with animation in a separate thread. + [cocoa (let ([cocoa (as-objc-allocation + ;; Beware that a guage may be finally deallocated in + ;; a seperate OS-level thread (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setMaxValue: #:type _double* rng) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 42c62ebf01..02d1a0b069 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -37,18 +37,12 @@ (define delete-me null) (define (objc-delete o) - (atomically - (set! delete-me (cons o delete-me)))) + (tellv o release)) (define (clean-up-deleted) - ;; called outside the event loop to actually delete objects - ;; that might otherwise be in use during a callback - (for ([o (in-list (begin0 - delete-me - (set! delete-me null)))]) - (tellv o release))) + (free-remembered-now objc-delete)) -(define objc-allocator (allocator objc-delete)) +(define objc-allocator (allocator remember-to-free-later)) (define-syntax-rule (as-objc-allocation expr) ((objc-allocator (lambda () expr)))) diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt index 7a27dbfe9e..2fcf5748b6 100644 --- a/collects/mred/private/wx/common/utils.rkt +++ b/collects/mred/private/wx/common/utils.rkt @@ -1,8 +1,33 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define + ffi/unsafe/atomic "once.rkt") -(provide (protect-out define-mz)) +(provide (protect-out define-mz + + remember-to-free-later + free-remembered-now)) (define-ffi-definer define-mz #f) + +;; ---------------------------------------- + +(define to-free null) + +;; Remember to free an object that might currently be in use during a +;; callback: +(define (remember-to-free-later o) + (start-atomic) + (set! to-free (cons o to-free)) + (end-atomic)) + +;; Called outside the event loop to actually free objects that might +;; otherwise be in use during a callback: +(define (free-remembered-now free) + (start-atomic) + (for ([o (in-list (begin0 + to-free + (set! to-free null)))]) + (free o)) + (end-atomic)) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index b0885b5148..e42d3100d9 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -183,6 +183,7 @@ (define (dispatch-all-ready) (pre-event-sync #f) + (clean-up-destroyed) (when (gtk_events_pending) (gtk_main_iteration_do #f) (dispatch-all-ready))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 5dd05e7c81..16d569ef4f 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -24,6 +24,7 @@ as-gtk-allocation as-gtk-window-allocation + clean-up-destroyed g_free _gpath/free @@ -113,7 +114,10 @@ (define gtk-destroy ((deallocator) (lambda (v) (gtk_widget_destroy v) (g_object_unref v)))) -(define gtk-allocator (allocator gtk-destroy)) + +(define gtk-allocator (allocator remember-to-free-later)) +(define (clean-up-destroyed) + (free-remembered-now gtk-destroy)) (define-syntax-rule (as-gtk-allocation expr) ((gtk-allocator (lambda () (let ([v expr]) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 24504696f2..a7acecc3e6 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -127,6 +127,7 @@ (define (dispatch-all-ready) ;; in atomic mode (pre-event-sync #f) + (clean-up-destroyed) ;; Windows uses messages above #x4000 to hilite items in the task bar, ;; etc. In any case, these messages won't be handled by us, so they diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 30840da72e..ce27d48f24 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -18,9 +18,12 @@ failed GetLastError + DestroyWindow NotifyWindowDestroy CreateWindowExW + clean-up-destroyed + GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str @@ -73,6 +76,9 @@ #:wrap (deallocator)) (define NotifyWindowDestroy ((deallocator) void)) +(define (clean-up-destroyed) + (free-remembered-now DestroyWindow)) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 @@ -80,7 +86,7 @@ _int _int _int _int _HWND _HMENU _HINSTANCE _pointer -> _HWND) - #:wrap (allocator DestroyWindow)) + #:wrap (allocator remember-to-free-later)) (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))