95 lines
2.8 KiB
Scheme
95 lines
2.8 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 sigevent :sigevent
|
||
|
|
(really-make-sigevent type next)
|
||
|
|
sigevent?
|
||
|
|
(type sigevent-type set-sigevent-type!)
|
||
|
|
(next sigevent-next set-sigevent-next!))
|
||
|
|
|
||
|
|
(define (make-sigevent type)
|
||
|
|
(really-make-sigevent type #f))
|
||
|
|
|
||
|
|
(define empty-sigevent (make-sigevent #f))
|
||
|
|
|
||
|
|
(define *most-recent-sigevent* empty-sigevent)
|
||
|
|
|
||
|
|
(define (most-recent-sigevent) *most-recent-sigevent*)
|
||
|
|
|
||
|
|
(define sigevent-thread-queue #f)
|
||
|
|
|
||
|
|
;Wait for an sigevent of a certain type.
|
||
|
|
(define (rts-next-sigevent pre-sigevent set type-in-set?)
|
||
|
|
(with-interrupts-inhibited
|
||
|
|
(lambda ()
|
||
|
|
(let lp ((pre-sigevent pre-sigevent))
|
||
|
|
(let ((sigevent (sigevent-next pre-sigevent)))
|
||
|
|
(if sigevent
|
||
|
|
(if (type-in-set? (sigevent-type sigevent) set)
|
||
|
|
sigevent
|
||
|
|
(lp sigevent))
|
||
|
|
(begin (block-on-queue sigevent-thread-queue)
|
||
|
|
(lp pre-sigevent))))))))
|
||
|
|
|
||
|
|
; same as above, but don't block
|
||
|
|
(define (rts-next-sigevent/no-wait pre-sigevent set type-in-set?)
|
||
|
|
(let ((sigevent (sigevent-next pre-sigevent)))
|
||
|
|
(if sigevent
|
||
|
|
(if (type-in-set? (sigevent-type sigevent) set)
|
||
|
|
sigevent
|
||
|
|
(rts-next-sigevent/no-wait (sigevent-next sigevent)
|
||
|
|
set
|
||
|
|
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-sigevent-next! *most-recent-sigevent* (make-sigevent type))
|
||
|
|
(set! *most-recent-sigevent* (sigevent-next *most-recent-sigevent*))
|
||
|
|
(do ((waiters '() (cons (maybe-dequeue-thread! sigevent-thread-queue)
|
||
|
|
waiters)))
|
||
|
|
((thread-queue-empty? sigevent-thread-queue)
|
||
|
|
waiters))))))
|
||
|
|
(for-each make-ready waiters)))
|
||
|
|
|
||
|
|
|
||
|
|
;;; Records whether the sigevent system is running.
|
||
|
|
;;; If set to #f we ignore threads waiting for a sigevent.
|
||
|
|
(define sigevents-running? #f)
|
||
|
|
|
||
|
|
;;; has to be called with interrupts disabled
|
||
|
|
(define (waiting-for-sigevent?)
|
||
|
|
(if sigevents-running?
|
||
|
|
(not (thread-queue-empty? sigevent-thread-queue))
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(define (with-sigevents thunk)
|
||
|
|
(set! sigevent-thread-queue (make-queue))
|
||
|
|
(set-interrupt-handler! (enum interrupt os-signal)
|
||
|
|
(lambda (type 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))))
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda ()
|
||
|
|
(set! sigevents-running? #t))
|
||
|
|
thunk
|
||
|
|
(lambda ()
|
||
|
|
(set! sigevents-running? #f))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; the vm uses the timer for the scheduler
|
||
|
|
(define (schedule-timer-interrupt! msec)
|
||
|
|
(spawn (lambda ()
|
||
|
|
(sleep msec)
|
||
|
|
(register-interrupt (enum interrupt alarm)))))
|
||
|
|
|