scsh-0.5/big/sleep.scm

102 lines
2.7 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; 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)))))))