1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Robert Ransom
; Sleeping for N milliseconds.
(define (sleep user-n)
(let ((n (coerce-to-nonnegative-integer user-n)))
(cond ((not n)
(assertion-violation 'sleep "wrong type argument" user-n))
((< 0 n)
(let ((cell (make-cell (current-thread))))
(disable-interrupts!)
(set-thread-cell! (current-thread) cell)
(register-dozer-unsafe! (+ (real-time) n)
(lambda ()
(and (cell-ref cell)
#t))
(lambda ()
(make-ready (cell-ref cell))))
(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))
; We insert a pair consisting of a wakeup time and another pair.
; The second pair contains two thunks; the first one checks if the
; dozer is still alive, the second wakes it up.
(define (register-dozer-unsafe! wakeup-time alive? wakeup!)
(session-data-set! dozers
(insert (cons wakeup-time
(cons alive? wakeup!))
(session-data-ref dozers)
(lambda (frob1 frob2)
(< (car frob1)
(car frob2))))))
; Note that, if ALIVE? or WAKEUP! isn't a thunk or doesn't run without
; problems, there'll be hell to pay upon wakeup.
(define (register-dozer! user-wakeup-time alive? wakeup!)
(let ((wakeup-time (coerce-to-nonnegative-integer user-wakeup-time)))
(cond ((not wakeup-time)
(assertion-violation 'register-dozer! "wrong type argument" user-wakeup-time))
(else
(let ((ints (set-enabled-interrupts! 0)))
(register-dozer-unsafe! wakeup-time alive? wakeup!)
(set-enabled-interrupts! ints))))))
(define dozers (make-session-data-slot! '()))
(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? (session-data-ref dozers))
(values #f #f)
(let ((time (real-time)))
(let loop ((to-do (session-data-ref dozers)) (woke? #f))
(if (null? to-do)
(begin
(session-data-set! dozers '())
(values woke? #f))
(let* ((next (car to-do))
(alive? (cadr next)))
(cond
((not (alive?))
(loop (cdr to-do) woke?))
((< time (car next))
(session-data-set! dozers to-do)
(values woke? (- (car next) time)))
(else
((cddr next))
(loop (cdr to-do) #t)))))))))
|
