suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

more memory management

Browse Source 
original commit: c7049058336382b651c82b3a98c8a7feb9311257
This commit is contained in:
Matthew Flatt 2010-08-15 10:56:02 -06:00
parent 2197b56aab
commit 1752204327
11 changed files with 145 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/wx/cocoa/image.rkt
View File

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

43
collects/mred/private/wx/cocoa/pool.rkt
View File

@ -1,17 +1,44 @@
#lang scheme/base
(require ffi/objc
scheme/foreign
#lang racket/base
(require ffi/unsafe
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
;; process exits.
;; have a pool:
(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)))))

2
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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!

16
collects/mred/private/wx/cocoa/window.rkt
View File

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

10
collects/mred/private/wx/common/queue.rkt
View File

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

24
collects/mred/private/wx/gtk/button.rkt
View File

@ -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)]
[image-gtk (gtk_image_new_from_pixbuf
(bitmap->pixbuf label))])
(let ([pixbuf (bitmap->pixbuf label)])
(atomically
(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
(bitmap->pixbuf s))])
(let ([pixbuf (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))))

11
collects/mred/private/wx/gtk/frame.rkt
View File

@ -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 panel-gtk (gtk_fixed_new))
(define-values (vbox-gtk panel-gtk)
(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)

12
collects/mred/private/wx/gtk/message.rkt
View File

@ -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
(bitmap->pixbuf label))
(let ([pixbuf (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)])

10
collects/mred/private/wx/gtk/pixbuf.rkt
View File

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

7
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -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
(bitmap->pixbuf lbl))])
[image-gtk (gtk_image_new_from_pixbuf pixbuf)])
(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)

21
collects/mred/private/wx/gtk/utils.rkt
View File

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