source: project/release/4/thread-utils/trunk/thread-utils.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: 10.3 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 extras format)
82  (only ports with-output-to-string)
83  (only srfi-1 any)
84  (only srfi-18
85    thread-state thread? current-thread
86    condition-variable?
87    mutex?
88    time? seconds->time time->seconds current-time)
89  (only type-checks define-check+error-type))
90
91;; Thread Messages
92
93(define (thread-warning-message th)
94  (with-output-to-string (cut format #t "Warning (~A): " th)) )
95
96(define (print-exception-error exn
97            #!optional (th (current-thread)) (out (current-error-port)))
98  (print-error-message exn out (thread-warning-message th))
99  (print-call-chain out 0 th) )
100
101(define (print-exception-warning exn
102            #!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=? (thread * --> boolean))
215;
216(define (thread-state=? th tk)
217        (eq? tk (thread-state th)) )
218
219(: thread-created? (thread --> boolean))
220;
221(define (thread-created? th)
222        (thread-state=? th 'created) )
223
224(: thread-ready? (thread --> boolean))
225;
226(define (thread-ready? th)
227        (thread-state=? th 'ready) )
228
229(: thread-running? (thread --> boolean))
230;
231(define (thread-running? th)
232        (thread-state=? th 'running) )
233
234(: thread-blocked? (thread --> boolean))
235;
236(define (thread-blocked? th)
237        (thread-state=? th 'blocked) )
238
239(: thread-suspended? (thread --> boolean))
240;
241(define (thread-suspended? th)
242        (thread-state=? th 'suspended) )
243
244(: thread-sleeping? (thread --> boolean))
245;
246(define (thread-sleeping? th)
247        (thread-state=? th 'sleeping) )
248
249(: thread-terminated? (thread --> boolean))
250;
251(define (thread-terminated? th)
252        (thread-state=? th 'terminated) )
253
254(: thread-dead? (thread --> boolean))
255;
256(define (thread-dead? th)
257        (thread-state=? th 'dead) )
258
259(: thread-obstructed? (thread --> boolean))
260;
261(define (thread-obstructed? th)
262        (or (thread-blocked? th) (thread-sleeping? th)) )
263
264;;
265
266(: thread-blocked-for-object (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? (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? (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? (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! (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)
314        (##sys#thread-unblock! th) )
315      ;cannot unblock when terminating
316      ((*thread-recipients th)
317        )
318      ;cannot unblock when waiting for some other object
319      ((*thread-block-object th)
320        ) ) ) )
321
322;;
323
324(: thread-thunk (thread --> procedure))
325;
326(define (thread-thunk th)
327        (*thread-thunk (check-thread 'thread-thunk th)) )
328
329(: thread-result-list (thread --> (or boolean list)))
330;
331(define (thread-result-list th)
332        (*thread-result-list (check-thread 'thread-result-list th)) )
333
334#;(: thread-state (thread --> *))
335;
336#;(define (thread-state th)
337        (*thread-state (check-thread 'thread-state th)) )
338
339(: thread-block-timeout (thread --> (or boolean float)))
340(define (thread-block-timeout th)
341        (*thread-block-timeout (check-thread 'thread-block-timeout th)) )
342
343(: thread-state-buffer (thread --> vector))
344;
345(define (thread-state-buffer th)
346        (*thread-state-buffer (check-thread 'thread-state-buffer th)) )
347
348#;(: thread-name (thread --> *))
349;
350#;(define (thread-name th)
351        (*thread-name (check-thread 'thread-name th)) )
352
353(: thread-end-exception (thread --> *))
354;
355(define (thread-end-exception th)
356        (*thread-end-exception (check-thread 'thread-end-exception th)) )
357
358(: thread-owned-mutexes (thread --> list))
359;
360(define (thread-owned-mutexes th)
361        (*thread-owned-mutexes (check-thread 'thread-owned-mutexes th)) )
362
363#;(: thread-quantum (thread --> *))
364;
365#;(define (thread-quantum th)
366        (*thread-quantum (check-thread 'thread-quantum th)) )
367
368#;(: thread-specific (thread --> *))
369;
370#;(define (thread-specific th)
371        (*thread-specific (check-thread 'thread-specific th)) )
372
373(: thread-block-object (thread --> *))
374;
375(define (thread-block-object th)
376        (*thread-block-object (check-thread 'thread-block-object th)) )
377
378(: thread-recipients (thread --> list))
379;
380(define (thread-recipients th)
381        (*thread-recipients (check-thread 'thread-recipients th)) )
382
383(: unblocked-by-timeout? (thread --> boolean))
384;
385(define (unblocked-by-timeout? th)
386        (*unblocked-by-timeout? (check-thread 'unblocked-by-timeout? th)) )
387
388;;
389
390(: thread-dynamic-winds (thread --> list))
391;
392(define (thread-dynamic-winds th)
393        (*state-buffer-dynamic-winds (*thread-state-buffer (check-thread 'thread-dynamic-winds th))) )
394
395(: thread-standard-input (thread --> port))
396;
397(define (thread-standard-input th)
398        (*state-buffer-standard-input (*thread-state-buffer (check-thread 'thread-standard-input th))) )
399
400(: thread-standard-output (thread --> port))
401;
402(define (thread-standard-output th)
403        (*state-buffer-standard-output (*thread-state-buffer (check-thread 'thread-standard-output th))) )
404
405(: thread-standard-error (thread --> port))
406;
407(define (thread-standard-error th)
408        (*state-buffer-standard-error (*thread-state-buffer (check-thread 'thread-standard-error th))) )
409
410(: thread-default-exception-handler (thread --> procedure))
411;
412(define (thread-default-exception-handler th)
413        (*state-buffer-default-exception-handler (*thread-state-buffer (check-thread 'thread-default-exception-handler th))) )
414
415(: thread-current-parameter-vector (thread --> vector))
416;
417(define (thread-current-parameter-vector th)
418        (*state-buffer-current-parameter-vector (*thread-state-buffer (check-thread 'thread-current-parameter-vector th))) )
419
420#; ;TBD
421(:define vector (thread-current-parameter-vector (thread th) !..)
422        ;# ;
423        "..."
424        ;# ;dynamic checks
425        (check-thread 'thread-current-parameter-vector th) ...
426        ...
427        ;body
428        (*state-buffer-current-parameter-vector (*thread-state-buffer th)) )
429
430;DEPRECATED
431
432(: thread-blocked?/termination (deprecated thread-blocked-for-termination?))
433(define thread-blocked?/termination thread-blocked-for-termination?)
434
435(: thread-blocked?/io (deprecated thread-blocked-for-io?))
436(define thread-blocked?/io thread-blocked-for-io?)
437
438(: thread-blocked?/timeout (deprecated thread-blocked-for-timeout?))
439(define thread-blocked?/timeout thread-blocked-for-timeout?)
440
441) ;module thread-utils
Note: See TracBrowser for help on using the repository browser.