source: project/release/5/srfi-18/trunk/srfi-18.scm @ 33353

Last change on this file since 33353 was 33262, checked in by evhan, 6 years ago

Fix up srfi-18 and srfi-69 imports after core library changes

File size: 16.6 KB
Line 
1;;;; srfi-18.scm - Simple thread unit - felix
2;
3; Copyright (c) 2008-2016, The Chicken Team
4; Copyright (c) 2000-2007, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29 (uses scheduler)
30 (usual-integrations)
31 (disable-interrupts))
32
33(register-feature! 'srfi-18)
34
35
36(module srfi-18 (current-time
37                 time->seconds
38                 seconds->time
39                 time?
40                 raise
41                 join-timeout-exception?
42                 abandoned-mutex-exception?
43                 terminated-thread-exception?
44                 uncaught-exception?
45                 uncaught-exception-reason
46                 make-thread
47                 thread?
48                 current-thread
49                 thread-state
50                 thread-specific
51                 thread-specific-set!
52                 thread-quantum
53                 thread-quantum-set!
54                 thread-name
55                 thread-start!
56                 thread-yield!
57                 thread-join!
58                 thread-terminate!
59                 thread-suspend!
60                 thread-resume!
61                 thread-sleep!
62                 mutex?
63                 make-mutex
64                 mutex-name
65                 mutex-specific
66                 mutex-specific-set!
67                 mutex-state
68                 mutex-lock!
69                 mutex-unlock!
70                 make-condition-variable
71                 condition-variable?
72                 condition-variable-name
73                 condition-variable-specific
74                 condition-variable-specific-set!
75                 condition-variable-signal!
76                 condition-variable-broadcast!
77                 thread-signal!
78                 thread-wait-for-i/o!)
79
80
81(import (scheme)
82        (chicken)
83        (chicken flonum)
84        (chicken time))
85
86(define-syntax dbg
87  (syntax-rules ()
88    ((_ . _) #f)))
89
90#;(define-syntax dbg
91    (syntax-rules ()
92      ((_ x ...) (print x ...))))
93
94;;; Helper routines:
95
96(define (compute-time-limit tm loc)
97  (cond ((not tm) #f)
98        ((##sys#structure? tm 'time) (##sys#slot tm 1))
99        ((real? tm) (+ (current-milliseconds) (* tm 1000)))
100        (else (##sys#signal-hook #:type-error loc "invalid timeout argument" tm))))
101
102(define (delq x lst)
103  (let loop ([lst lst])
104    (cond ((null? lst) lst)
105          ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
106          (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
107
108
109;;; Time objects:
110
111(define (current-time)
112  (##sys#make-structure 'time (current-milliseconds)))
113
114(define (time->seconds tm)
115  (##sys#check-structure tm 'time 'time->seconds)
116  (fp/ (##sys#slot tm 1) 1000.0))
117
118(define (seconds->time n)
119  (##sys#check-number n 'seconds->time)
120  (##sys#make-structure 'time (fp* (##sys#exact->inexact n) 1000.0)))
121
122(define (time? x) (##sys#structure? x 'time))
123
124
125;;; Exception handling:
126
127(define raise ##sys#signal)
128
129(define (join-timeout-exception? x) 
130  (and (##sys#structure? x 'condition)
131       (memq 'join-timeout-exception (##sys#slot x 1)) ) )
132
133(define (abandoned-mutex-exception? x)
134  (and (##sys#structure? x 'condition)
135       (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )
136
137(define (terminated-thread-exception? x)
138  (and (##sys#structure? x 'condition)
139       (memq 'terminated-thread-exception (##sys#slot x 1)) ) )
140
141(define (uncaught-exception? x)
142  (and (##sys#structure? x 'condition)
143       (memq 'uncaught-exception (##sys#slot x 1)) ) )
144
145(define uncaught-exception-reason
146  (condition-property-accessor 'uncaught-exception 'reason) )
147
148
149;;; Threads:
150
151(define make-thread
152  (lambda (thunk . name)
153    (let ((thread
154           (##sys#make-thread
155            #f
156            'created
157            (if (pair? name) (##sys#slot name 0) (gensym 'thread))
158            (##sys#slot ##sys#current-thread 9) ) ) )
159      (##sys#setslot 
160       thread 1 
161       (lambda () 
162         (##sys#call-with-values
163          thunk
164          (lambda results
165            (##sys#setslot thread 2 results)
166            (##sys#thread-kill! thread 'dead)
167            (##sys#schedule) ) ) ) )
168      thread) ) )
169
170(define (thread? x) (##sys#structure? x 'thread))
171(define (current-thread) ##sys#current-thread)
172
173(define (thread-state thread)
174  (##sys#check-structure thread 'thread 'thread-state)
175  (##sys#slot thread 3) )
176
177(define (thread-specific-set! thread x)
178  (##sys#check-structure thread 'thread 'thread-specific-set!)
179  (##sys#setslot thread 10 x) )
180
181(define thread-specific
182  (getter-with-setter
183   (lambda (thread)
184     (##sys#check-structure thread 'thread 'thread-specific)
185     (##sys#slot thread 10) )
186   thread-specific-set!))
187
188(define (thread-quantum thread)
189  (##sys#check-structure thread 'thread 'thread-quantum)
190  (##sys#slot thread 9) )
191
192(define (thread-quantum-set! thread q)
193  (##sys#check-structure thread 'thread 'thread-quantum-set!)
194  (##sys#check-exact q 'thread-quantum-set!)
195  (##sys#setislot thread 9 (fxmax q 10)) )
196
197(define (thread-name x)
198  (##sys#check-structure x 'thread 'thread-name)
199  (##sys#slot x 6) )
200
201(define thread-start!
202  (lambda (thread)
203    (if (procedure? thread)
204        (set! thread (make-thread thread))
205        (##sys#check-structure thread 'thread 'thread-start!) )
206    (unless (eq? 'created (##sys#slot thread 3))
207      (##sys#error 'thread-start! "thread cannot be started a second time" thread) )
208    (##sys#setslot thread 3 'ready)
209    (##sys#add-to-ready-queue thread) 
210    thread) )
211
212(define thread-yield! ##sys#thread-yield!) ;In library.scm
213
214(define thread-join!
215  (lambda (thread . timeout)
216    (##sys#check-structure thread 'thread 'thread-join!)
217    (let* ((limit (and (pair? timeout) 
218                       (compute-time-limit (##sys#slot timeout 0) 'thread-join!)))
219           (rest (and (pair? timeout) (##sys#slot timeout 1)))
220           (tosupplied (and rest (pair? rest)))
221           (toval (and tosupplied (##sys#slot rest 0))) )
222      (##sys#call-with-current-continuation
223       (lambda (return)
224         (let ((ct ##sys#current-thread))
225           (when limit (##sys#thread-block-for-timeout! ct limit))
226           (##sys#setslot
227            ct 1
228            (lambda ()
229              (case (##sys#slot thread 3)
230                ((dead)
231                 (unless (##sys#slot ct 13) ; not unblocked by timeout
232                   (##sys#remove-from-timeout-list ct))
233                 (apply return (##sys#slot thread 2)))
234                ((terminated)
235                 (return 
236                  (##sys#signal
237                   (##sys#make-structure 
238                    'condition '(uncaught-exception)
239                    (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) )
240                ((blocked ready sleeping)
241                 (if limit
242                     (return
243                      (if tosupplied
244                          toval
245                          (##sys#signal
246                           (##sys#make-structure 'condition '(join-timeout-exception) '())) ) )
247                     (##sys#thread-block-for-termination! ct thread) ) )
248                (else
249                 (##sys#error 'thread-join!
250                              "Internal scheduler error: unknown thread state: "
251                              ct (##sys#slot thread 3)) ) ) ) )
252           (##sys#thread-block-for-termination! ct thread)
253           (##sys#schedule) ) ) ) ) ) )
254
255(define (thread-terminate! thread)
256  (##sys#check-structure thread 'thread 'thread-terminate!)
257  (when (eq? thread ##sys#primordial-thread)
258    ((##sys#exit-handler)) )
259  (##sys#setslot thread 2 (list (##core#undefined)))
260  (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
261  (##sys#thread-kill! thread 'terminated)
262  (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
263
264(define (thread-suspend! thread)
265  (##sys#check-structure thread 'thread 'thread-suspend!)
266  (##sys#setslot thread 3 'suspended)
267  (when (eq? thread ##sys#current-thread) ;XXX what if thread is ready or blocked?
268    (##sys#call-with-current-continuation
269     (lambda (return)
270       (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
271       (##sys#schedule) ) ) ) )
272
273(define (thread-resume! thread)
274  (##sys#check-structure thread 'thread 'thread-resume!)
275  (when (eq? (##sys#slot thread 3) 'suspended) ;XXX what if thread is ready or blocked?
276    (##sys#setslot thread 3 'ready)
277    (##sys#add-to-ready-queue thread) ) )
278
279(define (thread-sleep! tm)
280  (define (sleep limit)
281    (##sys#call-with-current-continuation
282     (lambda (return)
283       (let ((ct ##sys#current-thread))
284         (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
285         (##sys#thread-block-for-timeout! ct limit)
286         (##sys#schedule) ) ) ) )
287  (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
288  (sleep (compute-time-limit tm 'thread-sleep!)) )
289
290
291;;; Mutexes:
292
293(define (mutex? x) (##sys#structure? x 'mutex))
294
295(define (make-mutex #!optional (id (gensym 'mutex)))
296  (##sys#make-mutex id #f))
297
298(define (mutex-name x)
299  (##sys#check-structure x 'mutex 'mutex-name) 
300  (##sys#slot x 1) )
301
302(define (mutex-specific mutex)
303  (##sys#check-structure mutex 'mutex 'mutex-specific)
304  (##sys#slot mutex 6) )
305
306(define (mutex-specific-set! mutex x)
307  (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
308  (##sys#setslot mutex 6 x) )
309
310(define (mutex-state mutex)
311  (##sys#check-structure mutex 'mutex 'mutex-state)
312  (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
313        [(##sys#slot mutex 4) 'abandoned]
314        [else 'not-abandoned] ) )
315
316(define mutex-lock! 
317  (lambda (mutex . ms-and-t)
318    (##sys#check-structure mutex 'mutex 'mutex-lock!)
319    (let* ([limitsup (pair? ms-and-t)]
320           [limit (and limitsup (compute-time-limit (car ms-and-t) 'mutex-lock!))]
321           [threadsup (fx> (length ms-and-t) 1)]
322           [thread (and threadsup (cadr ms-and-t))] )
323      (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
324      (##sys#call-with-current-continuation
325       (lambda (return)
326         (let ([ct ##sys#current-thread])
327           (define (switch)
328             (dbg ct " sleeping on mutex " (mutex-name mutex))
329             (##sys#setslot ct 11 mutex)
330             (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
331             (##sys#schedule) )
332           (define (check)
333             (when (##sys#slot mutex 4) ; abandoned
334               (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
335           (define (assign)
336             (##sys#setislot ct 11 #f)
337             (check)
338             (if (and threadsup (not thread))
339                 (begin
340                   (##sys#setislot mutex 2 #f)
341                   (##sys#setislot mutex 5 #t) )
342                 (let* ([t (or thread ct)]
343                        [ts (##sys#slot t 3)] )
344                   (if (or (eq? 'terminated ts) (eq? 'dead ts))
345                       (begin
346                         (##sys#setislot mutex 2 #f)
347                         (##sys#setislot mutex 5 #f)
348                         (##sys#setislot mutex 4 #t)
349                         (check))
350                       (begin
351                         (##sys#setslot mutex 2 t)
352                         (##sys#setislot mutex 5 #t)
353                         (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
354             (return #t))
355           (dbg ct ": locking " mutex)
356           (cond [(not (##sys#slot mutex 5))
357                  (assign) ]
358                 [limit
359                  (check)
360                  (##sys#setslot
361                   ct 1 
362                   (lambda ()
363                     (if (##sys#slot ct 13)  ; unblocked by timeout
364                         (begin
365                           (##sys#setslot mutex 3 (delq ct (##sys#slot mutex 3)))
366                           (##sys#setislot ct 11 #f)
367                           (return #f))
368                         (begin
369                           (##sys#remove-from-timeout-list ct)
370                           (assign))) ))
371                  (##sys#thread-block-for-timeout! ct limit)
372                  (switch) ]
373                 [else
374                  (##sys#setslot ct 3 'sleeping)
375                  (##sys#setslot ct 1 assign)
376                  (switch) ] ) ) ) ) ) ) )
377
378(define mutex-unlock!
379  (lambda (mutex . cvar-and-to)
380    (##sys#check-structure mutex 'mutex 'mutex-unlock!)
381    (let ([ct ##sys#current-thread]
382          [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
383          [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
384      (dbg ct ": unlocking " (mutex-name mutex))
385      (when cvar
386        (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
387      (##sys#call-with-current-continuation
388       (lambda (return)
389         (let ([waiting (##sys#slot mutex 3)]
390               [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )
391           (##sys#setislot mutex 4 #f)  ; abandoned
392           (##sys#setislot mutex 5 #f)  ; blocked
393           (let ((t (##sys#slot mutex 2)))
394             (when t
395               (##sys#setislot mutex 2 #f)
396               (##sys#setslot t 8 (delq mutex (##sys#slot t 8))))) ; unown from owner
397           (when cvar
398             (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
399             (##sys#setslot ct 11 cvar) ; block object
400             (cond (limit
401                    (##sys#setslot 
402                     ct 1
403                     (lambda ()
404                       (##sys#setislot ct 11 #f)
405                       (if (##sys#slot ct 13) ; unblocked by timeout
406                           (begin
407                             (##sys#setslot cvar 2 (delq ct (##sys#slot cvar 2)))
408                             (return #f))
409                           (begin
410                             (##sys#remove-from-timeout-list ct)
411                             (return #t))) ) )
412                    (##sys#thread-block-for-timeout! ct limit) )
413                   (else
414                    (##sys#setslot ct 1 (lambda () (return #t)))
415                    (##sys#setslot ct 3 'sleeping)) ) )
416           (unless (null? waiting)
417             (let* ((wt (##sys#slot waiting 0))
418                    (wts (##sys#slot wt 3)) )
419               (##sys#setslot mutex 3 (##sys#slot waiting 1))
420               (##sys#setislot mutex 5 #t)
421               (case wts
422                 ((blocked sleeping)
423                  (##sys#setslot wt 11 #f)
424                  (##sys#add-to-ready-queue wt))
425                 (else
426                  (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state: "
427                               wt wts))) ) )
428           (if (eq? (##sys#slot ct 3) 'running)
429               (return #t)
430               (##sys#schedule)) ) ) ) ) ))
431
432;;; Condition variables:
433
434(define make-condition-variable
435  (lambda name
436    (##sys#make-structure
437     'condition-variable 
438     (if (pair? name)                   ; #1 name
439         (car name)
440         (gensym 'condition-variable) )
441     '()                                ; #2 list of waiting threads
442     (##core#undefined) ) ) )           ; #3 specific
443
444(define (condition-variable? x)
445  (##sys#structure? x 'condition-variable) )
446
447(define (condition-variable-name cv)
448  (##sys#check-structure cv 'condition-variable 'condition-variable-name)
449  (##sys#slot cv 1) )
450
451(define (condition-variable-specific cv)
452  (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
453  (##sys#slot cv 3) )
454
455(define (condition-variable-specific-set! cv x)
456  (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
457  (##sys#setslot cv 3 x) )
458
459(define (condition-variable-signal! cvar)
460  (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
461  (dbg "signalling " cvar)
462  (let ([ts (##sys#slot cvar 2)])
463    (unless (null? ts)
464      (let* ([t0 (##sys#slot ts 0)]
465             [t0s (##sys#slot t0 3)] )
466        (##sys#setslot cvar 2 (##sys#slot ts 1))
467        (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
468          (##sys#thread-basic-unblock! t0) ) ) ) ) )
469
470(define (condition-variable-broadcast! cvar)
471  (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
472  (dbg "broadcasting " cvar)
473  (##sys#for-each
474   (lambda (ti)
475     (let ([tis (##sys#slot ti 3)])
476       (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
477         (##sys#thread-basic-unblock! ti) ) ) )
478   (##sys#slot cvar 2) )
479  (##sys#setislot cvar 2 '()) )
480
481
482;;; Change continuation of thread to signal an exception:
483
484(define (thread-signal! thread exn)
485  (##sys#check-structure thread 'thread 'thread-signal!)
486  (dbg "signal " thread exn)
487  (if (eq? thread ##sys#current-thread)
488      (##sys#signal exn)
489      (let ([old (##sys#slot thread 1)]
490            [blocked (##sys#slot thread 11)])
491        (cond
492         ((##sys#structure? blocked 'condition-variable)
493          (##sys#setslot blocked 2 (delq thread (##sys#slot blocked 2))))
494         ((##sys#structure? blocked 'mutex)
495          (##sys#setslot blocked 3 (delq thread (##sys#slot blocked 3))))
496         ((##sys#structure? blocked 'thread)
497          (##sys#setslot blocked 12 (delq thread (##sys#slot blocked 12)))))
498        (##sys#setslot
499         thread 1
500         (lambda ()
501           (##sys#signal exn)
502           (old) ) )
503        (##sys#setslot thread 3 'blocked)
504        (##sys#thread-unblock! thread) ) ) )
505
506
507;;; Don't block in the repl: (by Chris Double)
508
509(set! ##sys#read-prompt-hook
510  (let ([old ##sys#read-prompt-hook])
511    (lambda ()
512      (when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
513        (old)
514        (##sys#thread-block-for-i/o! ##sys#current-thread 0 #:input)
515        (thread-yield!)))) )
516
517
518;;; Waiting for I/O on file-descriptor
519
520(define (thread-wait-for-i/o! fd #!optional (mode #:all))
521  (##sys#check-exact fd 'thread-wait-for-i/o!)
522  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode) 
523  (thread-yield!) )
524
525
526)
Note: See TracBrowser for help on using the repository browser.