From 88f75dbc133313c715eb290c1ff4abeb3d42aff5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Jul 2010 20:03:23 -0600 Subject: [PATCH] fix constrained-reply to use delim continuations --- collects/mred/private/wx/cocoa/canvas.rkt | 12 +-- collects/mred/private/wx/cocoa/queue.rkt | 11 ++- collects/mred/private/wx/cocoa/slider.rkt | 11 +-- collects/mred/private/wx/cocoa/utils.rkt | 19 +---- collects/mred/private/wx/cocoa/window.rkt | 2 +- collects/mred/private/wx/common/freeze.rkt | 95 ++++++++++++++-------- collects/mred/private/wx/common/utils.rkt | 9 +- collects/mred/private/wx/gtk/menu-bar.rkt | 2 +- collects/mred/private/wx/gtk/queue.rkt | 11 ++- collects/mred/private/wx/gtk/window.rkt | 2 +- 10 files changed, 96 insertions(+), 78 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 2fb3d1c315..573080510f 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -14,7 +14,7 @@ "../common/queue.rkt" "../../syntax.rkt" "../../lock.rkt" - "freeze.rkt") + "../common/freeze.rkt") (provide canvas%) @@ -61,6 +61,7 @@ [gl-config #f]) (inherit get-cocoa + get-eventspace make-graphics-context get-client-size is-shown-to-root? @@ -327,11 +328,12 @@ [event-type kind] [direction direction] [position (get-scroll-pos direction)]))))))) - (frozen-stack-run-some - (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))))) - 200)) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void))) (define/public (on-scroll e) (void)) - + (define/override (wants-all-events?) ;; Called in Cocoa event-handling mode #t) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 76e3cb479d..a4d5f99d4c 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -8,7 +8,7 @@ "types.rkt" "../common/queue.rkt" "../../lock.rkt" - "freeze.rkt") + "../common/freeze.rkt") (unsafe!) (objc-unsafe!) @@ -213,11 +213,10 @@ (begin (retain evt) (queue-event e (lambda () - (as-entry (lambda () - (call-with-frozen-stack - (lambda () - (tellv app sendEvent: evt) - (release evt)))))))) + (call-as-unfreeze-point + (lambda () + (tellv app sendEvent: evt) + (release evt)))))) (tellv app sendEvent: evt))) #t))) (tellv pool release)))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index c287e067b8..d9c06a3148 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -10,8 +10,8 @@ "window.rkt" "../common/event.rkt" "../common/queue.rkt" - "../../lock.rkt" - "freeze.rkt") + "../common/freeze.rkt" + "../../lock.rkt") (unsafe!) (objc-unsafe!) @@ -26,9 +26,10 @@ [wx] (-a _void (changed: [_id sender]) (queue-window-event wx (lambda () (send wx changed))) - (frozen-stack-run-some - (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))))) - 200))) + (constrained-reply + (send wx get-eventspace) + (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void)))) (defclass slider% item% (init parent cb diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index a4e9d37740..aacb4303ba 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe/objc ffi/unsafe ffi/unsafe/alloc + ffi/unsafe/define "../common/utils.rkt") (provide cocoa-lib @@ -18,21 +19,9 @@ (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) (define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices"))) -(define-syntax define-cocoa/private - (syntax-rules () - [(_ id type) - (define-cocoa/private id id type)] - [(_ id c-id type) - (define id (get-ffi-obj 'c-id cocoa-lib type))])) - -(define-syntax-rule (define-cocoa id type) - (define-cocoa/private id id type)) - -(define-syntax-rule (define-cf id type) - (define id (get-ffi-obj 'id cf-lib type))) - -(define-syntax-rule (define-appserv id type) - (define id (get-ffi-obj 'id appserv-lib type))) +(define-ffi-definer define-cocoa cocoa-lib) +(define-ffi-definer define-cf cf-lib) +(define-ffi-definer define-appserv appserv-lib) (define (objc-delete v) (tellv v release)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 807f93e7d3..e11beb0591 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -9,7 +9,7 @@ "keycode.rkt" "../common/event.rkt" "../../syntax.rkt" - "freeze.rkt") + "../common/freeze.rkt") (unsafe!) (objc-unsafe!) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index cfcf2ff41d..e8278e1021 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -1,45 +1,74 @@ #lang scheme/base (require scheme/foreign - "../common/utils.rkt" - "../common/queue.rkt") + racket/draw/hold + "utils.rkt" + "queue.rkt" + "../../lock.rkt") (unsafe!) -(provide call-with-frozen-stack - frozen-stack-run-some +(provide call-as-unfreeze-point constrained-reply) -(define-mz scheme_with_stack_freeze (_fun (_fun _scheme -> _int) _scheme -> _int)) -(define-mz scheme_frozen_run_some (_fun (_fun _scheme -> _int) _scheme _int -> _int)) -(define-mz scheme_is_in_frozen_stack (_fun -> _int)) +(define-mz scheme_abort_continuation_no_dws (_fun _scheme _scheme -> _scheme)) +(define-mz scheme_call_with_composable_no_dws (_fun _scheme _scheme -> _scheme)) +(define-mz scheme_set_on_atomic_timeout (_fun (_fun -> _void) -> _pointer)) +(define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer) + #:c-id scheme_set_on_atomic_timeout) -(define (do-apply p) - ;; Continuation prompt ensures that errors do not escape - ;; (and escapes are not supported by the frozen-stack implementation) - (call-with-continuation-prompt p) - 1) +(define freezer-box (make-parameter #f)) +(define freeze-tag (make-continuation-prompt-tag)) -(define (call-with-frozen-stack thunk) - (void (scheme_with_stack_freeze do-apply thunk))) +;; Runs `thunk' atomically, but cooperates with +;; `constrained-reply' to continue a frozen +;; computation in non-atomic mode. +(define (call-as-unfreeze-point thunk) + (let ([b (box #f)]) + (parameterize ([freezer-box b]) + ;; In atomic mode: + (as-entry (lambda () (thunk))) + ;; Out of atomic mode: + (let ([k (unbox b)]) + (when k + (call-with-continuation-prompt + k + freeze-tag))) + (void)))) -(define (frozen-stack-run-some thunk msecs) - (positive? (scheme_frozen_run_some do-apply thunk msecs))) - -;; FIXME: this loop needs to give up on the thunk -;; if it takes too long to return; as long as we're in the -;; loop, no other threads/eventspaces can run -(define (constrained-reply es thunk default) +;; FIXME: waiting 200msec is not a good enough rule. +(define (constrained-reply es thunk default [should-give-up? + (let ([now (current-inexact-milliseconds)]) + (lambda () + ((current-inexact-milliseconds) . > . 200)))]) + (unless (freezer-box) + (log-error "internal error: constrained-reply not within an unfreeze point")) (if (eq? (current-thread) (eventspace-handler-thread es)) - (let ([done? #f] - [result default]) - (frozen-stack-run-some (lambda () (set! result (thunk))) - 200) - (let loop () - (frozen-stack-run-some (lambda () (set! done? #t)) 200) - (unless done? (loop))) - result) + (let* ([prev #f] + [ready? #f] + [handler (lambda () + (when (and ready? (should-give-up?)) + (scheme_call_with_composable_no_dws + (lambda (proc) + (set-box! (freezer-box) proc) + (scheme_restore_on_atomic_timeout prev) + (scheme_abort_continuation_no_dws + freeze-tag + (lambda () default))) + freeze-tag) + (void)))] + [old (scheme_set_on_atomic_timeout handler)]) + (with-holding + handler + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt ; for composable continuation + (lambda () + (set! prev old) + (set! ready? #t) + (begin0 + (parameterize ([freezer-box #f]) + (thunk)) + (scheme_restore_on_atomic_timeout prev))) + freeze-tag))))) (begin - (eprintf "WARNING: internal error: wrong eventspace for constrained event handling\n") - (eprintf "~s\n" (continuation-mark-set->context (current-continuation-marks))) + (log-error "internal error: wrong eventspace for constrained event handling\n") default))) - - diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt index 8de704c5b8..5e7e4f0224 100644 --- a/collects/mred/private/wx/common/utils.rkt +++ b/collects/mred/private/wx/common/utils.rkt @@ -1,8 +1,7 @@ -#lang scheme/base -(require scheme/foreign) -(unsafe!) +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define) (provide define-mz) -(define-syntax-rule (define-mz id type) - (define id (get-ffi-obj 'id #f type))) +(define-ffi-definer define-mz #f) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index dc59e96356..84abe61cc4 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -2,7 +2,7 @@ (require scheme/class scheme/foreign "../../syntax.rkt" - "../cocoa/freeze.rkt" + "../common/freeze.rkt" "widget.rkt" "utils.rkt" "types.rkt") diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index a37830bf26..443f87393f 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -5,7 +5,7 @@ "types.rkt" racket/draw/lock "../common/queue.rkt" - "../cocoa/freeze.rkt" + "../common/freeze.rkt" "const.rkt") (provide gtk-start-event-pump @@ -105,11 +105,10 @@ => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () - (as-entry (lambda () - (call-with-frozen-stack - (lambda () - (gtk_main_do_event evt) - (gdk_event_free evt)))))))))] + (call-as-unfreeze-point + (lambda () + (gtk_main_do_event evt) + (gdk_event_free evt)))))))] [else (gtk_main_do_event evt)]))) (define (uninstall ignored) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index afe8079bbe..f8d33dbbe4 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -4,7 +4,7 @@ ffi/unsafe/atomic "../../syntax.rkt" "../common/event.rkt" - "../cocoa/freeze.rkt" + "../common/freeze.rkt" "keycode.rkt" "queue.rkt" "utils.rkt"