source: project/release/4/thread-utils/trunk/thread-reaper.scm @ 35444

Last change on this file since 35444 was 35444, checked in by Kon Lovett, 3 years ago

re-flow, use ->boolean, thread is pre-defined type

File size: 8.4 KB
Line 
1;;;; thread-reaper.scm
2;;;; Kon Lovett, Oct '09
3
4;; Issues
5;;
6;; - What's up w/ thread-yield!
7;;
8;; - Could allow the stopping of an existing reaper and the startup of another.
9;; Make '+stopping?+' thread thunk local w/ a set/get behavior.
10
11; Used by threads that are cleanly terminating and wish to 'join' the
12; primordial thread w/o any user intervention. (A thread that attempts
13; to 'join' itself will cause a deadlock.)
14;
15; The "reaped" thread's end-exception, if any, is printed as a warning.
16;
17; The reaper can be stopped at any time
18
19(module thread-reaper
20
21(;export
22  thread-reaper-shutdown?
23  thread-reap!
24  thread-reaper-stop!
25  ;
26  thread-reaper-greedy thread-reaper-greedy-set!
27  thread-reaper-quantum thread-reaper-quantum-set!
28  thread-reaper-wait-seconds thread-reaper-wait-seconds-set!
29  thread-reaper-timeout thread-reaper-timeout-set!
30  thread-reaper-retries thread-reaper-retries-set!)
31
32(import scheme chicken)
33(use
34  (only data-structures
35    queue-empty? queue-remove! make-queue queue-add! queue->list)
36  (only srfi-18
37    thread-name thread-sleep!
38    thread-join! thread-yield! thread-start! make-thread
39    thread-quantum-set! thread-quantum
40    terminated-thread-exception? uncaught-exception?)
41  (only miscmacros until)
42  (only synch
43    make-object/synch synch-with %synch-with)
44  (only record-variants
45    define-record-type-variant)
46  (only thread-utils
47    check-thread print-exception-warning)
48  (only type-checks
49    check-positive-number check-natural-fixnum))
50
51;;
52
53(define (->boolean x)
54  (and x #t) )
55
56;;
57
58;modes: normal & stopping (during reaper termination)
59
60(define-constant DEFAULT-REAPER-WAIT-SECONDS 1.0) ;reaper wait time
61
62(define-constant DEFAULT-REAPER-QUANTUM 10)     ;reaper thread normal
63(define-constant STOPPING-REAPER-QUANTUM 100)
64
65(define-constant DEFAULT-REAPER-TIMEOUT #f)     ;reaped thread join wait
66(define-constant STOPPING-REAPER-TIMEOUT 1.0)
67
68(define-constant DEFAULT-REAPER-RETRIES 1)      ;reaped thread reap retries
69(define-constant STOPPING-REAPER-RETRIES 0)
70
71;;
72
73;Local to this module
74(define-record-type-variant reap-item (unsafe unchecked inline)
75  (make-reap-item th to rt)
76  reap-item?
77  (th reap-item-thread)
78  (to reap-item-timeout set-reap-item-timeout!)
79  (rt reap-item-retries set-reap-item-retries!) )
80
81;;
82
83(define REAP-TIMED-OUT '#(reap-timedout))
84
85(define (reap-queue-thread thq)
86  ;In case an unhandled-exception
87  (let* (
88    (ri (queue-remove! thq))
89    (th (reap-item-thread ri))
90    (to (reap-item-timeout ri)) )
91    (handle-exceptions
92      ;as
93      exn
94      ;with
95      (begin
96        #; ;FIXME should we put the offender back?
97        (queue-add! thq ri)
98        (print-exception-warning exn) )
99      ;in
100      (let ((res (thread-join! th to REAP-TIMED-OUT)))
101        ;try again if it just timed-out
102        (when (eq? REAP-TIMED-OUT res)
103          (let ((rt (reap-item-retries ri)))
104            (if (fx= 0 rt)
105              (warning "cannot reap thread" th)
106              (begin
107                (set-reap-item-retries! ri (fx- rt 1))
108                (queue-add! thq ri) ) ) ) ) ) ) ) )
109
110(define-inline (reap-thread-queue-top thq)
111  (unless (queue-empty? thq) (reap-queue-thread thq)) )
112
113(define-inline (reap-thread-queue thq)
114  (until (queue-empty? thq) (reap-queue-thread thq)) )
115
116;;
117
118(define +threads+ #f)           ;Queue of threads to reap
119
120(define +reaper-thread+ #f)     ;Needs a separate thread since asynch
121
122(define +greedy?+ #f)           ;Reaper should empty the queue each time-slice
123
124(define +wait-seconds+ DEFAULT-REAPER-WAIT-SECONDS) ;Reaper sleep time
125
126(define +stopping?+ #f)         ;Reaper should cleanly stop
127(define +shutdown?+ #f)         ;Program terminating
128
129(define +timeout+ DEFAULT-REAPER-TIMEOUT) ;Reaped thread join timeout
130(define +retries+ DEFAULT-REAPER-RETRIES) ;Reaped thread join attempts
131
132;
133
134(define-inline (reap-all)
135  (%synch-with +threads+ threads (reap-thread-queue threads) ) )
136
137(define-inline (reap-top)
138  (%synch-with +threads+ threads (reap-thread-queue-top threads) ) )
139
140(define-inline (reap)
141  (%synch-with +threads+ threads
142    (if +greedy?+
143      (reap-thread-queue threads)
144      (reap-thread-queue-top threads) ) ) )
145
146; Reaper thread thunk
147
148(define (reaper)
149  (let loop ()
150    (if +stopping?+
151      (reap-all)
152      (begin
153        (reap)
154        #; ;FIXME this causes busy loop!
155        (thread-yield!)
156        (thread-sleep! 1.0)
157        (loop) ) ) ) )
158
159(define (adjust-reap-items-for-stopping)
160  (%synch-with +threads+ threads
161    (for-each
162      (lambda (ri)
163        (set-reap-item-retries! ri STOPPING-REAPER-RETRIES)
164        (set-reap-item-timeout! ri STOPPING-REAPER-TIMEOUT) )
165      (queue->list threads)) ) )
166
167;;
168
169(define (thread-reaper-shutdown!)
170  (set! +shutdown?+ #t)
171  (thread-reaper-stop!) )
172
173(define (thread-reaper-start!)
174  ;ensure reasonable state anyway
175  (unless +threads+
176    ;only done once
177    (set! +threads+ (make-object/synch (make-queue) '(queue/synch-)))
178    ;clean shutdown
179    (on-exit thread-reaper-shutdown!) )
180  ;whenever no reaper
181  (unless +reaper-thread+
182    (set! +stopping?+ #f)
183    (set! +reaper-thread+ (make-thread reaper 'thread-reaper))
184    (thread-quantum-set! +reaper-thread+ DEFAULT-REAPER-QUANTUM)
185    (thread-start! +reaper-thread+) ) )
186
187(define-inline (ensure-reaper)
188  (unless +reaper-thread+ (thread-reaper-start!)) )
189
190;;; Public
191
192(define (thread-reaper-shutdown?)
193  (or +stopping?+ +shutdown?+) )
194
195(define (thread-reap! th)
196  (check-thread 'thread-reap! th)
197  ;Ignore request when cannot fulfill
198  (if (or +stopping?+ +shutdown?+)
199    (warning "attempt to reap a thread as reaper winding up" th)
200    (begin
201      (ensure-reaper)
202      (%synch-with +threads+ threads
203        (queue-add! threads (make-reap-item th +timeout+ +retries+))) ) ) )
204
205
206(define (thread-reaper-stop!)
207  (when (and +reaper-thread+ (not +stopping?+))
208    (let (
209      (th +reaper-thread+) )
210      ;Bump up the time-slice so queue clears faster
211      (thread-quantum-set! th (fxmax (thread-quantum th) STOPPING-REAPER-QUANTUM))
212      ;No long waits or retries
213      (adjust-reap-items-for-stopping)
214      ;Tell reaper we're quits
215      (set! +stopping?+ #t)
216      ;Waits until queue empty
217      ;FIXME Timeout? Assuming each item joins/timed-out then not needed.
218      (thread-join! th)
219      ;No more reaping with this thread
220      (set! +reaper-thread+ #f) ) )
221  ;noreturn
222  (void) )
223
224;;
225
226;"location" style calling
227;FIXME use getter-with-setter
228
229(define (thread-reaper-greedy-set! flag)
230  (set! +greedy?+ (->boolean flag)) )
231
232(define thread-reaper-greedy
233  (getter-with-setter
234    (lambda args
235      (if (null? args)
236        +greedy?+
237        (begin
238          (warning 'thread-reaper-greedy "mutation deprecated")
239          (thread-reaper-greedy-set! (car args)) ) ) )
240     thread-reaper-greedy-set!))
241
242(define (thread-reaper-quantum-set! qt)
243  (if +reaper-thread+
244    (unless (or +stopping?+ +shutdown?+)
245      (thread-quantum-set! +reaper-thread+ qt) ) )
246    (error 'thread-reaper-quantum-set! "reaper is not running") )
247
248(define thread-reaper-quantum
249  (getter-with-setter
250    (lambda args
251      (if +reaper-thread+
252        (if (null? args)
253          (thread-quantum +reaper-thread+)
254          (begin
255            (warning 'thread-reaper-quantum "mutation deprecated")
256            (thread-reaper-quantum-set! (car args)) ) )
257        (error 'thread-reaper-quantum "reaper is not running") ) )
258    thread-reaper-quantum-set!))
259
260(define (thread-reaper-wait-seconds-set! to)
261  (set! +wait-seconds+ (check-positive-number 'thread-reaper-wait-seconds to)) )
262
263(define thread-reaper-wait-seconds
264  (getter-with-setter
265    (lambda args
266      (if (null? args)
267        +wait-seconds+
268        (begin
269          (warning 'thread-reaper-wait-seconds "mutation deprecated")
270          (thread-reaper-wait-seconds-set! (car args)) ) ) )
271    thread-reaper-wait-seconds-set!))
272
273(define (thread-reaper-timeout-set! to)
274  (set! +timeout+
275    (and to (check-positive-number 'thread-reaper-timeout to))) )
276
277(define thread-reaper-timeout
278  (getter-with-setter
279    (lambda args
280      (if (null? args)
281        +timeout+
282        (begin
283          (warning 'thread-timeout "mutation deprecated")
284          (thread-reaper-timeout-set! (car args)) ) ) )
285    thread-reaper-timeout-set!))
286
287(define (thread-reaper-retries-set! rt)
288  (set! +retries+ (check-natural-fixnum 'thread-reaper-retries rt)) )
289
290(define thread-reaper-retries
291  (getter-with-setter
292    (lambda args
293      (if (null? args)
294        +retries+
295        (begin
296          (warning 'thread-reaper-retries "mutation deprecated")
297          (thread-reaper-retries-set! (car args)) ) ) )
298    thread-reaper-retries-set!))
299
300) ;module thread-reaper
Note: See TracBrowser for help on using the repository browser.