scsh-0.6/scheme/rts/sleep.scm

62 lines
1.7 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Sleeping for N milliseconds.
(define (sleep user-n)
(let ((n (coerce-to-nonnegative-integer user-n)))
(cond ((not n)
(call-error "wrong type argument" sleep user-n))
((< 0 n)
(let ((queue (make-thread-queue))) ; only one entry, but it must be a queue
(disable-interrupts!)
(enqueue-thread! queue (current-thread))
(set! *dozers*
(insert (cons (+ (real-time) n)
queue)
*dozers*
(lambda (frob1 frob2)
(< (car frob1) (car frob2)))))
(block))))))
(define (coerce-to-nonnegative-integer n)
(if (real? n)
(let* ((n (round n))
(n (if (exact? n)
n
(inexact->exact n))))
(if (<= 0 n)
n
#f))
#f))
1999-09-14 08:45:02 -04:00
(define *dozers* '()) ; List of (wakeup-time . queue)
(define (insert x l <)
(cond ((null? l) (list x))
((< x (car l)) (cons x l))
(else (cons (car l) (insert x (cdr l) <)))))
; Called by root scheduler, so won't be interrupted.
; This returns two values, a boolean that indicates if any threads were
; woken and the time until the next sleeper wakes. We have to check for
; threads that have been started for some other reason.
(define (wake-some-threads)
(if (null? *dozers*)
(values #f #f)
(let ((time (real-time)))
(let loop ((dozers *dozers*) (woke? #f))
(if (null? dozers)
(begin
(set! *dozers* '())
(values woke? #f))
(let ((next (car dozers)))
(cond ((thread-queue-empty? (cdr next))
(loop (cdr dozers) woke?))
((< time (car next))
(set! *dozers* dozers)
(values woke? (- (car next) time)))
(else
(make-ready (dequeue-thread! (cdr next)))
(loop (cdr dozers) #t)))))))))