scsh-0.6/scheme/rts/sleep.scm

; 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))

(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)))))))))