win32: change HWND allocation and deallocation

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

@@ -21,7 +21,6 @@
 (define base-button% 
   (class item%
     (inherit set-control-font auto-size get-hwnd
-             subclass-control
              remember-label-bitmap)
 
     (init parent cb label x y w h style font)
@@ -38,7 +37,7 @@
     (super-new [callback cb]
                [parent parent]
                [hwnd 
-                (CreateWindowExW 0
+                (CreateWindowExW/control 0
                                          (get-class)
                                          (if (string? label)
                                              label
@@ -73,8 +72,6 @@
         (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
     (auto-size-button font label)
 
-    (subclass-control (get-hwnd))
-
     (define/override (is-command? cmd)
       (= cmd BN_CLICKED))
 

collects/mred/private/wx/win32/canvas.rkt

@@ -82,7 +82,6 @@
               get-client-size
               get-eventspace
               set-control-font
-              subclass-control
               is-auto-scroll? get-virtual-width get-virtual-height
               reset-auto-scroll
               refresh-for-autoscroll
@@ -122,7 +121,7 @@
                         #f))
      (define combo-hwnd
        (and panel-hwnd
-            (CreateWindowExW 0
+            (CreateWindowExW/control 0
                                      "PLTCOMBOBOX"
                                      ""
                                      (bitwise-ior WS_CHILD WS_VISIBLE
@@ -145,8 +144,7 @@
                 [style style])
 
      (when combo-hwnd
-       (set-control-font #f combo-hwnd)
+       (set-control-font #f combo-hwnd))
-       (subclass-control combo-hwnd))
 
      (define control-border-theme
        (and (memq 'control-border style)

collects/mred/private/wx/win32/choice.rkt

@@ -25,13 +25,12 @@
           x y w h
           choices style font)
     (inherit auto-size set-control-font
-             set-size
+             set-size)
-             subclass-control)
 
     (define callback cb)
     
     (define hwnd
-      (CreateWindowExW 0
+      (CreateWindowExW/control 0
                                "PLTCOMBOBOX"
                                label
                                (bitwise-ior WS_CHILD CBS_DROPDOWNLIST 
@@ -66,8 +65,6 @@
                  (set-size -11111 -11111 w (* h 8))))
 
 
-    (subclass-control hwnd)
-
     (define choice-dropped? #f)
 
     (define/override (ctlproc w msg wParam lParam default)

collects/mred/private/wx/win32/gauge.rkt

@@ -21,8 +21,7 @@
 
 (define gauge%
   (class item%
-    (inherit set-size
+    (inherit set-size)
-             subclass-control)
 
     (init parent
           label
@@ -32,7 +31,7 @@
           font)
 
     (define hwnd
-      (CreateWindowExW 0
+      (CreateWindowExW/control 0
                                "PLTmsctls_progress32"
                                label
                                (bitwise-ior WS_CHILD WS_CLIPSIBLINGS
@@ -56,8 +55,6 @@
         (set-size -11111 -11111 100 24)
         (set-size -11111 -11111 24 100))
 
-    (subclass-control hwnd)
-
     (define/public (get-value)
       (SendMessageW hwnd PBM_GETPOS 0 0))
     (define/public (set-value v)

collects/mred/private/wx/win32/group-panel.rkt

@@ -22,11 +22,10 @@
           style
           label)
 
-    (inherit auto-size set-control-font
+    (inherit auto-size set-control-font)
-             subclass-control)
 
     (define hwnd
-      (CreateWindowExW 0
+      (CreateWindowExW/control 0
                                "PLTBUTTON"
                                (or label "")
                                (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS)
@@ -63,7 +62,6 @@
                (lambda (w h)
                  (set! label-h h)
                  (set-size -11111 -11111 (+ w 10) (+ h 10))))
-    (subclass-control hwnd)
 
     (define/public (set-label lbl)
       (SetWindowTextW hwnd lbl))

collects/mred/private/wx/win32/item.rkt

@@ -16,17 +16,6 @@
  (protect-out item-mixin
               item%))
 
-(define (control-proc w msg wParam lParam)
-  (let ([wx (hwnd->wx w)])
-    (if wx
-        (send wx ctlproc w msg wParam lParam
-              (lambda (w msg wParam lParam)
-                ((hwnd->ctlproc w) w msg wParam lParam)))
-        (let ([default-ctlproc (hwnd->ctlproc w)])
-          (default-ctlproc w msg wParam lParam)))))
-
-(define control_proc (function-ptr control-proc _WndProc))
-
 (define (item-mixin %)
   (class %
     (inherit on-set-focus
@@ -40,11 +29,6 @@
 
     (super-new)
     
-    (define/public (subclass-control hwnd)
-      (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
-        (set-hwnd-ctlproc! hwnd old-control-proc)
-        (SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
-    
     (define/public (ctlproc w msg wParam lParam default)
       (if (try-mouse w msg wParam lParam)
           0

collects/mred/private/wx/win32/list-box.rkt

@@ -54,7 +54,6 @@
           font label-font)
 
     (inherit set-size set-control-font
-             subclass-control
              get-client-size)
 
     (define single?
@@ -62,7 +61,7 @@
            (not (memq 'mutiple style))))
 
     (define hwnd
-      (CreateWindowExW WS_EX_CLIENTEDGE
+      (CreateWindowExW/control WS_EX_CLIENTEDGE
                                "PLTLISTBOX"
                                label
                                (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
@@ -90,8 +89,6 @@
     (set-control-font font)
     (set-size -11111 -11111 40 60)
 
-    (subclass-control hwnd)
-
     (define callback cb)
 
     (define/override (is-command? cmd)

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

@@ -65,7 +65,6 @@
 (define message%
   (class item%
     (inherit auto-size set-size set-control-font get-hwnd
-             subclass-control
              remember-label-bitmap)
 
     (init parent label
@@ -81,7 +80,7 @@
     (super-new [callback void]
                [parent parent]
                [hwnd 
-                (CreateWindowExW 0
+                (CreateWindowExW/control 0
                                          (get-class)
                                          (if (string? label)
                                              label
@@ -99,8 +98,6 @@
                                          #f)]
                [style style])
 
-    (subclass-control (get-hwnd))
-
     (when bitmap?
       (let ([hbitmap (bitmap->hbitmap label)])
         (remember-label-bitmap hbitmap)

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

@@ -30,7 +30,6 @@
 
     (inherit auto-size set-control-font
              is-enabled-to-root?
-             subclass-control
              set-focus)
 
     (define callback cb)
@@ -59,7 +58,7 @@
                    [bitmap? (and (label . is-a? . bitmap%)
                                  (send label ok?))]
                    [radio-hwnd 
-                    (CreateWindowExW 0
+                    (CreateWindowExW/control 0
                                              "PLTBUTTON"
                                              (if (string? label)
                                                  label
@@ -97,9 +96,6 @@
                [extra-hwnds radio-hwnds]
                [style style])
 
-    (for ([radio-hwnd (in-list radio-hwnds)])
-      (subclass-control radio-hwnd))
-
     (define/override (is-hwnd? a-hwnd)
       (or (ptr-equal? hwnd a-hwnd)
           (for/or ([radio-hwnd (in-list radio-hwnds)])

collects/mred/private/wx/win32/slider.rkt

@@ -40,8 +40,7 @@
         style
         font)
   (inherit set-control-font
-           auto-size
+           auto-size)
-           subclass-control)
 
   (define callback cb)
   (define vertical? (memq 'vertical style))
@@ -79,7 +78,7 @@
 
   (define value-hwnd
     (and panel-hwnd
-         (CreateWindowExW 0
+         (CreateWindowExW/control 0
                                   "STATIC"
                                   (format "~s" val)
                                   (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
@@ -129,8 +128,6 @@
   (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi))
   (set-value val)
 
-  (subclass-control slider-hwnd)
-
   (define/override (set-size x y w h)
     (super set-size x y w h)
     (when panel-hwnd

collects/mred/private/wx/win32/tab-panel.rkt

@@ -45,11 +45,10 @@
     (define callback void)
 
     (inherit auto-size set-control-font
-             is-shown-to-root?
+             is-shown-to-root?)
-             subclass-control)
 
     (define hwnd
-      (CreateWindowExW 0
+      (CreateWindowExW/control 0
                                "PLTSysTabControl32"
                                ""
                                (bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
@@ -76,8 +75,6 @@
                [hwnd hwnd]
                [style style])
 
-    (subclass-control hwnd)
-
     (define/override (get-client-hwnd)
       client-hwnd)
 

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

@@ -19,11 +19,6 @@
 
               GetLastError
 
-              DestroyWindow
-              NotifyWindowDestroy
-              CreateWindowExW
-              clean-up-destroyed
-
               GetWindowLongW
               SetWindowLongW
               SendMessageW SendMessageW/str
@@ -71,23 +66,6 @@
   (error who "call failed (~s)"
          (GetLastError)))
 
-(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
-                                    -> (unless r (failed 'DestroyWindow)))
-  #: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
-				      _UDWORD
-				      _int _int _int _int
-				      _HWND _HMENU _HINSTANCE _pointer
-				      -> _HWND)
-  #:wrap (allocator remember-to-free-later))
-
 (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
 (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
 

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

@@ -143,11 +143,6 @@
     (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]

collects/mred/private/wx/win32/wndclass.rkt

@@ -1,7 +1,9 @@
 #lang racket/base
 (require ffi/unsafe
+         ffi/unsafe/alloc
 	 racket/class
          "../../lock.rkt"
+         "../common/utils.rkt"
 	 "utils.rkt"
 	 "types.rkt"
 	 "const.rkt"
@@ -12,11 +14,12 @@
               DefWindowProcW
               background-hbrush
               set-hwnd-wx!
-              set-hwnd-ctlproc!
               hwnd->wx
               hwnd->ctlproc
               any-hwnd->wx
-              unregister-hwnd
+              CreateWindowExW
+              CreateWindowExW/control
+              clean-up-destroyed
               MessageBoxW
               _WndProc))
 
@@ -32,50 +35,69 @@
 ;;                | (cons <ctlproc> <wx-weak-box>)
 ;;  <wx-weak-box> = (make-weak-box <object%>)
 
-(define all-cells (make-hash))
+(define all-hwnds (make-hash))
+
+;; call in atomic mode:
+(define (register-hwnd! hwnd)
+  (hash-set! all-hwnds (cast hwnd _pointer _long) #t))
+
+;; call in atomic mode:
+(define (alloc-hwnd-cell hwnd)
+  (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
+    (or c
+        (let ([c (malloc-immobile-cell #f)])
+          (SetWindowLongW hwnd GWLP_USERDATA c)
+          c))))
 
 (define (set-hwnd-wx! hwnd wx)
-  (let ([c (malloc-immobile-cell (make-weak-box wx))])
+  (let* ([c (atomically (alloc-hwnd-cell hwnd))]
-    (SetWindowLongW hwnd GWLP_USERDATA c)
+         [v (ptr-ref c _racket)])
-    (atomically (hash-set! all-cells (cast c _pointer _long) #t))))
+    (ptr-set! c _racket (cons wx (and v (cdr v))))))
 
 (define (set-hwnd-ctlproc! hwnd ctlproc)
-  (let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
+  (let* ([c (atomically (alloc-hwnd-cell hwnd))]
-    (ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc))))
+         [v (ptr-ref c _racket)])
+    (ptr-set! c _racket (cons (and v (car v)) ctlproc))))
 
 (define (hwnd->wx hwnd)
-  (let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
+  (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
-    (and p (let ([wb (ptr-ref p _racket)])
+    (and c (let ([wb (ptr-ref c _racket)])
              (and wb
                   (weak-box-value (if (pair? wb) 
                                       (car wb) 
                                       wb)))))))
 
 (define (hwnd->ctlproc hwnd)
-  (let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
+  (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
-    (and p (let ([wb (ptr-ref p _racket)])
+    (and c (let ([wb (ptr-ref c _racket)])
              (and wb
                   (pair? wb)
                   (cdr wb))))))
 
 (define (any-hwnd->wx hwnd)
-  (let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
+  (and
-    (and p 
+   (atomically (hash-ref all-hwnds (cast hwnd _pointer _long) #f))
-         (atomically (hash-ref all-cells (cast p _pointer _long) #f))
+   (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
-         (let ([wx (let ([wb (ptr-ref p _racket)])
+     (and c 
+          (let ([wx (let ([wb (ptr-ref c _racket)])
                       (and wb 
                            (weak-box-value (if (pair? wb)
                                                (car wb)
                                                wb))))])
             (and wx
                  (send wx is-hwnd? hwnd)
-                wx)))))
+                 wx))))))
 
-(define (unregister-hwnd hwnd)
+;; call in atomic mode:
-  (let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
+(define (unregister-hwnd? hwnd)
-    (when p
+  (let ([addr (cast hwnd _pointer _long)])
-      (free-immobile-cell p)
+    (and (hash-ref all-hwnds addr #f)
-      (SetWindowLongW hwnd GWLP_USERDATA #f))))
+         (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
+           (when c
+             (free-immobile-cell c)
+             (hash-ref all-hwnds addr #f)
+             (SetWindowLongW hwnd GWLP_USERDATA #f)
+             #t)))))
 
 ;; ----------------------------------------
 
@@ -95,6 +117,74 @@
 (define _WndProc (_wfun #:atomic? #t #:keep (box null)
 			_HWND _UINT _WPARAM _LPARAM -> _LRESULT))
 
+(define (wind-proc w msg wparam lparam)
+  (if (= msg WM_DESTROY)
+      (begin
+        (unregister-hwnd? w)
+        (DefWindowProcW w msg wparam lparam))
+      (let ([wx (hwnd->wx w)])
+        (if wx
+            (send wx wndproc w msg wparam lparam DefWindowProcW)
+            (DefWindowProcW w msg wparam lparam)))))
+
+(define wind-proc-ptr (function-ptr wind-proc _WndProc))
+
+(define (control-proc w msg wParam lParam)
+  (if (= msg WM_DESTROY)
+      (let ([default-ctlproc (hwnd->ctlproc w)])
+        (unregister-hwnd? w)
+        (default-ctlproc w))
+      (let ([wx (hwnd->wx w)])
+        (if wx
+            (send wx ctlproc w msg wParam lParam
+                  (lambda (w msg wParam lParam)
+                    ((hwnd->ctlproc w) w msg wParam lParam)))
+            (let ([default-ctlproc (hwnd->ctlproc w)])
+              (default-ctlproc w msg wParam lParam))))))
+
+(define control_proc (function-ptr control-proc _WndProc))
+
+(define (subclass-control hwnd)
+  (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
+    (set-hwnd-ctlproc! hwnd old-control-proc)
+    (SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
+
+;; ----------------------------------------
+
+(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
+                                    -> (unless r (failed 'DestroyWindow))))
+
+(define (maybe-destroy-window hwnd)
+  (atomically
+   (when (unregister-hwnd? hwnd)
+     (DestroyWindow hwnd))))
+
+(define (clean-up-destroyed)
+  (free-remembered-now maybe-destroy-window))
+
+(define-user32 _CreateWindowExW (_wfun _DWORD
+                                       _string/utf-16
+                                       _string/utf-16
+                                       _UDWORD
+                                       _int _int _int _int
+                                       _HWND _HMENU _HINSTANCE _pointer
+                                       -> _HWND)
+  #:c-id CreateWindowExW)
+
+(define (make-CreateWindowEx register!)
+  ((allocator remember-to-free-later)
+   (lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)
+     (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)])
+       (register-hwnd! hwnd)
+       hwnd))))
+
+(define CreateWindowExW (make-CreateWindowEx register-hwnd!))
+(define CreateWindowExW/control (make-CreateWindowEx (lambda (hwnd)
+                                                       (register-hwnd! hwnd)
+                                                       (subclass-control hwnd))))
+
+;; ----------------------------------------
+
 (define-cstruct _WNDCLASS ([style _UINT]
 			   [lpfnWndProc _fpointer]
 			   [cbClsExtra _int]
@@ -120,14 +210,6 @@
 
 #;(define-user32 PostQuitMessage (_wfun _int -> _void))
 
-(define (wind-proc w msg wparam lparam)
-  (let ([wx (hwnd->wx w)])
-    (if wx
-        (send wx wndproc w msg wparam lparam DefWindowProcW)
-        (DefWindowProcW w msg wparam lparam))))
-
-(define wind-proc-ptr (function-ptr wind-proc _WndProc))
-
 (define hInstance (GetModuleHandleW #f))
 
 (define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])