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

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

type deprecated, canon form

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