source: project/release/5/thread-utils/trunk/thread-reaper.scm @ 38939

Last change on this file since 38939 was 38939, checked in by Kon Lovett, 9 months ago

add -strict-types, type is interface

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