1#lang racket/base 2(require ffi/unsafe 3 racket/draw/private/utils 4 ffi/unsafe/atomic 5 ffi/unsafe/custodian 6 ffi/unsafe/schedule 7 racket/class 8 racket/port 9 "rbtree.rkt" 10 "../../lock.rkt" 11 "handlers.rkt" 12 "once.rkt") 13 14(provide 15 (protect-out queue-evt 16 set-check-queue! 17 set-queue-wakeup! 18 19 add-event-boundary-callback! 20 add-event-boundary-sometimes-callback! 21 remove-event-boundary-callback! 22 pre-event-sync 23 boundary-tasks-ready-evt 24 sometimes-delay-msec 25 set-platform-queue-sync! 26 27 eventspace? 28 current-eventspace 29 queue-event 30 queue-refresh-event 31 yield 32 yield/no-sync 33 yield-refresh 34 eventspace-event-evt 35 (rename-out [make-new-eventspace make-eventspace]) 36 37 event-dispatch-handler 38 eventspace-shutdown? 39 main-eventspace? 40 eventspace-handler-thread 41 eventspace-event-evt 42 eventspace-wait-cursor-count 43 eventspace-extra-table 44 eventspace-adjust-external-modal! 45 46 queue-callback 47 middle-queue-key 48 49 make-timer-callback 50 add-timer-callback 51 remove-timer-callback 52 53 register-frame-shown 54 get-top-level-windows 55 other-modal? 56 57 queue-quit-event 58 queue-prefs-event 59 queue-about-event 60 queue-file-event 61 queue-start-empty-event 62 63 begin-busy-cursor 64 end-busy-cursor 65 is-busy?)) 66 67;; ------------------------------------------------------------ 68;; Create a Scheme evt that is ready when a queue is nonempty 69 70(struct event-queue-evt () 71 #:property prop:evt (unsafe-poller 72 (lambda (self ctx) 73 (cond 74 [(do-check-queue) 75 (values (list (void)) #f)] 76 [else 77 (do-queue-wakeup ctx) 78 (values #f self)])))) 79 80(define (do-check-queue) #f) 81(define (do-queue-wakeup fds) #f) 82 83(define queue-evt (event-queue-evt)) 84 85(define (set-check-queue! check) 86 (set! do-check-queue check)) 87(define (set-queue-wakeup! wake) 88 (set! do-queue-wakeup wake)) 89 90;; ------------------------------------------------------------ 91;; Pre-event sync 92 93(define boundary-ht (make-hasheq)) 94(define sometimes-boundary-ht (make-hasheq)) 95 96(define tasks-ready? #f) 97(define task-ready-sema (make-semaphore)) 98(define boundary-tasks-ready-evt (semaphore-peek-evt task-ready-sema)) 99 100(define (alert-tasks-ready) 101 (let ([ready? (or (positive? (hash-count boundary-ht)) 102 (positive? (hash-count sometimes-boundary-ht)))]) 103 (unless (eq? ready? tasks-ready?) 104 (set! tasks-ready? ready?) 105 (if ready? 106 (semaphore-post task-ready-sema) 107 (semaphore-wait task-ready-sema))))) 108 109(define (add-event-boundary-callback! v proc) 110 (atomically 111 (hash-set! boundary-ht v proc) 112 (alert-tasks-ready))) 113(define (add-event-boundary-sometimes-callback! v proc) 114 (atomically 115 (when (zero? (hash-count sometimes-boundary-ht)) 116 (set! last-time (current-inexact-milliseconds))) 117 (hash-set! sometimes-boundary-ht v proc) 118 (alert-tasks-ready))) 119 120(define (remove-event-boundary-callback! v) 121 (atomically 122 (hash-remove! boundary-ht v) 123 (hash-remove! sometimes-boundary-ht v) 124 (alert-tasks-ready))) 125 126(define last-time -inf.0) 127(define sometimes-delay-msec 100) 128 129;; Call this function only in atomic mode: 130(define (pre-event-sync force?) 131 (let ([now (current-inexact-milliseconds)]) 132 (when (or (now . > . (+ last-time sometimes-delay-msec)) 133 force?) 134 (set! last-time now) 135 (hash-for-each/clear sometimes-boundary-ht (lambda (v p) (p v))))) 136 (hash-for-each/clear boundary-ht (lambda (v p) (p v))) 137 (alert-tasks-ready)) 138 139(define (hash-for-each/clear ht f) 140 (let ([l (hash-map ht cons)]) 141 (hash-clear! ht) 142 (for ([p (in-list l)]) 143 (f (car p) (cdr p))))) 144 145;; ------------------------------------------------------------ 146;; Eventspaces 147 148(define-struct eventspace (handler-thread 149 queue-proc 150 frames-hash 151 done-evt 152 [shutdown? #:mutable] 153 done-sema 154 [wait-cursor-count #:mutable] 155 extra-table 156 [external-modal #:mutable]) 157 #:property prop:evt (lambda (v) 158 (wrap-evt (eventspace-done-evt v) 159 (lambda (_) v)))) 160(define-struct timed (alarm-evt msecs val [id #:mutable])) 161 162(define (make-timer-callback msecs thunk) 163 (make-timed (alarm-evt msecs) 164 msecs 165 thunk 166 0)) 167 168(define (timed-compare a b) 169 (if (eq? a b) 170 0 171 (let ([am (timed-msecs a)] 172 [bm (timed-msecs b)]) 173 (cond 174 [(= am bm) (if ((timed-id a) . < . (timed-id b)) 175 -1 176 1)] 177 [(< am bm) -1] 178 [else 1])))) 179 180;; This table refers to handle threads of eventspaces 181;; that have an open window, etc., so that the eventspace 182;; isn't GCed 183(define active-eventspaces (make-hasheq)) 184 185(define (shutdown-eventspace! e) 186 ;; atomic mode 187 (unless (eventspace-shutdown? e) 188 (set-eventspace-shutdown?! e #t) 189 (semaphore-post (eventspace-done-sema e)) 190 (for ([f (in-list (get-top-level-windows e))]) 191 (send f destroy)) 192 (hash-remove! active-eventspaces (eventspace-handler-thread e)))) 193 194(define platform-queue-sync void) 195(define (set-platform-queue-sync! proc) 196 (set! platform-queue-sync proc)) 197 198(define (make-eventspace* th) 199 (let ([done-sema (make-semaphore 1)] 200 [done-set? #t] 201 [frames (make-hasheq)]) 202 (let ([e 203 (make-eventspace th 204 (let ([count 0]) 205 (let ([lo (mcons #f #f)] 206 [refresh (mcons #f #f)] 207 [med (mcons #f #f)] 208 [hi (mcons #f #f)] 209 [timer (box '())] 210 [timer-counter 0] 211 [newly-posted-sema (make-semaphore)]) 212 (let* ([check-done 213 (lambda () 214 (if (or (positive? count) 215 (positive? (hash-count frames)) 216 (not (null? (unbox timer)))) 217 (when done-set? 218 (hash-set! active-eventspaces th #t) 219 (set! done-set? #f) 220 (semaphore-try-wait? done-sema)) 221 (unless done-set? 222 (hash-remove! active-eventspaces th) 223 (set! done-set? #t) 224 (semaphore-post done-sema))))] 225 [enqueue (lambda (v q) 226 (set! count (add1 count)) 227 (check-done) 228 (let ([p (mcons v #f)]) 229 (if (mcdr q) 230 (set-mcdr! (mcdr q) p) 231 (set-mcar! q p)) 232 (set-mcdr! q p)))] 233 [first (lambda (q peek?) 234 (and (mcar q) 235 (if peek? 236 always-evt 237 (wrap-evt 238 always-evt 239 (lambda (_) 240 (start-atomic) 241 (set! count (sub1 count)) 242 (check-done) 243 (let ([result (mcar (mcar q))]) 244 (set-mcar! q (mcdr (mcar q))) 245 (unless (mcar q) 246 (set-mcdr! q #f)) 247 (end-atomic) 248 result))))))] 249 [remove-timer 250 (lambda (v timer) 251 (set-box! timer (rbtree-remove 252 timed-compare 253 v 254 (unbox timer))) 255 (check-done))] 256 [timer-first-ready 257 (lambda (timer peek?) 258 (let ([rb (unbox timer)]) 259 (and (not (null? rb)) 260 (let* ([v (rbtree-min (unbox timer))] 261 [evt (timed-alarm-evt v)]) 262 (and (sync/timeout 0 evt) 263 ;; It's ready 264 (if peek? 265 always-evt 266 (wrap-evt 267 always-evt 268 (lambda (_) 269 (start-atomic) 270 (remove-timer v timer) 271 (end-atomic) 272 (timed-val v)))))))))] 273 [timer-first-wait 274 (lambda (timer peek?) 275 (let ([rb (unbox timer)]) 276 (and (not (null? rb)) 277 (wrap-evt 278 (timed-alarm-evt (rbtree-min (unbox timer))) 279 (lambda (_) #f)))))] 280 [make-event-choice 281 (lambda (peek? sync?) 282 (choice-evt 283 (wrap-evt (semaphore-peek-evt newly-posted-sema) 284 (lambda (_) #f)) 285 (or (first hi peek?) 286 (timer-first-ready timer peek?) 287 (first refresh peek?) 288 (first med peek?) 289 (and (not peek?) 290 sync? 291 ;; before going with low-priority events, 292 ;; make sure we're sync'ed up with the 293 ;; GUI platform's event queue: 294 (platform-queue-sync) 295 (first med peek?)) 296 (first lo peek?) 297 (timer-first-wait timer peek?) 298 ;; nothing else ready... 299 never-evt)))]) 300 (case-lambda 301 [(v) 302 ;; Enqueue 303 (start-atomic) 304 (let ([val (cdr v)]) 305 (case (car v) 306 [(lo) (enqueue val lo)] 307 [(refresh) (enqueue val refresh)] 308 [(med) (enqueue val med)] 309 [(hi) (enqueue val hi)] 310 [(timer-add) 311 (set! timer-counter (add1 timer-counter)) 312 (set-timed-id! val timer-counter) 313 (set-box! timer 314 (rbtree-insert 315 timed-compare 316 val 317 (unbox timer))) 318 (check-done)] 319 [(timer-remove) (remove-timer val timer)] 320 [(frame-add) (hash-set! frames val #t) (check-done)] 321 [(frame-remove) (hash-remove! frames val) (check-done)])) 322 (semaphore-post newly-posted-sema) 323 (set! newly-posted-sema (make-semaphore)) 324 (check-done) 325 (end-atomic)] 326 [() 327 ;; Dequeue as evt 328 (start-atomic) 329 (begin0 330 (make-event-choice #f #t) 331 (end-atomic))] 332 [(only-refresh? peek? sync?) 333 (start-atomic) 334 (begin0 335 (cond 336 [only-refresh? 337 ;; Dequeue only refresh event 338 (or (first refresh peek?) never-evt)] 339 [else 340 (make-event-choice peek? sync?)]) 341 (end-atomic))])))) 342 frames 343 (semaphore-peek-evt done-sema) 344 #f 345 done-sema 346 0 347 (make-hash) 348 0)] 349 [cb-box (box #f)]) 350 (register-custodian-shutdown e 351 shutdown-eventspace! 352 (current-custodian) 353 #:weak? #t) 354 e))) 355 356(define main-eventspace (make-eventspace* (current-thread))) 357(define current-eventspace (make-parameter main-eventspace)) 358 359;; So we can get from a thread to the eventspace that 360;; it handles (independent of the `current-eventspace' 361;; parameter): 362(define handler-thread-of (make-thread-cell #f)) 363(thread-cell-set! handler-thread-of main-eventspace) 364 365(define make-new-eventspace 366 (let ([make-eventspace 367 (lambda (#:suspend-to-kill? [suspend-to-kill? #f]) 368 (define pause (make-semaphore)) 369 (define break-paramz (current-break-parameterization)) 370 (define (eventspace-handler-thread-proc) 371 (sync pause) ; wait until `es' has a value 372 (thread-cell-set! handler-thread-of es) 373 (current-eventspace es) 374 (let loop () 375 (call-with-continuation-prompt 376 (lambda () 377 ;; re-enable breaks (if they are supposed to be enabled): 378 (call-with-break-parameterization 379 break-paramz 380 (lambda () 381 ;; yield; any abort (including a break exception) 382 ;; will get caught and the loop will yield again 383 (yield (make-semaphore)))))) 384 (loop))) 385 (define es 386 (make-eventspace* 387 (parameterize-break 388 #f ; disable breaks until we're in the yield loop 389 (if suspend-to-kill? 390 (thread/suspend-to-kill eventspace-handler-thread-proc) 391 (thread eventspace-handler-thread-proc))))) 392 (semaphore-post pause) ; `es' has a value 393 es)]) 394 make-eventspace)) 395 396(define (queue-event eventspace thunk [level 'med]) 397 ((eventspace-queue-proc eventspace) (cons level thunk))) 398 399(define (queue-refresh-event eventspace thunk) 400 ((eventspace-queue-proc eventspace) (cons 'refresh thunk))) 401 402(define dispatch-event-prompt (make-continuation-prompt-tag)) 403(define dispatch-event-key (gensym)) 404 405(define (really-dispatch-event e) 406 (let ([b (continuation-mark-set-first 407 #f 408 dispatch-event-key 409 #f 410 dispatch-event-prompt)]) 411 (unless b 412 (error 'default-event-dispatch-handler 413 "not in an event-dispatch context")) 414 (let ([thunk (atomically 415 (begin0 416 (unbox b) 417 (set-box! b #f)))]) 418 (unless thunk 419 (error 'default-event-dispatch-handler 420 "event in current context was already dispatched")) 421 (thunk)))) 422 423(define event-dispatch-handler (make-parameter really-dispatch-event)) 424 425(define event-logger (make-logger 'gui-event (current-logger))) 426;; start? : boolean -- indicates if this is a start of an event being handled or not 427;; msec : start time if start? is #t, delta from start to end if start? is #f 428;; name : (or/c #f symbol?) 429(struct gui-event (start end name) #:prefab) 430 431(define (handle-event thunk e) 432 (call-with-continuation-prompt ; to delimit continuations 433 (lambda () 434 (call-with-continuation-prompt ; to delimit search for dispatch-event-key 435 (lambda () 436 ;; communicate the thunk to `really-dispatch-event': 437 (define before (current-inexact-milliseconds)) 438 (when (log-level? event-logger 'debug) 439 (log-message event-logger 'debug 440 (format "starting to handle an event from ~a" (object-name thunk)) 441 (gui-event before #f (object-name thunk)))) 442 (let ([b (box thunk)]) 443 ;; use the event-dispatch handler: 444 (with-continuation-mark dispatch-event-key b 445 ((event-dispatch-handler) e)) 446 ;; if the event-dispatch handler doesn't chain 447 ;; to the original one, then do so now: 448 (when (unbox b) 449 (set-box! b #f) 450 (thunk))) 451 (define after (current-inexact-milliseconds)) 452 (when (log-level? event-logger 'debug) 453 (log-message event-logger 'debug 454 (format "handled an event: ~a msec" 455 (- after before)) 456 (gui-event before after (object-name thunk))))) 457 dispatch-event-prompt)))) 458 459(define yield 460 (case-lambda 461 [() 462 (let ([e (current-eventspace)]) 463 (if (eq? (current-thread) (eventspace-handler-thread e)) 464 (let ([v (sync/timeout 0 ((eventspace-queue-proc e)))]) 465 (if v 466 (begin (handle-event v e) #t) 467 #f)) 468 #f))] 469 [(evt) 470 (unless (or (evt? evt) 471 (eq? evt 'wait)) 472 (raise-type-error 'yield "evt or 'wait" evt)) 473 (let* ([e (current-eventspace)] 474 [handler? (eq? (current-thread) (eventspace-handler-thread e))]) 475 (cond 476 [(and (eq? evt 'wait) 477 (not handler?)) 478 #t] 479 [else 480 (define (wait-now) 481 (if handler? 482 (sync (if (eq? evt 'wait) 483 (wrap-evt e (lambda (_) #t)) 484 evt) 485 (handle-evt ((eventspace-queue-proc e)) 486 (lambda (v) 487 (when v (handle-event v e)) 488 (yield evt)))) 489 (sync evt))) 490 (if (evt? evt) 491 ;; `yield' is supposed to return immediately if the 492 ;; event is already ready: 493 (sync/timeout wait-now evt) 494 (wait-now))]))])) 495 496(define (yield/no-sync) 497 (let ([e (current-eventspace)]) 498 (when (eq? (current-thread) (eventspace-handler-thread e)) 499 (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f #f))]) 500 (if v 501 (begin (handle-event v e) #t) 502 #f))))) 503 504(define yield-refresh 505 (lambda () 506 (let ([e (current-eventspace)]) 507 (and (eq? (current-thread) (eventspace-handler-thread e)) 508 (let loop ([result #f]) 509 (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #t #f #t))]) 510 (if v 511 (begin 512 (handle-event v e) 513 (loop #t)) 514 result))))))) 515 516(define (eventspace-event-evt [e (current-eventspace)]) 517 (unless (eventspace? e) 518 (raise-type-error 'eventspace-event-evt "eventspace" e)) 519 (wrap-evt ((eventspace-queue-proc e) #f #t #t) 520 (lambda (_) e))) 521 522(define (main-eventspace? e) 523 (eq? e main-eventspace)) 524 525(define (queue-callback thunk [high? #t]) 526 (let ([es (current-eventspace)]) 527 (when (eventspace-shutdown? es) 528 (error 'queue-callback "eventspace is shutdown: ~e" es)) 529 (queue-event es thunk (cond 530 [(not high?) 'lo] 531 [(eq? high? middle-queue-key) 'med] 532 [else 'hi])))) 533 534(define middle-queue-key (gensym 'middle)) 535 536 537(define (add-timer-callback cb es) 538 ;; in atomic mode 539 (queue-event es cb 'timer-add)) 540(define (remove-timer-callback cb es) 541 ;; in atomic mode 542 (unless (eventspace-shutdown? es) 543 (queue-event es cb 'timer-remove))) 544 545(define (register-frame-shown f on?) 546 (queue-event (send f get-eventspace) f (if on? 547 'frame-add 548 'frame-remove))) 549 550(define (get-top-level-windows [e (current-eventspace)]) 551 ;; called in event-pump thread 552 (hash-map (eventspace-frames-hash e) 553 (lambda (k v) k))) 554 555(define (other-modal? win [e #f] [ignore-win #f]) 556 ;; called in atomic mode in eventspace's thread 557 (and 558 ;; deliver mouse-motion events even if a modal window 559 ;; is open 560 (or (not e) 561 (not (or (send e leaving?) 562 (send e entering?) 563 (send e moving?)))) 564 ;; for any other kind of mouse or key event, deliver only 565 ;; if no model dialog is open 566 (let ([es (send win get-eventspace)]) 567 (or (positive? (eventspace-external-modal es)) 568 (let loop ([frames (get-top-level-windows es)]) 569 (and (pair? frames) 570 (let ([status (if (eq? ignore-win (car frames)) 571 #f 572 (send (car frames) frame-relative-dialog-status win))]) 573 (case status 574 [(#f) (loop (cdr frames))] 575 [(same) (loop (cdr frames))] 576 [(other) #t])))))))) 577 578(define (eventspace-adjust-external-modal! es amt) 579 (atomically 580 (set-eventspace-external-modal! 581 es 582 (+ (eventspace-external-modal es) amt)))) 583 584(define (queue-quit-event) 585 ;; called in event-pump thread 586 (queue-event main-eventspace (application-quit-handler) 'med)) 587 588(define (queue-prefs-event) 589 ;; called in event-pump thread 590 (queue-event main-eventspace (application-pref-handler) 'med)) 591 592(define (queue-about-event) 593 ;; called in event-pump thread 594 (queue-event main-eventspace (application-about-handler) 'med)) 595 596(define (queue-file-event file) 597 ;; called in event-pump thread 598 (queue-event main-eventspace (lambda () 599 ((application-file-handler) file)) 600 'med)) 601 602(define (queue-start-empty-event) 603 ;; called in event-pump thread 604 (queue-event main-eventspace (application-start-empty-handler) 605 'med)) 606 607(define (begin-busy-cursor) 608 (let ([e (current-eventspace)]) 609 (atomically 610 (set-eventspace-wait-cursor-count! 611 e 612 (add1 (eventspace-wait-cursor-count e))) 613 (when (= (eventspace-wait-cursor-count e) 1) 614 (for ([e (in-list (get-top-level-windows))]) 615 (send e set-wait-cursor-mode #t)))))) 616 617(define (end-busy-cursor) 618 (let ([e (current-eventspace)]) 619 (atomically 620 (set-eventspace-wait-cursor-count! 621 e 622 (sub1 (eventspace-wait-cursor-count e))) 623 (when (zero? (eventspace-wait-cursor-count e)) 624 (for ([e (in-list (get-top-level-windows))]) 625 (send e set-wait-cursor-mode #f)))))) 626 627(define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace)))) 628 629;; ---------------------------------------- 630 631;; Before exiting, wait until frames are closed, etc.: 632(executable-yield-handler 633 (let ([old-eyh (executable-yield-handler)]) 634 (lambda (v) 635 (yield main-eventspace) 636 (old-eyh v)))) 637 638;; When using a REPL in a thread that has an eventspace, 639;; yield to events when the port would block. 640(current-get-interaction-input-port 641 (let ([orig (current-get-interaction-input-port)]) 642 (lambda () 643 (let ([e (thread-cell-ref handler-thread-of)]) 644 (if e 645 (let ([filter (lambda (v) 646 (cond 647 [(eq? v 0) (yield) 0] 648 [(evt? v) 649 (parameterize ([current-eventspace e]) 650 (yield)) 651 (choice-evt v 652 (wrap-evt (eventspace-event-evt e) 653 (lambda (_) 0)))] 654 [else v]))]) 655 (filter-read-input-port 656 (orig) 657 (lambda (str v) 658 (filter v)) 659 (lambda (s skip evt v) 660 (filter v)))) 661 (orig)))))) 662