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

Last change on this file since 38686 was 38686, checked in by Kon Lovett, 4 months ago

purpose comment

File size: 10.0 KB
Line 
1;;;; thread-utils.scm
2;;;; Kon Lovett, Oct '09
3;;;; Kon Lovett, Sep '17
4
5;; Issues
6
7(module thread-utils
8
9(;export
10  ;
11  thread-warning-message
12  print-exception-error
13  print-exception-warning
14  ;
15  make-thread-timeout
16  thread-timeout? check-thread-timeout error-thread-timeout
17  ;
18  check-thread error-thread
19  ;
20  thread-state=?
21  ;
22  thread-created?
23  thread-ready?
24  thread-running?
25  thread-blocked?
26  thread-suspended?
27  thread-sleeping?
28  thread-terminated?
29  thread-dead?
30  thread-obstructed?
31  ;
32  thread-blocked-for-termination?
33  thread-blocked-for-io?
34  thread-blocked-for-timeout?
35  ;
36  thread-unblock!
37  ;
38  thread-thunk
39  thread-result-list
40  #;thread-state
41  thread-block-timeout
42  thread-state-buffer
43  #;thread-name
44  thread-end-exception
45  thread-owned-mutexes
46  #;thread-quantum
47  #;thread-specific
48  thread-block-object
49  thread-recipients
50  thread-dynamic-winds
51  thread-standard-input
52  thread-standard-output
53  thread-standard-error
54  thread-default-exception-handler
55  thread-current-parameter-vector
56  ;
57  thread-block-object-of-recipient?
58  ;
59  *thread-thunk
60  *thread-result-list
61  *thread-state
62  *thread-block-timeout
63  *thread-state-buffer
64  *thread-name
65  *thread-end-exception
66  *thread-owned-mutexes
67  *thread-quantum
68  *thread-specific
69  *thread-block-object
70  *thread-recipients)
71
72(import scheme)
73(import (chicken base))
74(import (chicken type))
75(import (only (chicken condition) print-error-message))
76(import (only (chicken format) format))
77(import (only (srfi 1) any))
78(import (only (srfi 18) thread-state thread? current-thread condition-variable?
79  mutex? time? seconds->time time->seconds current-time))
80(import (only type-checks define-check+error-type))
81
82;; Thread Messages
83
84(define (thread-warning-message th)
85  (format #t "Warning (~A): " th) )
86
87(define (print-exception-error exn
88            #!optional
89            (th (current-thread))
90            (out (current-error-port))
91            (hdr "\n\tThread call history:\n"))
92  (print-error-message exn out (thread-warning-message th))
93  (print-call-chain out 0 th hdr) )
94
95(define (print-exception-warning exn
96            #!optional
97            (th (current-thread))
98            (out (current-error-port))
99            (hdr "\n\tThread call history:\n"))
100  (when (enable-warnings)
101    (print-exception-error exn th out hdr)) )
102
103;; Thread Timeout Object (actually any SRFI 12 timeout)
104
105(define (thread-timeout? obj) (or (not obj) (number? obj) (time? obj)))
106
107(define-check+error-type thread-timeout)
108
109(define (make-thread-timeout off #!optional base)
110  (cond
111    ;ignore base when no timeout
112    ((not off)    #f)
113    ((time? off)  off)
114    ((number? off)
115      (let (
116        (base
117          (cond
118            ((number? base)
119              base )
120            ((not base)
121              (time->seconds (current-time)) )
122            ((time? base)
123              (time->seconds base) )
124            (else
125              (error-thread-timeout 'make-thread-timeout base 'base) ) ) ) )
126        (seconds->time (+ off base)) ) )
127    (else
128      (error-thread-timeout 'make-thread-timeout off 'offset) ) ) )
129
130;(define make-thread-timeout
131
132;;; Unchecked slot access
133
134(define (*thread-thunk th)            (##sys#slot th 1))
135(define (*thread-result-list th)      (##sys#slot th 2))
136(define (*thread-state th)            (##sys#slot th 3))
137(define (*thread-block-timeout th)    (##sys#slot th 4))
138(define (*thread-state-buffer th)     (##sys#slot th 5))
139(define (*thread-name th)             (##sys#slot th 6))
140(define (*thread-end-exception th)    (##sys#slot th 7))
141(define (*thread-owned-mutexes th)    (##sys#slot th 8))
142(define (*thread-quantum th)          (##sys#slot th 9))
143(define (*thread-specific th)         (##sys#slot th 10))
144(define (*thread-block-object th)     (##sys#slot th 11))
145(define (*thread-recipients th)       (##sys#slot th 12))
146(define (*unblocked-by-timeout? th)   (##sys#slot th 13))
147
148;;
149
150(define (*state-buffer-dynamic-winds sb)              (vector-ref sb 0))
151(define (*state-buffer-standard-input sb)             (vector-ref sb 1))
152(define (*state-buffer-standard-output sb)            (vector-ref sb 2))
153(define (*state-buffer-standard-error sb)             (vector-ref sb 3))
154(define (*state-buffer-default-exception-handler sb)  (vector-ref sb 4))
155(define (*state-buffer-current-parameter-vector sb)   (vector-ref sb 5))
156
157;;
158
159(define (thread-block-object-of-recipient? th)
160  (any
161    (lambda (rth) (eq? (*thread-block-object rth) th))
162    (*thread-recipients th)) )
163
164;;;
165
166;;
167
168(define-check+error-type thread)
169
170;;
171
172(: thread-state=? (thread * -> boolean))
173;
174(define (thread-state=? th tk) (eq? tk (thread-state th)))
175
176(: thread-created? (thread -> boolean))
177(: thread-ready? (thread -> boolean))
178(: thread-running? (thread -> boolean))
179(: thread-blocked? (thread -> boolean))
180(: thread-suspended? (thread -> boolean))
181(: thread-sleeping? (thread -> boolean))
182(: thread-terminated? (thread -> boolean))
183(: thread-dead? (thread -> boolean))
184(: thread-obstructed? (thread -> boolean))
185;
186(define (thread-created? th)      (thread-state=? th 'created))
187(define (thread-ready? th)        (thread-state=? th 'ready))
188(define (thread-running? th)      (thread-state=? th 'running))
189(define (thread-blocked? th)      (thread-state=? th 'blocked))
190(define (thread-suspended? th)    (thread-state=? th 'suspended))
191(define (thread-sleeping? th)     (thread-state=? th 'sleeping))
192(define (thread-terminated? th)   (thread-state=? th 'terminated))
193(define (thread-dead? th)         (thread-state=? th 'dead))
194(define (thread-obstructed? th)   (or (thread-blocked? th) (thread-sleeping? th)))
195
196;;
197
198(: thread-blocked-for-object (thread -> *))
199;
200(define (*thread-blocked-for-object th)
201  (and
202    (thread-blocked? th)
203    (*thread-block-object th)) )
204
205(: thread-blocked-for-termination? (thread -> boolean))
206;
207(define (thread-blocked-for-termination? th)
208  (and
209    (thread-blocked? th)
210    ;????? ;FIXME accurate but imprecise
211    (null? (*thread-recipients th))
212    #t ) )
213
214(: thread-blocked-for-timeout? (thread -> boolean))
215;
216(define (thread-blocked-for-timeout? th)
217  (and
218    (thread-blocked? th)
219    (not (*thread-block-object th))
220    (*thread-block-timeout th)
221    #t ) )
222
223(: thread-blocked-for-io? (thread -> boolean))
224;
225(define (thread-blocked-for-io? th)
226  (and-let* ((obj (*thread-blocked-for-object th)))
227    ;FIXME should check for (fd . i/o)
228    (pair? obj) ) )
229
230;thread-block-object:
231;- mutex : means owns the mutex (but obviously not blocking on it)
232;condition-variable : means blocked waiting for a cv announce
233;thread : means blocked waiting for termination of the thread
234
235;;
236
237(: thread-unblock! (thread -> void))
238;
239(define (thread-unblock! th)
240  (when (thread-blocked-for-timeout? th) (##sys#thread-unblock! th))
241  #;
242  (when (thread-obstructed? th)
243    (cond
244      ((*thread-block-timeout th)
245        (##sys#thread-unblock! th) )
246      ;cannot unblock when terminating
247      ((*thread-recipients th)
248        )
249      ;cannot unblock when waiting for some other object
250      ((*thread-block-object th)
251        ) ) ) )
252
253;;
254
255#| ;SRFI-18
256(: thread-state (thread -> *))
257;
258(define (thread-state th)
259        (*thread-state (check-thread 'thread-state th)) )
260(: thread-name (thread -> *))
261;
262(define (thread-name th)
263        (*thread-name (check-thread 'thread-name th)) )
264
265(: thread-quantum (thread -> *))
266;
267(define (thread-quantum th)
268        (*thread-quantum (check-thread 'thread-quantum th)) )
269
270(: thread-specific (thread -> *))
271;
272(define (thread-specific th)
273        (*thread-specific (check-thread 'thread-specific th)) )
274|#
275
276(: thread-thunk (thread -> procedure))
277;
278(define (thread-thunk th)
279        (*thread-thunk (check-thread 'thread-thunk th)) )
280
281(: thread-result-list (thread -> (or boolean list)))
282;
283(define (thread-result-list th)
284        (*thread-result-list (check-thread 'thread-result-list th)) )
285
286(: thread-block-timeout (thread -> (or boolean float)))
287(define (thread-block-timeout th)
288        (*thread-block-timeout (check-thread 'thread-block-timeout th)) )
289
290(: thread-state-buffer (thread -> vector))
291;
292(define (thread-state-buffer th)
293        (*thread-state-buffer (check-thread 'thread-state-buffer th)) )
294
295(: thread-end-exception (thread -> *))
296;
297(define (thread-end-exception th)
298        (*thread-end-exception (check-thread 'thread-end-exception th)) )
299
300(: thread-owned-mutexes (thread -> list))
301;
302(define (thread-owned-mutexes th)
303        (*thread-owned-mutexes (check-thread 'thread-owned-mutexes th)) )
304
305(: thread-block-object (thread -> *))
306;
307(define (thread-block-object th)
308        (*thread-block-object (check-thread 'thread-block-object th)) )
309
310(: thread-recipients (thread -> list))
311;
312(define (thread-recipients th)
313        (*thread-recipients (check-thread 'thread-recipients th)) )
314
315(: unblocked-by-timeout? (thread -> boolean))
316;
317(define (unblocked-by-timeout? th)
318        (*unblocked-by-timeout? (check-thread 'unblocked-by-timeout? th)) )
319
320;;
321
322(: thread-dynamic-winds (thread -> list))
323;
324(define (thread-dynamic-winds th)
325        (*state-buffer-dynamic-winds (*thread-state-buffer (check-thread 'thread-dynamic-winds th))) )
326
327(: thread-standard-input (thread -> port))
328;
329(define (thread-standard-input th)
330        (*state-buffer-standard-input (*thread-state-buffer (check-thread 'thread-standard-input th))) )
331
332(: thread-standard-output (thread -> port))
333;
334(define (thread-standard-output th)
335        (*state-buffer-standard-output (*thread-state-buffer (check-thread 'thread-standard-output th))) )
336
337(: thread-standard-error (thread -> port))
338;
339(define (thread-standard-error th)
340        (*state-buffer-standard-error (*thread-state-buffer (check-thread 'thread-standard-error th))) )
341
342(: thread-default-exception-handler (thread -> procedure))
343;
344(define (thread-default-exception-handler th)
345        (*state-buffer-default-exception-handler (*thread-state-buffer (check-thread 'thread-default-exception-handler th))) )
346
347(: thread-current-parameter-vector (thread -> vector))
348;
349(define (thread-current-parameter-vector th)
350        (*state-buffer-current-parameter-vector (*thread-state-buffer (check-thread 'thread-current-parameter-vector th))) )
351
352#; ;TBD
353(:define vector (thread-current-parameter-vector (thread th) !..)
354        ;# ;
355        "..."
356        ;# ;dynamic checks
357        (check-thread 'thread-current-parameter-vector th) ...
358        ...
359        ;body
360        (*state-buffer-current-parameter-vector (*thread-state-buffer th)) )
361
362) ;module thread-utils
Note: See TracBrowser for help on using the repository browser.