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

fix constrained-reply to use delim continuations

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-12 20:03:23 -06:00
parent cb69ea3c66
commit 88f75dbc13
10 changed files with 96 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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,9 +328,10 @@
[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?)

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

@ -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
(call-as-unfreeze-point
(lambda ()
(tellv app sendEvent: evt)
(release evt))))))))
(release evt))))))
(tellv app sendEvent: evt)))
#t)))
(tellv pool release))))

11
collects/mred/private/wx/cocoa/slider.rkt
View File

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

19
collects/mred/private/wx/cocoa/utils.rkt
View File

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

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

@ -9,7 +9,7 @@
"keycode.rkt"
"../common/event.rkt"
"../../syntax.rkt"
"freeze.rkt")
"../common/freeze.rkt")
(unsafe!)
(objc-unsafe!)

95
collects/mred/private/wx/common/freeze.rkt
View File

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

9
collects/mred/private/wx/common/utils.rkt
View File

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

2
collects/mred/private/wx/gtk/menu-bar.rkt
View File

@ -2,7 +2,7 @@
(require scheme/class
scheme/foreign
"../../syntax.rkt"
"../cocoa/freeze.rkt"
"../common/freeze.rkt"
"widget.rkt"
"utils.rkt"
"types.rkt")

7
collects/mred/private/wx/gtk/queue.rkt
View File

@ -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
(call-as-unfreeze-point
(lambda ()
(gtk_main_do_event evt)
(gdk_event_free evt)))))))))]
(gdk_event_free evt)))))))]
[else
(gtk_main_do_event evt)])))
(define (uninstall ignored)

2
collects/mred/private/wx/gtk/window.rkt
View File

@ -4,7 +4,7 @@
ffi/unsafe/atomic
"../../syntax.rkt"
"../common/event.rkt"
"../cocoa/freeze.rkt"
"../common/freeze.rkt"
"keycode.rkt"
"queue.rkt"
"utils.rkt"