use ffi/unsafe/schedule instead of scheme_...

Author: mflatt

gui-lib/info.rkt

@@ -4,7 +4,7 @@
 
 (define deps '("srfi-lite-lib"
                "data-lib"
-               ["base" #:version "6.5.0.2"]
+               ["base" #:version "6.11.0.1"]
                "syntax-color-lib"
                ["draw-lib" #:version "1.13"]
                ["snip-lib" #:version "1.2"]

gui-lib/mred/private/wx/cocoa/gc.rkt

@@ -20,8 +20,10 @@
 
 (define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer))
 
-(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
-(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
+(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)
+  #:fail (lambda () void))
+(define-mz scheme_remove_gc_callback (_fun _racket -> _void)
+  #:fail (lambda () void))
 
 (define (make-gc-action-desc win sel val)
   (vector

gui-lib/mred/private/wx/cocoa/queue.rkt

@@ -1,6 +1,9 @@
 #lang racket/base
 (require ffi/unsafe/objc
          ffi/unsafe
+         ffi/unsafe/global
+         ffi/unsafe/schedule
+         ffi/unsafe/custodian
          racket/class
          racket/draw/private/dc
          "pool.rkt"
@@ -10,8 +13,7 @@
          "../common/queue.rkt"
          "../common/handlers.rkt"
          "../../lock.rkt"
-         "../common/freeze.rkt"
-         "../common/keep-forever.rkt")
+         "../common/freeze.rkt")
 
 (provide 
  (protect-out app
@@ -89,7 +91,7 @@
   [-a _void (applicationDidChangeScreenParameters: notification)
       ;; Screen changes sometimes make the event loop get stuck;
       ;; hack: schedule a wake-up call in 5 seconds
-      (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)])
+      (let ([priviledged-custodian (make-custodian-at-root)])
         (parameterize ([current-custodian priviledged-custodian])
           (thread (lambda () (sleep 5.0)))))
       (unless (version-10.10-or-later?)
@@ -116,7 +118,7 @@
                                            -> _OSStatus))
 (define NSApplicationActivationPolicyRegular 0)
 (define NSApplicationActivationPolicyAccessory 1)
-(unless (scheme_register_process_global "PLT_IS_FOREGROUND_APP" #f)
+(unless (register-process-global #"PLT_IS_FOREGROUND_APP" #f)
   (cond
    [(version-10.6-or-later?)
     ;; When a frame or root menu bar is created, we promote to
@@ -132,7 +134,7 @@
 (tellv app setDelegate: app-delegate)
 
 (define (bring-to-front)
-  (unless (scheme_register_process_global "Racket-GUI-no-front" #f)
+  (unless (register-process-global #"Racket-GUI-no-front" #f)
     (tellv app activateIgnoringOtherApps: #:type _BOOL #t)
     ;; It may not be that easy...
     (when (version-10.7-or-later?)
@@ -311,13 +313,12 @@
 (define-cf CFRunLoopAddObserver (_fun _pointer _pointer _pointer -> _void))
 (define-cf CFRunLoopGetMain (_fun -> _pointer))
 (define kCFRunLoopExit (arithmetic-shift 1 7))
-(define-mz scheme_signal_received (_fun -> _void))
 (define already-exited? #f)
 (define sleeping? #f)
 (define (exiting-run-loop x y z)
   (when sleeping?
     (if already-exited?
-        (scheme_signal_received)
+        (unsafe-signal-received)
         (set! already-exited? #t))))
 (let ([o (CFRunLoopObserverCreate #f kCFRunLoopExit #t 0 exiting-run-loop #f)])
   (CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes))
@@ -468,23 +469,15 @@
 ;; Install an alternate "sleep" function (in the Racket core)
 ;; that wakes up if any Cocoa event is ready.
 
-(define-mz scheme_start_sleeper_thread (_fun _fpointer _float _pointer _int -> _void))
-(define-mz scheme_end_sleeper_thread (_fun -> _void))
-
-(define-mz scheme_sleep _pointer)
-(define-mz scheme_set_place_sleep (_fun _pointer -> _void))
-
 ;; Called through an atomic callback:
-(define (sleep-until-event secs fds)
+(define (sleep-until-event)
   (set! sleeping? #t)
   (set! already-exited? #f)
-  (scheme_start_sleeper_thread scheme_sleep secs fds write_sock)
-  (check-one-event #t #f) ; blocks until an event is ready
-  (scheme_end_sleeper_thread)
+  ;; blocks until an event is ready, which can include a post from a
+  ;; background `sleep` thread that that triggers `write_sock`:
+  (check-one-event #t #f)
   (set! sleeping? #f))
 
 (define (cocoa-install-event-wakeup)
   (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it
-  (scheme_set_place_sleep (function-ptr sleep-until-event 
-                                        (_fun #:atomic? #t _float _gcpointer -> _void))))
-(keep-forever sleep-until-event)
+  (unsafe-set-sleep-in-thread! sleep-until-event write_sock))

gui-lib/mred/private/wx/common/once.rkt

@@ -1,14 +1,9 @@
 #lang racket/base
-(require ffi/unsafe)
-
-(provide (protect-out scheme_register_process_global))
+(require ffi/unsafe
+         ffi/unsafe/global)
 
 ;; This module must be instantiated only once:
-
-(define scheme_register_process_global
-  (get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer)))
-
-(let ([v (scheme_register_process_global "GRacket-support-initialized"
-                                         (cast 1 _scheme _pointer))])
+(let ([v (register-process-global #"GRacket-support-initialized"
+                                  (cast 1 _scheme _pointer))])
   (when v
     (error "cannot instantiate `racket/gui/base' a second time in the same process")))

gui-lib/mred/private/wx/common/queue.rkt

@@ -2,13 +2,14 @@
 (require ffi/unsafe
          racket/draw/private/utils
          ffi/unsafe/atomic
+         ffi/unsafe/custodian
+         ffi/unsafe/schedule
          racket/class
          racket/port
          "rbtree.rkt"
          "../../lock.rkt"
          "handlers.rkt"
-         "once.rkt"
-         "keep-forever.rkt")
+         "once.rkt")
 
 (provide 
  (protect-out queue-evt
@@ -61,40 +62,25 @@
 
               begin-busy-cursor
               end-busy-cursor
-              is-busy?)
-
- scheme_register_process_global)
+              is-busy?))
 
 ;; ------------------------------------------------------------
 ;; Create a Scheme evt that is ready when a queue is nonempty
 
-(define _Scheme_Type _short)
-(define-mz scheme_make_type (_fun _string -> _Scheme_Type))
-(define event-queue-type (scheme_make_type "event-queue"))
-
-(define-mz scheme_add_evt (_fun _Scheme_Type
-                                (_fun #:atomic? #t _scheme -> _int)
-                                (_fun #:atomic? #t _scheme _gcpointer -> _void)
-                                _pointer
-                                _int
-                                -> _void))
+(struct event-queue-evt ()
+  #:property prop:evt (unsafe-poller
+                       (lambda (self ctx)
+                         (cond
+                           [(do-check-queue)
+                            (values (list (void)) #f)]
+                           [else
+                            (do-queue-wakeup ctx)
+                            (values #f self)]))))
 
 (define (do-check-queue) #f)
 (define (do-queue-wakeup fds) #f)
 
-(define (check-queue o)
-  (if (do-check-queue) 1 0))
-(define (queue-wakeup o fds)
-  (do-queue-wakeup fds))
-(scheme_add_evt event-queue-type check-queue queue-wakeup #f 0)
-(keep-forever check-queue)
-(keep-forever queue-wakeup)
-(define queue-evt (let ([p (malloc 16)]
-                        [p2 (malloc 'nonatomic _pointer)])
-                    (memset p 0 16)
-                    (ptr-set! p _Scheme_Type event-queue-type)
-                    (ptr-set! p2 _pointer p)
-                    (ptr-ref p2 _scheme)))
+(define queue-evt (event-queue-evt))
 
 (define (set-check-queue! check)
   (set! do-check-queue check))
@@ -191,17 +177,7 @@
 ;;  isn't GCed
 (define active-eventspaces (make-hasheq))
 
-(define current-cb-box (make-parameter #f))
-
-(define-mz scheme_add_managed (_fun _racket ; custodian
-                                    _racket ; object
-                                    (_fun #:atomic? #t #:keep (lambda (v) (set-box! (current-cb-box) v))
-                                          _racket _racket -> _void)
-                                    _racket ; data
-                                    _int ; strong?
-                                    -> _gcpointer))
-
-(define (shutdown-eventspace! e ignored)
+(define (shutdown-eventspace! e)
   ;; atomic mode
   (unless (eventspace-shutdown? e)
     (set-eventspace-shutdown?! e #t)
@@ -366,12 +342,10 @@
                             (make-hash)
                             0)]
           [cb-box (box #f)])
-      (parameterize ([current-cb-box cb-box])
-        (scheme_add_managed (current-custodian) 
-                            e
-                            shutdown-eventspace!
-                            cb-box ; retain callback until it's called
-                            0))
+      (register-custodian-shutdown e
+                                   shutdown-eventspace!
+                                   (current-custodian)
+                                   #:weak? #t)
       e)))
 
 (define main-eventspace (make-eventspace* (current-thread)))

gui-lib/mred/private/wx/gtk/queue.rkt

@@ -1,6 +1,8 @@
 #lang racket/base
 (require racket/class
          ffi/unsafe
+         ffi/unsafe/global
+         ffi/unsafe/schedule
          "utils.rkt"
          "types.rkt"
          "../../lock.rkt"
@@ -39,10 +41,10 @@
 (define-gdk gdk_set_program_class (_fun _string -> _void))
 
 (define x11-display
-  (let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)]
+  (let* ([argc-ptr (register-process-global #"PLT_X11_ARGUMENT_COUNT" #f)]
          [argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)]
          [argv (and (positive? argc)
-                    (scheme_register_process_global "PLT_X11_ARGUMENTS" #f))]
+                    (register-process-global #"PLT_X11_ARGUMENTS" #f))]
          [display (getenv "DISPLAY")])
     ;; Convert X11 arguments, if any, to Gtk form:
     (let-values ([(args single-instance?)
@@ -86,7 +88,7 @@
                   (or display ":0"))))
         (when single-instance?
           (do-single-instance))
-        (let ([v (scheme_register_process_global "Racket-GUI-wm-class" #f)])
+        (let ([v (register-process-global #"Racket-GUI-wm-class" #f)])
           (when v
             (gdk_set_program_class (cast v _pointer _string))))
         display))))
@@ -144,12 +146,6 @@
 (define POLLERR #x8)
 (define POLLHUP #x10)
 
-(define-mz scheme_get_fdset (_fun _pointer _int -> _gcpointer))
-(define-mz scheme_fdset (_fun _gcpointer _int -> _void))
-(define-mz scheme_set_wakeup_time (_fun _gcpointer _double -> _void))
-(define-mz scheme_add_fd_eventmask (_fun _gcpointer _int -> _void)
-  #:fail #f)
-
 (define (install-wakeup fds)
   (let ([n (g_main_context_query (g_main_context_default)
                                  #x7FFFFFFF ; max-int, hopefully
@@ -158,7 +154,7 @@
                                  poll-fd-count)])
     (let ([to (ptr-ref timeout _int)])
       (when (to . >= . 0)
-        (scheme_set_wakeup_time fds (+ (current-inexact-milliseconds) to))))
+        (unsafe-poll-ctx-milliseconds-wakeup fds (+ (current-inexact-milliseconds) to))))
     (if (n . > . poll-fd-count)
         (begin
           (set! poll-fds (malloc _GPollFD n))
@@ -167,18 +163,18 @@
 	(if (eq? 'windows (system-type))
 	    ;; We don't know how to deal with GLib FDs under
 	    ;;  Windows, but we should wake up on any Windows event
-	    (scheme_add_fd_eventmask fds QS_ALLINPUT)
+	    (unsafe-poll-ctx-eventmask-wakeup fds QS_ALLINPUT)
 	    ;; Normal FD handling under Unix variants:
             (for ([i (in-range n)])
               (let* ([gfd (ptr-ref poll-fds _GPollFD i)]
                      [fd (GPollFD-fd gfd)]
                      [events (GPollFD-events gfd)])
                 (when (not (zero? (bitwise-and events POLLIN)))
-                  (scheme_fdset (scheme_get_fdset fds 0) fd))
+                  (unsafe-poll-ctx-fd-wakeup fds fd 'read))
                 (when (not (zero? (bitwise-and events POLLOUT)))
-                  (scheme_fdset (scheme_get_fdset fds 1) fd))
+                  (unsafe-poll-ctx-fd-wakeup fds fd 'write))
                 (when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP))))
-                  (scheme_fdset (scheme_get_fdset fds 2) fd))))))))
+                  (unsafe-poll-ctx-fd-wakeup fds fd 'error))))))))
 
 (set-check-queue! gtk_events_pending)
 (set-queue-wakeup! install-wakeup)

gui-lib/mred/private/wx/win32/queue.rkt

@@ -3,6 +3,7 @@
          racket/class
          ffi/unsafe/alloc
          ffi/unsafe/try-atomic
+         ffi/unsafe/schedule
          "utils.rkt"
          "types.rkt"
          "const.rkt"
@@ -36,8 +37,6 @@
 
 (define _enum_proc (_wfun _HWND _LPARAM -> _BOOL))
 
-(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void))
-
 (define free-msg
   ((deallocator)
    (lambda (msg) 
@@ -54,7 +53,7 @@
 
 (define (install-wakeup fds)
   (pre-event-sync #t)
-  (scheme_add_fd_eventmask fds QS_ALLINPUT))
+  (unsafe-poll-ctx-eventmask-wakeup fds QS_ALLINPUT))
 
 (set-check-queue! events-ready?)
 (set-queue-wakeup! install-wakeup)

gui-lib/mred/private/wx/win32/window.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require ffi/unsafe
+         ffi/unsafe/global
 	 racket/class
 	 racket/draw
 	 racket/draw/unsafe/bstr
@@ -110,10 +111,10 @@
 (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
 (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
 
-(define WM_IS_GRACKET (cast (scheme_register_process_global "PLT_WM_IS_GRACKET" #f)
+(define WM_IS_GRACKET (cast (register-process-global #"PLT_WM_IS_GRACKET" #f)
                             _pointer
                             _UINT_PTR))
-(define GRACKET_GUID (cast (scheme_register_process_global "PLT_GRACKET_GUID" #f)
+(define GRACKET_GUID (cast (register-process-global #"PLT_GRACKET_GUID" #f)
                            _pointer
                            _bytes))
 (define-cstruct _COPYDATASTRUCT