1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Suresh Jagannathan,
4; Henry Ceijtin
5
6; A parameterized scheduler.
7
8; (run-threads event-handler) -> unspecific
9;   (event-handler thread time-left event event-data) -> [thread args time]
10; A bogus BLOCKED event is passed to the handler to get the initial thread.
11
12(define (run-threads event-handler)
13  (call-with-values
14   (lambda ()
15     (event-handler #f 0 (enum event-type blocked) '()))
16   (lambda (thread time)
17     (if thread
18	 (let loop ((thread thread) (time time))
19	   (call-with-values
20	    (lambda ()
21	      (run thread time))
22	    (lambda (time-left event . event-data)
23	      (call-with-values
24	       (lambda ()
25		 (event-handler thread time-left event event-data))
26	       (lambda (thread time)
27		 (if thread
28		     (loop thread time)))))))))))
29
30; Same thing, with the addition of a housekeeping thunk that gets
31; run periodically.
32
33(define (run-threads-with-housekeeper event-handler housekeeper delay)
34  (call-with-values
35   (lambda ()
36     (event-handler #f 0 (enum event-type blocked) '()))
37   (lambda (thread time)
38     (if thread
39	 (let loop ((thread thread) (time time) (hk-time delay))
40	   (call-with-values
41	    (lambda ()
42	      (run thread time))
43	    (lambda (time-left event . event-data)
44	      (let ((hk-time (let ((temp (- hk-time (- time time-left))))
45			       (if (<= temp 0)
46				   (begin
47				     (housekeeper)
48				     delay)
49				   temp))))
50		(call-with-values
51		 (lambda ()
52		   (event-handler thread time-left event event-data))
53		 (lambda (thread time)
54		   (if thread
55		       (loop thread time hk-time))))))))))))
56
57; An event-handler that does round-robin scheduling.
58; Arguments:
59;    runnable         ; queue of threads
60;    quantum          ; number of ticks each thread gets
61;    dynamic-env      ; initial dynamic environments for new threads
62;    thread-count     ; counter tracking the number of threads
63;    event-handler : event-type event-data -> handled?
64;    upcall-handler : thread token . args -> return-values
65;    wait             ; thunk returns #t if scheduling is to continue
66
67(define (round-robin-event-handler runnable quantum dynamic-env thread-count
68				   event-handler upcall-handler wait)
69
70  (define (thread-event-handler thread time-left event event-data)
71    (enum-case event-type event
72
73      ;; the thread stops, either temporarily or permanently
74      ((blocked)
75       (next-thread))
76      ((completed killed)
77       (decrement-counter! thread-count)
78       (next-thread))
79      ((out-of-time)
80       (enqueue! runnable thread)
81       (next-thread))
82
83      ;; the thread keeps running
84      ((upcall)
85       (call-with-values
86	(lambda ()
87	  (apply upcall-handler event-data))
88	(lambda results
89	  (set-thread-arguments! thread results)
90	  (values thread time-left))))
91      (else
92       (asynchronous-event-handler event event-data)
93       (values thread time-left))))
94
95  ;; We call EVENT-HANDLER first so that it can override the default behavior
96  (define (asynchronous-event-handler event event-data)
97    (or (event-handler event event-data)
98	(enum-case event-type event
99	  ((runnable)
100	   (enqueue! runnable (car event-data)))
101	  ((spawned)
102	   (increment-counter! thread-count)
103	   (let ((thread (car event-data)))
104	     (set-thread-dynamic-env! thread dynamic-env)
105	     (set-thread-scheduler! thread (current-thread))
106	     (enqueue! runnable thread)))
107	  ((no-event)
108	   (values))
109	  (else
110	   (assertion-violation 'asynchronous-event-handler "unhandled event"
111				(cons (enumerand->name event event-type)
112				      event-data)
113				event-handler)))))
114
115  (define (next-thread)
116    (if (queue-empty? runnable)
117	(call-with-values
118	  get-next-event!
119	  (lambda (event . data)
120	    (cond ((not (eq? event (enum event-type no-event)))
121		   (asynchronous-event-handler event data)
122		   (next-thread))
123		  ((wait)
124		   (next-thread))
125		  (else
126		   (values #f 0)))))
127	(values (dequeue! runnable)
128		quantum)))
129
130  thread-event-handler)
131
132; Simple counting cell
133
134(define (make-counter)
135  (list 0))
136
137(define counter-value car)
138
139(define (increment-counter! count)
140  (set-car! count (+ 1 (car count))))
141
142(define (decrement-counter! count)
143  (set-car! count (- (car count) 1)))
144
145(define (set-counter! count val)
146  (set-car! count val))
147