fix constrained-reply to use delim continuations

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 
+      (constrained-reply (get-eventspace)
-       (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop))))))
+                         (lambda ()
-       200))
+                           (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)

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

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

@@ -10,8 +10,8 @@
          "window.rkt"
          "../common/event.rkt"
          "../common/queue.rkt"
-         "../../lock.rkt"
+         "../common/freeze.rkt"
-         "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 
+      (constrained-reply
-       (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop))))))
+       (send wx get-eventspace)
-       200)))
+       (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop))))
+       (void))))
 
 (defclass slider% item%
   (init parent cb

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
+(define-ffi-definer define-cocoa cocoa-lib)
-  (syntax-rules ()
+(define-ffi-definer define-cf cf-lib)
-    [(_ id type)
+(define-ffi-definer define-appserv appserv-lib)
-     (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 (objc-delete v)
   (tellv v release))

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

collects/mred/private/wx/common/freeze.rkt

@@ -1,45 +1,74 @@
 #lang scheme/base
 (require scheme/foreign
-         "../common/utils.rkt"
+         racket/draw/hold
-         "../common/queue.rkt")
+         "utils.rkt"
+         "queue.rkt"
+         "../../lock.rkt")
 (unsafe!)
 
-(provide call-with-frozen-stack
+(provide call-as-unfreeze-point
-         frozen-stack-run-some
          constrained-reply)
 
-(define-mz scheme_with_stack_freeze (_fun (_fun _scheme -> _int) _scheme -> _int))
+(define-mz scheme_abort_continuation_no_dws (_fun _scheme _scheme -> _scheme))
-(define-mz scheme_frozen_run_some (_fun (_fun _scheme -> _int) _scheme _int -> _int))
+(define-mz scheme_call_with_composable_no_dws (_fun _scheme _scheme -> _scheme))
-(define-mz scheme_is_in_frozen_stack (_fun -> _int))
+(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) 
+(define freezer-box (make-parameter #f))
-  ;; Continuation prompt ensures that errors do not escape
+(define freeze-tag (make-continuation-prompt-tag))
-  ;; (and escapes are not supported by the frozen-stack implementation)
-  (call-with-continuation-prompt p)
-  1)
 
-(define (call-with-frozen-stack thunk)
+;; Runs `thunk' atomically, but cooperates with 
-  (void (scheme_with_stack_freeze do-apply thunk)))
+;; `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)
+;; FIXME: waiting 200msec is not a good enough rule.
-  (positive? (scheme_frozen_run_some do-apply thunk msecs)))
+(define (constrained-reply es thunk default [should-give-up?
-
+                                             (let ([now (current-inexact-milliseconds)])
-;; FIXME: this loop needs to give up on the thunk
+                                               (lambda ()
-;;  if it takes too long to return; as long as we're in the
+                                                 ((current-inexact-milliseconds) . > . 200)))])
-;;  loop, no other threads/eventspaces can run
+  (unless (freezer-box)
-(define (constrained-reply es thunk default)
+    (log-error "internal error: constrained-reply not within an unfreeze point"))
   (if (eq? (current-thread) (eventspace-handler-thread es))
-      (let ([done? #f]
+      (let* ([prev #f]
-            [result default])
+             [ready? #f]
-        (frozen-stack-run-some (lambda () (set! result (thunk)))
+             [handler (lambda ()
-                               200)
+                        (when (and ready? (should-give-up?))
-        (let loop ()
+                          (scheme_call_with_composable_no_dws
-          (frozen-stack-run-some (lambda () (set! done? #t)) 200)
+                           (lambda (proc)
-          (unless done? (loop)))
+                             (set-box! (freezer-box) proc)
-        result)
+                             (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")
+        (log-error "internal error: wrong eventspace for constrained event handling\n")
-        (eprintf "~s\n" (continuation-mark-set->context (current-continuation-marks)))
         default)))
-
-

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

@@ -1,8 +1,7 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/foreign)
+(require ffi/unsafe
-(unsafe!)
+         ffi/unsafe/define)
 
 (provide define-mz)
 
-(define-syntax-rule (define-mz id type)
+(define-ffi-definer define-mz #f)
-  (define id (get-ffi-obj 'id #f type)))

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

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

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"