From 3f3d5f0f2131293bb3d4fff886158bd34c6cfdae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 13:39:32 -0600 Subject: [PATCH] win32: memory management --- collects/mred/private/wx/win32/button.rkt | 9 ++-- collects/mred/private/wx/win32/canvas.rkt | 11 ++--- collects/mred/private/wx/win32/frame.rkt | 45 ++++++++++++++------ collects/mred/private/wx/win32/gcwin.rkt | 2 - collects/mred/private/wx/win32/hbitmap.rkt | 6 --- collects/mred/private/wx/win32/item.rkt | 5 +++ collects/mred/private/wx/win32/message.rkt | 11 +++-- collects/mred/private/wx/win32/radio-box.rkt | 9 ++-- collects/mred/private/wx/win32/utils.rkt | 43 +++++++++++++++++-- collects/mred/private/wx/win32/window.rkt | 5 +++ collects/mred/private/wx/win32/wndclass.rkt | 6 +++ 11 files changed, 111 insertions(+), 41 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 88a153f3d4..75639f4c6a 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -20,7 +20,8 @@ (define base-button% (class item% (inherit set-control-font auto-size get-hwnd - subclass-control) + subclass-control + remember-label-bitmap) (init parent cb label x y w h style font) @@ -53,8 +54,10 @@ [style style]) (when bitmap? - (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label #:bg #xFFFFFF) _HBITMAP _LPARAM))) + (let ([hbitmap (bitmap->hbitmap label #:bg #xFFFFFF)]) + (remember-label-bitmap hbitmap) + (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) (set-control-font font) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 931ba4b2b6..eb374ca6f1 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -31,14 +31,9 @@ -> (unless r (failed 'ShowScrollbar)))) (define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) -(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) - -> (unless r (failed 'DeleteObject)))) (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) -(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) - -> (unless r (failed 'DestroyWindow)))) - (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) @@ -89,7 +84,8 @@ subclass-control is-auto-scroll? get-virtual-width get-virtual-height reset-auto-scroll - refresh-for-autoscroll) + refresh-for-autoscroll + on-size) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) @@ -228,7 +224,8 @@ [w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)] [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)]) (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t) - (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))) + (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t))) + (on-size 0 0)) ;; The `queue-paint' and `paint-children' methods ;; are defined by `canvas-mixin' from ../common/canvas-mixin diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 3a49cc3e30..8bc64a745c 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -3,6 +3,7 @@ racket/draw (only-in racket/list last) ffi/unsafe + ffi/unsafe/alloc "../../syntax.rkt" "../../lock.rkt" "../common/queue.rkt" @@ -44,8 +45,13 @@ [yHotspot _DWORD] [hbmMask _HBITMAP] [hbmColor _HBITMAP])) + +(define-user32 DestroyIcon (_wfun _HICON -> (r : _BOOL) + -> (unless r (failed 'DestroyIcon))) + #:wrap (deallocator)) (define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON) - -> (or r (failed 'CreateIconIndirect)))) + -> (or r (failed 'CreateIconIndirect))) + #:wrap (allocator DestroyIcon)) (define SPI_GETWORKAREA #x0030) @@ -378,23 +384,36 @@ (define/override (is-frame?) #t) + ;; Retain to aviod GC of the icon: + (define small-hicon #f) + (define big-hicon #f) + (define/public (set-icon bm mask [mode 'both]) - (let ([hicon (CreateIconIndirect - (make-ICONINFO - #t 0 0 - (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] - [dc (make-object bitmap-dc% bm)]) - (send dc set-brush "black" 'solid) - (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) - (send dc set-bitmap #f) - (bitmap->hbitmap bm #:b&w? #t)) - (bitmap->hbitmap bm #:mask mask)))]) + (let* ([bg-hbitmap + (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] + [dc (make-object bitmap-dc% bm)]) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send dc set-bitmap #f) + (bitmap->hbitmap bm #:b&w? #t))] + [main-hbitmap (bitmap->hbitmap bm #:mask mask)] + [hicon (CreateIconIndirect + (make-ICONINFO + #t 0 0 + bg-hbitmap + main-hbitmap))]) + (DeleteObject bg-hbitmap) + (DeleteObject main-hbitmap) (when (or (eq? mode 'small) (eq? mode 'both)) - (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM))) + (atomically + (set! small-hicon hicon) + (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM)))) (when (or (eq? mode 'big) (eq? mode 'both)) - (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM))))) + (atomically + (set! big-hicon hicon) + (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))) (def/public-unimplemented iconize) (define/public (set-title s) diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt index e43a2a32d6..7f84bdcc13 100644 --- a/collects/mred/private/wx/win32/gcwin.rkt +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -21,8 +21,6 @@ (define-gdi32 SelectObject/raw _fpointer #:c-id SelectObject) -(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) - (define SRCCOPY #x00CC0020) (define blit-hdc (CreateCompatibleDC #f)) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index b4e0952f91..81e327c530 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -10,12 +10,6 @@ (provide bitmap->hbitmap) -(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)) -(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP)) -(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) -(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) - -> (unless r (failed 'DeleteDC)))) - (define (bitmap->hbitmap bm #:mask [mask-bm #f] #:b&w? [b&w? #f] diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 6f8491ffa5..a74d0cd606 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -76,6 +76,11 @@ (super-new) (define/override (gets-focus?) #t) + + ;; Retain to avoid GC of the bitmaps: + (define label-hbitmaps null) + (define/public (remember-label-bitmap hbitmap) + (set! label-hbitmaps (cons hbitmap label-hbitmaps))) (define/public (set-label s) (SetWindowTextW (get-hwnd) s)) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index a0af26eaf4..2572c55b20 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -64,7 +64,8 @@ (define message% (class item% (inherit auto-size set-size set-control-font get-hwnd - subclass-control) + subclass-control + remember-label-bitmap) (init parent label x y @@ -100,8 +101,10 @@ (subclass-control (get-hwnd)) (when bitmap? - (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (let ([hbitmap (bitmap->hbitmap label)]) + (remember-label-bitmap hbitmap) + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) (when (symbol? label) (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON (cast (force (case label @@ -111,7 +114,7 @@ _HICON _LPARAM))) (set-control-font font) - + (if (symbol? label) (set-size -11111 -11111 32 32) (auto-size label 0 0 0 0)))) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 583b246e47..41db4c265c 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -30,7 +30,8 @@ (inherit auto-size set-control-font is-enabled-to-root? subclass-control - set-focus) + set-focus + remember-label-bitmap) (define callback cb) (define current-value val) @@ -71,8 +72,10 @@ hInstance #f)]) (when bitmap? - (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (let ([hbitmap (bitmap->hbitmap label)]) + (remember-label-bitmap hbitmap) + (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) (ShowWindow radio-hwnd SW_SHOW) (set-control-font font radio-hwnd) (let-values ([(w h) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 273cca8ac9..25d4cb819e 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define + ffi/unsafe/alloc "../common/utils.rkt" "types.rkt") @@ -14,11 +15,18 @@ failed GetLastError + DestroyWindow + NotifyWindowDestroy CreateWindowExW GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str GetSysColor GetRValue GetGValue GetBValue make-COLORREF + CreateBitmap + CreateCompatibleBitmap + DeleteObject + CreateCompatibleDC + DeleteDC MoveWindow ShowWindow EnableWindow @@ -53,13 +61,20 @@ (error who "call failed (~s)" (GetLastError))) +(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DestroyWindow))) + #:wrap (deallocator)) +(define NotifyWindowDestroy ((deallocator) void)) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 _UDWORD _int _int _int _int _HWND _HMENU _HINSTANCE _pointer - -> _HWND)) + -> _HWND) + #:wrap (allocator DestroyWindow)) + (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) @@ -88,8 +103,30 @@ (define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR)) -(define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) +(define-user32 _GetDC (_wfun _HWND -> _HDC) + #:c-id GetDC) +(define (GetDC hwnd) + (((allocator (lambda (hdc) (ReleaseDC hwnd hdc))) + _GetDC) + hwnd)) + +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int) + #:wrap (deallocator cadr)) + +(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) + -> (unless r (failed 'DeleteObject))) + #:wrap (deallocator)) + +(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP) + #:wrap (allocator DeleteObject)) +(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP) + #:wrap (allocator DeleteObject)) + +(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) + -> (unless r (failed 'DeleteDC))) + #:wrap (deallocator)) +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC) + #:wrap (allocator DeleteDC)) (define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) -> (unless r (failed 'InvalidateRect)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index f7cc9df248..b231db0b7e 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -114,6 +114,11 @@ (if (try-mouse w msg wParam lParam) 0 (cond + [(= msg WM_DESTROY) + ;; release immobile cell + (unregister-hwnd w) + ;; so it won't be finalized: + (NotifyWindowDestroy w)] [(= msg WM_SETFOCUS) (queue-window-event this (lambda () (on-set-focus))) 0] diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 2033e2ac05..d789de6641 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -13,6 +13,7 @@ hwnd->wx any-hwnd->wx set-hwnd-wx! + unregister-hwnd MessageBoxW _WndProc) @@ -38,6 +39,11 @@ (send wx is-hwnd? hwnd) wx))))) +(define (unregister-hwnd hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (when p + (free-immobile-cell p) + (SetWindowLongW hwnd GWLP_USERDATA #f)))) ;; ----------------------------------------