80 lines
2.5 KiB
Scheme
80 lines
2.5 KiB
Scheme
|
; Copyright (c) 1999-2001 by Martin Gasbichler. See file COPYING.
|
||
|
|
|
||
|
|
;;; Functional event system.
|
||
|
|
;;; System by Olin Shivers, implementation by Martin Gasbichler
|
||
|
|
|
||
|
|
(define-record-type event :event
|
||
|
|
(really-make-event type next)
|
||
|
|
event?
|
||
|
|
(type event-type set-event-type!)
|
||
|
|
(next next-event set-next-event!))
|
||
|
|
|
||
|
|
(define (make-event type)
|
||
|
|
(really-make-event type #f))
|
||
|
|
|
||
|
|
(define empty-event (make-event #f))
|
||
|
|
|
||
|
|
(define *most-recent-event* empty-event)
|
||
|
|
|
||
|
|
(define (most-recent-event) *most-recent-event*)
|
||
|
|
|
||
|
|
(define event-thread-queue #f)
|
||
|
|
|
||
|
|
;Wait for an event of a certain type.
|
||
|
|
(define (rts-wait-interrupt set pre-event type-in-set?)
|
||
|
|
(with-interrupts-inhibited
|
||
|
|
(lambda ()
|
||
|
|
(let lp ((event (next-event pre-event)))
|
||
|
|
(if event
|
||
|
|
(if (type-in-set? (event-type event) set)
|
||
|
|
event
|
||
|
|
(lp (next-event event)))
|
||
|
|
(begin (enqueue-thread! event-thread-queue (current-thread))
|
||
|
|
(block)
|
||
|
|
(lp (next-event pre-event))))))))
|
||
|
|
|
||
|
|
; same as above, but don't block
|
||
|
|
(define (rts-maybe-wait-interrupt set pre-event type-in-set?)
|
||
|
|
(let ((event (next-event pre-event)))
|
||
|
|
(if event
|
||
|
|
(if (type-in-set? (event-type event) set)
|
||
|
|
event
|
||
|
|
(rts-maybe-wait-interrupt set (next-event event) type-in-set?))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
|
||
|
|
;Called when the interrupt actually happened.
|
||
|
|
;;; TODO w-i-i is problaly not necessary since they're off already
|
||
|
|
(define (register-interrupt type)
|
||
|
|
(let ((waiters (with-interrupts-inhibited
|
||
|
|
(lambda ()
|
||
|
|
(set-next-event! *most-recent-event* (make-event type))
|
||
|
|
(set! *most-recent-event* (next-event *most-recent-event*))
|
||
|
|
(do ((waiters '() (cons (dequeue-thread! event-thread-queue)
|
||
|
|
waiters)))
|
||
|
|
((thread-queue-empty? event-thread-queue)
|
||
|
|
waiters))))))
|
||
|
|
(for-each make-ready waiters)))
|
||
|
|
|
||
|
|
;;; has to be called with interrupts disabled
|
||
|
|
(define (waiting-for-os-event?)
|
||
|
|
(not (thread-queue-empty? event-thread-queue)))
|
||
|
|
|
||
|
|
(define (initialize-events!)
|
||
|
|
(set! event-thread-queue (make-thread-queue))
|
||
|
|
(set-interrupt-handler! (enum interrupt os-signal)
|
||
|
|
(lambda (type arg enabled-interrupts)
|
||
|
|
; type is already set in the unix signal handler
|
||
|
|
(register-interrupt type)))
|
||
|
|
(set-interrupt-handler! (enum interrupt keyboard)
|
||
|
|
(lambda (enabled-interrupts)
|
||
|
|
(register-interrupt (enum interrupt keyboard))))
|
||
|
|
; (call-after-gc! (lambda () (register-interrupt (enum interrupt post-gc))))
|
||
|
|
)
|
||
|
|
;;; the vm uses the timer for the scheduler
|
||
|
|
(define (schedule-timer-interrupt! msec)
|
||
|
|
(spawn (lambda ()
|
||
|
|
(sleep msec)
|
||
|
|
(register-interrupt (enum interrupt alarm)))))
|
||
|
|
|