more memory management

original commit: c7049058336382b651c82b3a98c8a7feb9311257

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

@@ -79,6 +79,7 @@
                                     0)])
          (CGDataProviderRelease provider)
          (CGColorSpaceRelease cs)
+         (as-objc-allocation
           (tell (tell NSImage alloc) 
                 initWithCGImage: #:type _CGImageRef image
-               size: #:type _NSSize (make-NSSize w h)))))))
+                size: #:type _NSSize (make-NSSize w h))))))))

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

@@ -1,17 +1,44 @@
-#lang scheme/base
+#lang racket/base
-(require ffi/objc
+(require ffi/unsafe
-         scheme/foreign
+         ffi/unsafe/objc
+         ffi/unsafe/atomic
          "utils.rkt"
          "const.rkt"
          "types.rkt")
-(unsafe!)
-(objc-unsafe!)
 
-(provide pool)
+(provide queue-autorelease-flush
+         autorelease-flush)
 
 (import-class NSAutoreleasePool)
 
 ;; This pool manages all objects that would otherwise not
-;; have a pool, which makes them stick around until the
+;; have a pool:
-;; process exits.
 (define pool (tell (tell NSAutoreleasePool alloc) init))
+
+;; We need to periodically flush the main pool, otherwise
+;; object autoreleased through the pool live until the
+;; end of execution:
+(define (autorelease-flush)
+  (start-atomic)
+  (tellv pool drain)
+  (set! pool (tell (tell NSAutoreleasePool alloc) init))
+  (end-atomic))
+
+(define queued? #f)
+(define autorelease-evt (make-semaphore))
+
+(define (queue-autorelease-flush)
+  (start-atomic)
+  (unless queued?
+    (semaphore-post autorelease-evt)
+    (set! queued? #t))
+  (end-atomic))
+
+;; Create a thread to periodically flush:
+(void
+ (thread (lambda ()
+           (let loop ()
+             (sync autorelease-evt)
+             (set! queued? #f)
+             (autorelease-flush)
+             (loop)))))

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

@@ -79,6 +79,7 @@
         subtype: #:type _short 0
         data1: #:type _NSInteger 0
         data2: #:type _NSInteger 0))
+(retain wake-evt)
 (define (post-dummy-event)
   (tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES))
 
@@ -248,6 +249,7 @@
             (let loop ()
               (sync queue-evt)
               (atomically (dispatch-all-ready))
+              (queue-autorelease-flush)
               (loop)))))
 
 (set-check-queue!

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

@@ -7,6 +7,7 @@
          "const.rkt"
          "types.rkt"
          "keycode.rkt"
+         "pool.rkt"
          "../../lock.rkt"
          "../common/event.rkt"
          "../common/queue.rkt"
@@ -128,6 +129,12 @@
                        [y (->long y)]
                        [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
                        [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
+           (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
+             (when (and (string? alt-str)
+                        (= 1 (string-length alt-str)))
+               (let ([alt-code (string-ref alt-str 0)])
+                 (unless (equal? alt-code (send k get-key-code))
+                   (send k set-other-altgr-key-code alt-code)))))
            (if (send wx definitely-wants-event? k)
                (begin
                  (queue-window-event wx (lambda ()
@@ -175,6 +182,8 @@
 
     (super-new)
 
+    (queue-autorelease-flush)
+
     (define eventspace (if parent
                            (send parent get-eventspace)
                            (current-eventspace)))
@@ -211,10 +220,15 @@
 
     (define/public (get-eventspace) eventspace)
 
+    (define is-on? #f)
     (define/public (show on?)
+      (atomically
+       (unless (eq? (and on? #t) is-on?)
          (if on?
              (tellv (send parent get-cocoa-content) addSubview: cocoa)
-          (tellv cocoa removeFromSuperview))
+             (with-autorelease
+              (tellv cocoa removeFromSuperview)))
+         (set! is-on? (and on? #t))))
       (maybe-register-as-child parent on?))
     (define/public (maybe-register-as-child parent on?)
       (void))

collects/mred/private/wx/common/queue.rkt

@@ -302,9 +302,17 @@
   ((eventspace-queue-proc eventspace) (cons level thunk)))
 
 (define (handle-event thunk)
+  (let/ec esc
+    (let ([done? #f])
+      (dynamic-wind
+       void
+       (lambda ()
          (call-with-continuation-barrier
           (lambda ()
-     (call-with-continuation-prompt thunk))))
+            (call-with-continuation-prompt thunk)))
+         (set! done? #t))
+       (lambda ()
+         (unless done? (esc (void))))))))
 
 (define yield
   (case-lambda

collects/mred/private/wx/gtk/button.rkt

@@ -2,6 +2,7 @@
 (require scheme/foreign
          scheme/class
           "../../syntax.rkt"
+          "../../lock.rkt"
          "item.rkt"
          "utils.rkt"
          "types.rkt"
@@ -43,16 +44,19 @@
   (super-new [parent parent]
              [gtk (cond
                    [(or (string? label) (not label))
-                    (gtk_new_with_mnemonic (or (mnemonic-string label) ""))]
+                    (as-gtk-allocation
+                     (gtk_new_with_mnemonic (or (mnemonic-string label) "")))]
                    [(send label ok?)
-                    (let ([gtk (gtk_new)]
+                    (let ([pixbuf (bitmap->pixbuf label)])
-                          [image-gtk (gtk_image_new_from_pixbuf 
+                      (atomically
-                                      (bitmap->pixbuf label))])
+                       (let ([gtk (as-gtk-allocation (gtk_new))]
+                             [image-gtk (gtk_image_new_from_pixbuf pixbuf)])
+                         (release-pixbuf pixbuf)
                          (gtk_container_add gtk image-gtk)
                          (gtk_widget_show image-gtk)
-                      gtk)]
+                         gtk)))]
                    [else
-                    (gtk_new_with_mnemonic "<bad>")])]
+                    (as-gtk-allocation (gtk_new_with_mnemonic "<bad>"))])]
              [callback cb]
              [no-show? (memq 'deleted style)])
   (define gtk (get-gtk))
@@ -82,11 +86,13 @@
      [(string? s)
       (gtk_button_set_label gtk (mnemonic-string s))]
      [else
-      (let ([image-gtk (gtk_image_new_from_pixbuf 
+      (let ([pixbuf (bitmap->pixbuf s)])
-                        (bitmap->pixbuf s))])
+        (atomically
+         (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)])
+           (release-pixbuf pixbuf)
            (gtk_container_remove gtk (gtk_bin_get_child gtk))
            (gtk_container_add gtk image-gtk)
-        (gtk_widget_show image-gtk))]))
+           (gtk_widget_show image-gtk))))]))
 
   (define/public (set-border on?)
     (gtk_window_set_default (get-window-gtk) (if on? gtk #f))))

collects/mred/private/wx/gtk/frame.rkt

@@ -2,6 +2,7 @@
 (require scheme/foreign
          scheme/class
          "../../syntax.rkt"
+         "../../lock.rkt"
          "utils.rkt"
          "const.rkt"
          "types.rkt"
@@ -103,13 +104,17 @@
              get-parent get-eventspace
              adjust-client-delta)
 
-    (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL))
+    (define gtk (as-gtk-window-allocation
+                 (gtk_window_new GTK_WINDOW_TOPLEVEL)))
     (when (memq 'no-caption style)
       (gtk_window_set_decorated gtk #f))    
-    (define vbox-gtk (gtk_vbox_new #f 0))
+    (define-values (vbox-gtk panel-gtk)
-    (define panel-gtk (gtk_fixed_new))
+      (atomically
+       (let ([vbox-gtk (gtk_vbox_new #f 0)]
+             [panel-gtk (gtk_fixed_new)])
          (gtk_container_add gtk vbox-gtk)
          (gtk_box_pack_end vbox-gtk panel-gtk #t #t 0)
+         (values vbox-gtk panel-gtk))))
     (gtk_widget_show vbox-gtk)
     (gtk_widget_show panel-gtk)
 

collects/mred/private/wx/gtk/message.rkt

@@ -51,15 +51,19 @@
   (super-new [parent parent]
              [gtk (if (or (string? label)
                           (not label))
-                      (gtk_label_new_with_mnemonic (or label ""))
+                      (as-gtk-allocation (gtk_label_new_with_mnemonic (or label "")))
                       (if (symbol? label)
+                          (as-gtk-allocation
                            (case label
                              [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)]
                              [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)]
-                            [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])
+                             [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)]))
                           (if (send label ok?)
-                              (gtk_image_new_from_pixbuf 
+                              (let ([pixbuf (bitmap->pixbuf label)])
-                               (bitmap->pixbuf label))
+                                (begin0
+                                 (as-gtk-allocation
+                                  (gtk_image_new_from_pixbuf pixbuf))
+                                 (release-pixbuf pixbuf)))
                               (gtk_label_new_with_mnemonic "<bad-image>"))))]
              [no-show? (memq 'deleted style)])
 

collects/mred/private/wx/gtk/pixbuf.rkt

@@ -1,6 +1,7 @@
 #lang racket
 (require racket/class
          ffi/unsafe
+         ffi/unsafe/alloc
          racket/draw
          "../../lock.rkt"
          "../common/bstr.rkt"
@@ -10,10 +11,13 @@
 
 (provide _GdkPixbuf
          bitmap->pixbuf
-         gtk_image_new_from_pixbuf)
+         gtk_image_new_from_pixbuf
+         release-pixbuf)
 
 (define _GdkPixbuf (_cpointer 'GdkPixbuf))
 
+(define release-pixbuf ((deallocator) g_object_unref))
+
 (define-gtk gtk_image_new_from_pixbuf (_fun _GdkPixbuf -> _GtkWidget))
 (define-gdk_pixbuf gdk_pixbuf_new_from_data (_fun _pointer ; data
 						  _int ; 0  =RGB
@@ -24,7 +28,9 @@
 						  _int ; rowstride
 						  _fpointer ; destroy
 						  _pointer  ; destroy data
-						  -> _GdkPixbuf))
+						  -> _GdkPixbuf)
+  #:wrap (allocator release-pixbuf))
+
 (define free-it (ffi-callback free
                               (list _pointer)
                               _void

collects/mred/private/wx/gtk/radio-box.rkt

@@ -52,12 +52,13 @@
                                          [(string? lbl)
                                           (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))]
                                          [(send lbl ok?)
+                                          (let ([pixbuf (bitmap->pixbuf lbl)])
                                             (let ([radio-gtk (gtk_radio_button_new #f)]
-                                                [image-gtk (gtk_image_new_from_pixbuf 
+                                                  [image-gtk (gtk_image_new_from_pixbuf pixbuf)])
-                                                            (bitmap->pixbuf lbl))])
+                                              (release-pixbuf pixbuf)
                                               (gtk_container_add radio-gtk image-gtk)
                                               (gtk_widget_show image-gtk)
-                                            radio-gtk)]
+                                              radio-gtk))]
                                          [else
                                           (gtk_radio_button_new_with_mnemonic #f "<bad bitmap>")])])
                          (gtk_box_pack_start gtk radio-gtk #t #t 0)

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

@@ -1,6 +1,7 @@
 #lang scheme/base
 (require ffi/unsafe
          ffi/unsafe/define
+         ffi/unsafe/alloc
          (only-in '#%foreign ctype-c->scheme)
          "../common/utils.rkt"
          "types.rkt")
@@ -16,6 +17,9 @@
          g_object_ref
          g_object_unref
 
+         as-gtk-allocation
+         as-gtk-window-allocation
+
          g_free
          _gpath/free
          _GSList
@@ -82,8 +86,23 @@
 (define-ffi-definer define-gdk gdk-lib)
 (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib)
 
-(define-gobj g_object_ref (_fun _pointer -> _void))
+(define-gobj g_object_ref (_fun _pointer -> _pointer))
 (define-gobj g_object_unref (_fun _pointer -> _void))
+(define-gobj g_object_ref_sink (_fun _pointer -> _pointer))
+
+(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void))
+
+(define gtk-destroy ((deallocator) (lambda (v)
+                                     (gtk_widget_destroy v)
+                                     (g_object_unref v))))
+(define gtk-allocator (allocator gtk-destroy))
+
+(define-syntax-rule (as-gtk-allocation expr)
+  ((gtk-allocator (lambda () (let ([v expr])
+                               (g_object_ref_sink v)
+                               v)))))
+(define-syntax-rule (as-gtk-window-allocation expr)
+  ((gtk-allocator (lambda () expr))))
 
 (define-glib g_free (_fun _pointer -> _void))