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

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

add -strict-types, type is interface

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