102 lines
2.7 KiB
Scheme
102 lines
2.7 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; New, more efficient SLEEP 1/23/92
|
|
|
|
; Earlier, simpler (and probably better) version:
|
|
;(define (sleep n)
|
|
; (let ((until (+ (time) n)))
|
|
; (with-interrupts-inhibited
|
|
; (lambda ()
|
|
; (let loop ()
|
|
; (if (>= (time) until)
|
|
; #t
|
|
; (begin (dispatch)
|
|
; (loop))))))))
|
|
|
|
; NYI: If there are no dozers to awake, and no runnable threads, and
|
|
; we're running under time sharing, we really ought to be polite and
|
|
; relinquish the processor to other processes by doing an appropriate
|
|
; system call (on unix, this means pause, sleep, or select).
|
|
|
|
(define (sleep n)
|
|
(let ((cv (make-condvar)))
|
|
(with-lock dozers-lock
|
|
(lambda ()
|
|
(set! *dozers*
|
|
(insert (cons (+ (time) n) cv)
|
|
*dozers*
|
|
(lambda (frob1 frob2)
|
|
(< (car frob1) (car frob2)))))
|
|
(if (not *wakeup-service*)
|
|
(set! *wakeup-service* (spawn wakeup-service 'wakeup-service)))))
|
|
(condvar-ref cv)))
|
|
|
|
(define dozers-lock (make-lock))
|
|
|
|
(define *dozers* '()) ;List of (wakeup-time . condvar)
|
|
|
|
|
|
; Wakeup service
|
|
|
|
(define *wakeup-service* #f)
|
|
|
|
(define (wakeup-service)
|
|
(dynamic-wind
|
|
relinquish-timeslice
|
|
(lambda ()
|
|
(let loop ()
|
|
(obtain-lock dozers-lock)
|
|
(if (not (null? *dozers*))
|
|
(begin (wake-up-some-threads)
|
|
(release-lock dozers-lock)
|
|
(relinquish-timeslice)
|
|
(loop)))))
|
|
(lambda ()
|
|
;; If wakeup service gets killed, propagate kill to the threads
|
|
;; it was going to wake up, so their unwind forms can run.
|
|
(for-each (lambda (dozer)
|
|
(kill-condvar (cdr dozer)))
|
|
*dozers*)
|
|
(set! *dozers* '()) ;in case of kill-thread
|
|
(set! *wakeup-service* #f)
|
|
(if (eq? (lock-owner dozers-lock) (current-thread))
|
|
(release-lock dozers-lock)))))
|
|
|
|
(define (wake-up-some-threads)
|
|
(if (null? *dozers*)
|
|
#f
|
|
(if (< (time) (car (car *dozers*)))
|
|
#f
|
|
(let ((cv (cdr (car *dozers*))))
|
|
(set! *dozers* (cdr *dozers*))
|
|
(condvar-set! cv #t)
|
|
(wake-up-some-threads)))))
|
|
|
|
(define (insert x l <)
|
|
(cond ((null? l) (list x))
|
|
((< x (car l)) (cons x l))
|
|
(else (cons (car l) (insert x (cdr l) <)))))
|
|
|
|
; Real time in seconds since some arbitrary origin.
|
|
|
|
(define (time)
|
|
(primitive-time time-option/real-time #f))
|
|
(define primitive-time (structure-ref primitives time))
|
|
|
|
(define time-option/real-time (enum time-option real-time))
|
|
|
|
|
|
|
|
(define (read-char-with-timeout port t)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(let ((deadline (+ (time) t)))
|
|
(let loop ()
|
|
(cond ((char-ready? port)
|
|
(read-char port))
|
|
((< (time) deadline)
|
|
(dispatch)
|
|
(loop))
|
|
(else 'timeout)))))))
|