From 72b671b6659702a9ff38c57b478873f661baffcb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Aug 2010 11:13:17 -0600 Subject: [PATCH] eventspace shutdown --- collects/mred/private/wx/cocoa/frame.rkt | 10 + collects/mred/private/wx/cocoa/window.rkt | 3 + collects/mred/private/wx/common/queue.rkt | 241 ++++++++++++---------- collects/mred/private/wx/gtk/frame.rkt | 16 +- collects/mred/private/wx/gtk/menu-bar.rkt | 5 +- collects/mred/private/wx/gtk/menu.rkt | 8 +- collects/mred/private/wx/gtk/widget.rkt | 14 +- collects/mred/private/wx/gtk/window.rkt | 3 +- 8 files changed, 184 insertions(+), 116 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3c843bdedb..c8b2578299 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -98,6 +98,7 @@ (init [is-dialog? #f]) (inherit get-cocoa get-parent + get-eventspace pre-on-char pre-on-event) (super-new [parent parent] @@ -232,8 +233,17 @@ (register-frame-shown this on?)))) (define/override (show on?) + (when on? + (when (eventspace-shutdown? (get-eventspace)) + (error (string->symbol + (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%))) + "the eventspace hash been shutdown"))) (direct-show on?)) + (define/public (destroy) + (when child-sheet (send child-sheet destroy)) + (direct-show #f)) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 91fbedb129..0f99ecf71c 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -169,6 +169,9 @@ (send parent get-eventspace) (current-eventspace))) + (when (eventspace-shutdown? eventspace) + (error '|GUI object initialization| "the eventspace has been shutdown")) + (set-ivar! cocoa wx this) (unless no-show? diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 2cdbf09d9c..e05b24238a 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -114,7 +114,7 @@ ;; ------------------------------------------------------------ ;; Eventspaces -(define-struct eventspace (handler-thread queue-proc frames-hash done-evt) +(define-struct eventspace (handler-thread queue-proc frames-hash done-evt [shutdown? #:mutable] done-sema) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -138,117 +138,141 @@ [(< am bm) -1] [else 1])))) + +(define-mz scheme_add_managed (_fun _racket ; custodian + _racket ; object + (_fun #:atomic? #t _racket _pointer -> _void) + _pointer ; data + _int ; strong? + -> _pointer)) + +(define (shutdown-eventspace! e ignored-data) + (unless (eventspace-shutdown? e) + (set-eventspace-shutdown?! e #t) + (semaphore-post (eventspace-done-sema e)) + (for ([f (in-list (get-top-level-windows e))]) + (send f destroy)))) + (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] [frames (make-hasheq)]) - (make-eventspace th - (let ([count 0]) - (let ([lo (mcons #f #f)] - [med (mcons #f #f)] - [hi (mcons #f #f)] - [timer (box '())] - [timer-counter 0] - [newly-posted-sema (make-semaphore)]) - (let* ([check-done - (lambda () - (if (or (positive? count) - (positive? (hash-count frames)) - (not (null? (unbox timer)))) - (semaphore-try-wait? done-sema) - (semaphore-post done-sema)))] - [enqueue (lambda (v q) - (set! count (add1 count)) - (check-done) - (let ([p (mcons v #f)]) - (if (mcdr q) - (set-mcdr! (mcdr q) p) - (set-mcar! q p)) - (set-mcdr! q p)))] - [first (lambda (q) - (and (mcar q) - (wrap-evt - always-evt - (lambda (_) - (start-atomic) - (set! count (sub1 count)) - (check-done) - (let ([result (mcar (mcar q))]) - (set-mcar! q (mcdr (mcar q))) - (unless (mcar q) - (set-mcdr! q #f)) - (end-atomic) - result)))))] - [remove-timer - (lambda (v timer) - (set-box! timer (rbtree-remove + (let ([e + (make-eventspace th + (let ([count 0]) + (let ([lo (mcons #f #f)] + [med (mcons #f #f)] + [hi (mcons #f #f)] + [timer (box '())] + [timer-counter 0] + [newly-posted-sema (make-semaphore)]) + (let* ([check-done + (lambda () + (if (or (positive? count) + (positive? (hash-count frames)) + (not (null? (unbox timer)))) + (semaphore-try-wait? done-sema) + (semaphore-post done-sema)))] + [enqueue (lambda (v q) + (set! count (add1 count)) + (check-done) + (let ([p (mcons v #f)]) + (if (mcdr q) + (set-mcdr! (mcdr q) p) + (set-mcar! q p)) + (set-mcdr! q p)))] + [first (lambda (q) + (and (mcar q) + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (set! count (sub1 count)) + (check-done) + (let ([result (mcar (mcar q))]) + (set-mcar! q (mcdr (mcar q))) + (unless (mcar q) + (set-mcdr! q #f)) + (end-atomic) + result)))))] + [remove-timer + (lambda (v timer) + (set-box! timer (rbtree-remove + timed-compare + v + (unbox timer))) + (check-done))]) + (case-lambda + [(v) + ;; Enqueue + (start-atomic) + (let ([val (cdr v)]) + (case (car v) + [(lo) (enqueue val lo)] + [(med) (enqueue val med)] + [(hi) (enqueue val hi)] + [(timer-add) + (set! timer-counter (add1 timer-counter)) + (set-timed-id! val timer-counter) + (set-box! timer + (rbtree-insert timed-compare - v + val (unbox timer))) - (check-done))]) - (case-lambda - [(v) - ;; Enqueue - (start-atomic) - (let ([val (cdr v)]) - (case (car v) - [(lo) (enqueue val lo)] - [(med) (enqueue val med)] - [(hi) (enqueue val hi)] - [(timer-add) - (set! timer-counter (add1 timer-counter)) - (set-timed-id! val timer-counter) - (set-box! timer - (rbtree-insert - timed-compare - val - (unbox timer))) - (check-done)] - [(timer-remove) (remove-timer val timer)] - [(frame-add) (hash-set! frames val #t) (check-done)] - [(frame-remove) (hash-remove! frames val) (check-done)])) - (semaphore-post newly-posted-sema) - (set! newly-posted-sema (make-semaphore)) - (check-done) - (end-atomic)] - [() - ;; Dequeue as evt - (start-atomic) - (let ([timer-first-ready - (lambda (timer) - (let ([rb (unbox timer)]) - (and (not (null? rb)) - (let* ([v (rbtree-min (unbox timer))] - [evt (timed-alarm-evt v)]) - (and (sync/timeout 0 evt) - ;; It's ready + (check-done)] + [(timer-remove) (remove-timer val timer)] + [(frame-add) (hash-set! frames val #t) (check-done)] + [(frame-remove) (hash-remove! frames val) (check-done)])) + (semaphore-post newly-posted-sema) + (set! newly-posted-sema (make-semaphore)) + (check-done) + (end-atomic)] + [() + ;; Dequeue as evt + (start-atomic) + (let ([timer-first-ready + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) + (let* ([v (rbtree-min (unbox timer))] + [evt (timed-alarm-evt v)]) + (and (sync/timeout 0 evt) + ;; It's ready + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (remove-timer v timer) + (end-atomic) + (timed-val v))))))))] + [timer-first-wait + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) (wrap-evt - always-evt - (lambda (_) - (start-atomic) - (remove-timer v timer) - (end-atomic) - (timed-val v))))))))] - [timer-first-wait - (lambda (timer) - (let ([rb (unbox timer)]) - (and (not (null? rb)) - (wrap-evt - (timed-alarm-evt (rbtree-min (unbox timer))) - (lambda (_) #f)))))]) - (let ([e (choice-evt - (wrap-evt (semaphore-peek-evt newly-posted-sema) - (lambda (_) #f)) - (or (first hi) - (timer-first-ready timer) - (first med) - (first lo) - (timer-first-wait timer) - ;; nothing else ready... - never-evt))]) - (end-atomic) - e))])))) - frames - (semaphore-peek-evt done-sema)))) + (timed-alarm-evt (rbtree-min (unbox timer))) + (lambda (_) #f)))))]) + (let ([e (choice-evt + (wrap-evt (semaphore-peek-evt newly-posted-sema) + (lambda (_) #f)) + (or (first hi) + (timer-first-ready timer) + (first med) + (first lo) + (timer-first-wait timer) + ;; nothing else ready... + never-evt))]) + (end-atomic) + e))])))) + frames + (semaphore-peek-evt done-sema) + #f + done-sema)]) + (scheme_add_managed (current-custodian) + e + shutdown-eventspace! + #f + 1) + e))) (define main-eventspace (make-eventspace* (current-thread))) (define current-eventspace (make-parameter main-eventspace)) @@ -308,7 +332,6 @@ (sync e)]))])) (define event-dispatch-handler (make-parameter void)) -(define (eventspace-shutdown? e) #f) (define (main-eventspace? e) (eq? e main-eventspace)) @@ -331,9 +354,9 @@ 'frame-add 'frame-remove))) -(define (get-top-level-windows) +(define (get-top-level-windows [e (current-eventspace)]) ;; called in event-pump thread - (hash-map (eventspace-frames-hash (current-eventspace)) + (hash-map (eventspace-frames-hash e) (lambda (k v) k))) (define (other-modal? win) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index ec99970b08..8e67ae9a5b 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -97,7 +97,7 @@ (inherit get-gtk set-size on-size pre-on-char pre-on-event get-client-delta get-size - get-parent) + get-parent get-eventspace) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) (when (memq 'no-caption style) @@ -207,10 +207,24 @@ (set-top-position x y) (gtk_window_resize gtk (max 1 w) (max 1 h))) + (define/override (show on?) + (when (and on? + (eventspace-shutdown? (get-eventspace))) + (error (string->symbol + (format "show method in ~a" + (if (frame-relative-dialog-status this) + 'dialog% + 'frame%))) + "eventspace has been shutdown")) + (super show on?)) + (define/override (direct-show on?) (super direct-show on?) (register-frame-shown this on?)) + (define/public (destroy) + (direct-show #f)) + (define/override (on-client-size w h) (on-size w h)) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 3e086852a0..20d225e519 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -63,6 +63,8 @@ (other-modal? wx)))) (defclass menu-bar% widget% + (inherit install-widget-parent) + (define menus null) (define gtk (gtk_menu_bar_new)) @@ -75,7 +77,8 @@ (define top-wx #f) (define/public (set-top-window top) - (set! top-wx top)) + (set! top-wx top) + (install-widget-parent top)) (define/public (get-top-window) top-wx) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index f5cf82474d..4e2232b606 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -75,6 +75,8 @@ callback font) + (inherit install-widget-parent) + (define cb callback) (define gtk (gtk_menu_new)) @@ -88,7 +90,8 @@ (define parent #f) (define/public (set-parent p) - (set! parent p)) + (set! parent p) + (install-widget-parent p)) (define/public (get-top-parent) ;; Maybe be called in Gtk event-handler thread (and parent @@ -187,7 +190,8 @@ (let ([item (new menu-item-handler% [gtk item-gtk] [menu this] - [menu-item i])]) + [menu-item i] + [parent this])]) (set! items (append items (list (list item item-gtk label chckable?)))) (adjust-shortcut item-gtk label))) (gtk_menu_shell_append gtk item-gtk) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index bb1d602b77..c8e8ea5450 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -2,6 +2,7 @@ (require scheme/foreign scheme/class "../../syntax.rkt" + "../common/queue.rkt" "queue.rkt" "utils.rkt" "types.rkt") @@ -30,11 +31,20 @@ (define widget% (class object% (init gtk - [extra-gtks null]) - (init-field [eventspace (current-eventspace)]) + [extra-gtks null] + [parent #f]) + (init-field [eventspace (if parent + (send parent get-eventspace) + (current-eventspace))]) + + (when (eventspace-shutdown? eventspace) + (error '|GUI object initialization| "the eventspace has been shutdown")) (define/public (get-eventspace) eventspace) (define/public (direct-update?) #t) + + (define/public (install-widget-parent p) + (set! eventspace (send p get-eventspace))) (super-new) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index b24e6537c7..c0f652d848 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -248,7 +248,8 @@ [add-to-parent? #t]) (super-new [gtk gtk] - [extra-gtks extra-gtks]) + [extra-gtks extra-gtks] + [parent parent]) (define save-x 0) (define save-y 0)