home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / SLEEP.SCM < prev    next >
Text File  |  1992-06-17  |  2KB  |  88 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; New, more efficient SLEEP  1/23/92
  5.  
  6. ; NYI: If there are no dozers to awake, and no runnable threads, and
  7. ; we're running under time sharing, we really ought to be polite and
  8. ; relinquish the processor to other processes by doing an appropriate
  9. ; system call (on unix, this means pause, sleep, or select).
  10.  
  11. (define (sleep n)
  12.   (let ((cv (make-condvar)))
  13.     (with-lock dozers-lock
  14.       (lambda ()
  15.     (set! *dozers*
  16.           (insert (cons (+ (time) n) cv)
  17.               *dozers*
  18.               (lambda (frob1 frob2)
  19.             (< (car frob1) (car frob2)))))
  20.     (if (not *wakeup-service*)
  21.         (set! *wakeup-service* (spawn wakeup-service 'wakeup-service)))))
  22.     (condvar-ref cv)))
  23.  
  24. (define dozers-lock (make-lock))
  25.  
  26. (define *dozers* '())  ;List of (wakeup-time . condvar)
  27.  
  28.  
  29. ; Wakeup service
  30.  
  31. (define *wakeup-service* #f)
  32.  
  33. (define (wakeup-service)
  34.   (dynamic-wind
  35.      relinquish-timeslice
  36.      (lambda ()
  37.        (let loop ()
  38.      (obtain-lock dozers-lock)
  39.      (if (not (null? *dozers*))
  40.          (begin (wake-up-some-threads)
  41.             (release-lock dozers-lock)
  42.             (relinquish-timeslice)
  43.             (loop)))))
  44.      (lambda ()
  45.        ;; If wakeup service gets killed, propagate kill to the threads
  46.        ;; it was going to wake up, so their unwind forms can run.
  47.        (for-each (lambda (dozer)
  48.            (kill-condvar (cdr dozer)))
  49.          *dozers*)
  50.        (set! *dozers* '())        ;in case of kill-thread
  51.        (set! *wakeup-service* #f)
  52.        (if (eq? (lock-owner dozers-lock) (current-thread))
  53.        (release-lock dozers-lock)))))
  54.  
  55. (define (wake-up-some-threads)
  56.   (if (null? *dozers*)
  57.       #f
  58.       (if (< (time) (car (car *dozers*)))
  59.       #f
  60.       (let ((cv (cdr (car *dozers*))))
  61.         (set! *dozers* (cdr *dozers*))
  62.         (condvar-set! cv #t)
  63.         (wake-up-some-threads)))))
  64.  
  65. (define (insert x l <)
  66.   (cond ((null? l) (list x))
  67.     ((< x (car l)) (cons x l))
  68.     (else (cons (car l) (insert x (cdr l) <)))))
  69.  
  70. ; Real time in seconds since some arbitrary origin.
  71. ; Number of ticks per second is given by (system-query 3).
  72.  
  73. (define (time)
  74.   (vm-extension 2 #f))  ; extension/get-real-time
  75.  
  76.  
  77.  
  78. ; Old version:
  79. ;(define (sleep n)
  80. ;  (let ((until (+ (time) n)))
  81. ;    (with-interrupts-inhibited
  82. ;      (let loop ()
  83. ;        (if (>= (time) until)
  84. ;            #t
  85. ;            (begin (dispatch)
  86. ;                   (loop)))))))
  87.  
  88.