destroy windows via finalization outside of the event loop

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

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
+             [cocoa (let ([cocoa (as-objc-allocation
-                                  ;; We're leaving guages for now. There's some problem
+                                  ;; Beware that a guage may be finally deallocated in 
-                                  ;; releasing gauges through a finalizer. My guess is that
+                                  ;; a seperate OS-level thread
-                                  ;; it has something to do with animation in a separate thread.
                                   (tell (tell MyProgressIndicator alloc) init))])
                       (tellv cocoa setIndeterminate: #:type _BOOL #f)
                       (tellv cocoa setMaxValue: #:type _double* rng)

collects/mred/private/wx/cocoa/utils.rkt

@@ -37,18 +37,12 @@
 (define delete-me null)
 
 (define (objc-delete o)
-  (atomically
+  (tellv o release))
-   (set! delete-me (cons o delete-me))))
 
 (define (clean-up-deleted)
-  ;; called outside the event loop to actually delete objects
+  (free-remembered-now objc-delete))
-  ;; that might otherwise be in use during a callback
-  (for ([o (in-list (begin0
-                     delete-me
-                     (set! delete-me null)))])
-    (tellv o release)))
 
-(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))))

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

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

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

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

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