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

Last change on this file since 33727 was 33727, checked in by evhan, 3 years ago

srfi-18: Remove use of ##sys#fudge and tag version 1.2

File size: 16.4 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                     (begin
248                       (##sys#thread-block-for-termination! ct thread)
249                       (##sys#schedule) ) ))
250                (else
251                 (##sys#error 'thread-join!
252                              "Internal scheduler error: unknown thread state"
253                              ct (##sys#slot thread 3)) ) ) ) )
254           (##sys#thread-block-for-termination! ct thread)
255           (##sys#schedule) ) ) ) ) ) )
256
257(define (thread-terminate! thread)
258  (##sys#check-structure thread 'thread 'thread-terminate!)
259  (when (eq? thread ##sys#primordial-thread)
260    ((##sys#exit-handler)) )
261  (##sys#setslot thread 2 (list (##core#undefined)))
262  (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
263  (##sys#thread-kill! thread 'terminated)
264  (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
265
266(define (thread-suspend! thread)
267  (##sys#check-structure thread 'thread 'thread-suspend!)
268  (##sys#setslot thread 3 'suspended)
269  (when (eq? thread ##sys#current-thread) ;XXX what if thread is ready or blocked?
270    (##sys#call-with-current-continuation
271     (lambda (return)
272       (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
273       (##sys#schedule) ) ) ) )
274
275(define (thread-resume! thread)
276  (##sys#check-structure thread 'thread 'thread-resume!)
277  (when (eq? (##sys#slot thread 3) 'suspended) ;XXX what if thread is ready or blocked?
278    (##sys#setslot thread 3 'ready)
279    (##sys#add-to-ready-queue thread) ) )
280
281(define (thread-sleep! tm)
282  (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
283  (##sys#thread-sleep! (compute-time-limit tm 'thread-sleep!)))
284
285
286;;; Mutexes:
287
288(define (mutex? x) (##sys#structure? x 'mutex))
289
290(define (make-mutex #!optional (id (gensym 'mutex)))
291  (##sys#make-mutex id #f))
292
293(define (mutex-name x)
294  (##sys#check-structure x 'mutex 'mutex-name) 
295  (##sys#slot x 1) )
296
297(define (mutex-specific mutex)
298  (##sys#check-structure mutex 'mutex 'mutex-specific)
299  (##sys#slot mutex 6) )
300
301(define (mutex-specific-set! mutex x)
302  (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
303  (##sys#setslot mutex 6 x) )
304
305(define (mutex-state mutex)
306  (##sys#check-structure mutex 'mutex 'mutex-state)
307  (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
308        [(##sys#slot mutex 4) 'abandoned]
309        [else 'not-abandoned] ) )
310
311(define mutex-lock! 
312  (lambda (mutex . ms-and-t)
313    (##sys#check-structure mutex 'mutex 'mutex-lock!)
314    (let* ([limitsup (pair? ms-and-t)]
315           [limit (and limitsup (compute-time-limit (car ms-and-t) 'mutex-lock!))]
316           [threadsup (fx> (length ms-and-t) 1)]
317           [thread (and threadsup (cadr ms-and-t))] )
318      (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
319      (##sys#call-with-current-continuation
320       (lambda (return)
321         (let ([ct ##sys#current-thread])
322           (define (switch)
323             (dbg ct " sleeping on mutex " (mutex-name mutex))
324             (##sys#setslot ct 11 mutex)
325             (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
326             (##sys#schedule) )
327           (define (check)
328             (when (##sys#slot mutex 4) ; abandoned
329               (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
330           (define (assign)
331             (##sys#setislot ct 11 #f)
332             (check)
333             (if (and threadsup (not thread))
334                 (begin
335                   (##sys#setislot mutex 2 #f)
336                   (##sys#setislot mutex 5 #t) )
337                 (let* ([t (or thread ct)]
338                        [ts (##sys#slot t 3)] )
339                   (if (or (eq? 'terminated ts) (eq? 'dead ts))
340                       (begin
341                         (##sys#setislot mutex 2 #f)
342                         (##sys#setislot mutex 5 #f)
343                         (##sys#setislot mutex 4 #t)
344                         (check))
345                       (begin
346                         (##sys#setslot mutex 2 t)
347                         (##sys#setislot mutex 5 #t)
348                         (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
349             (return #t))
350           (dbg ct ": locking " mutex)
351           (cond [(not (##sys#slot mutex 5))
352                  (assign) ]
353                 [limit
354                  (check)
355                  (##sys#setslot
356                   ct 1 
357                   (lambda ()
358                     (if (##sys#slot ct 13)  ; unblocked by timeout
359                         (begin
360                           (##sys#setslot mutex 3 (delq ct (##sys#slot mutex 3)))
361                           (##sys#setislot ct 11 #f)
362                           (return #f))
363                         (begin
364                           (##sys#remove-from-timeout-list ct)
365                           (assign))) ))
366                  (##sys#thread-block-for-timeout! ct limit)
367                  (switch) ]
368                 [else
369                  (##sys#setslot ct 3 'sleeping)
370                  (##sys#setslot ct 1 assign)
371                  (switch) ] ) ) ) ) ) ) )
372
373(define mutex-unlock!
374  (lambda (mutex . cvar-and-to)
375    (##sys#check-structure mutex 'mutex 'mutex-unlock!)
376    (let ([ct ##sys#current-thread]
377          [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
378          [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
379      (dbg ct ": unlocking " (mutex-name mutex))
380      (when cvar
381        (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
382      (##sys#call-with-current-continuation
383       (lambda (return)
384         (let ([waiting (##sys#slot mutex 3)]
385               [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )
386           (##sys#setislot mutex 4 #f)  ; abandoned
387           (##sys#setislot mutex 5 #f)  ; blocked
388           (let ((t (##sys#slot mutex 2)))
389             (when t
390               (##sys#setislot mutex 2 #f)
391               (##sys#setslot t 8 (delq mutex (##sys#slot t 8))))) ; unown from owner
392           (when cvar
393             (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
394             (##sys#setslot ct 11 cvar) ; block object
395             (cond (limit
396                    (##sys#setslot 
397                     ct 1
398                     (lambda ()
399                       (##sys#setislot ct 11 #f)
400                       (if (##sys#slot ct 13) ; unblocked by timeout
401                           (begin
402                             (##sys#setslot cvar 2 (delq ct (##sys#slot cvar 2)))
403                             (return #f))
404                           (begin
405                             (##sys#remove-from-timeout-list ct)
406                             (return #t))) ) )
407                    (##sys#thread-block-for-timeout! ct limit) )
408                   (else
409                    (##sys#setslot ct 1 (lambda () (return #t)))
410                    (##sys#setslot ct 3 'sleeping)) ) )
411           (unless (null? waiting)
412             (let* ((wt (##sys#slot waiting 0))
413                    (wts (##sys#slot wt 3)) )
414               (##sys#setslot mutex 3 (##sys#slot waiting 1))
415               (##sys#setislot mutex 5 #t)
416               (case wts
417                 ((blocked sleeping)
418                  (##sys#setslot wt 11 #f)
419                  (##sys#add-to-ready-queue wt))
420                 (else
421                  (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state"
422                               wt wts))) ) )
423           (if (eq? (##sys#slot ct 3) 'running)
424               (return #t)
425               (##sys#schedule)) ) ) ) ) ))
426
427;;; Condition variables:
428
429(define make-condition-variable
430  (lambda name
431    (##sys#make-structure
432     'condition-variable 
433     (if (pair? name)                   ; #1 name
434         (car name)
435         (gensym 'condition-variable) )
436     '()                                ; #2 list of waiting threads
437     (##core#undefined) ) ) )           ; #3 specific
438
439(define (condition-variable? x)
440  (##sys#structure? x 'condition-variable) )
441
442(define (condition-variable-name cv)
443  (##sys#check-structure cv 'condition-variable 'condition-variable-name)
444  (##sys#slot cv 1) )
445
446(define (condition-variable-specific cv)
447  (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
448  (##sys#slot cv 3) )
449
450(define (condition-variable-specific-set! cv x)
451  (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
452  (##sys#setslot cv 3 x) )
453
454(define (condition-variable-signal! cvar)
455  (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
456  (dbg "signalling " cvar)
457  (let ([ts (##sys#slot cvar 2)])
458    (unless (null? ts)
459      (let* ([t0 (##sys#slot ts 0)]
460             [t0s (##sys#slot t0 3)] )
461        (##sys#setslot cvar 2 (##sys#slot ts 1))
462        (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
463          (##sys#thread-basic-unblock! t0) ) ) ) ) )
464
465(define (condition-variable-broadcast! cvar)
466  (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
467  (dbg "broadcasting " cvar)
468  (##sys#for-each
469   (lambda (ti)
470     (let ([tis (##sys#slot ti 3)])
471       (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
472         (##sys#thread-basic-unblock! ti) ) ) )
473   (##sys#slot cvar 2) )
474  (##sys#setislot cvar 2 '()) )
475
476
477;;; Change continuation of thread to signal an exception:
478
479(define (thread-signal! thread exn)
480  (##sys#check-structure thread 'thread 'thread-signal!)
481  (dbg "signal " thread exn)
482  (if (eq? thread ##sys#current-thread)
483      (##sys#signal exn)
484      (let ([old (##sys#slot thread 1)]
485            [blocked (##sys#slot thread 11)])
486        (cond
487         ((##sys#structure? blocked 'condition-variable)
488          (##sys#setslot blocked 2 (delq thread (##sys#slot blocked 2))))
489         ((##sys#structure? blocked 'mutex)
490          (##sys#setslot blocked 3 (delq thread (##sys#slot blocked 3))))
491         ((##sys#structure? blocked 'thread)
492          (##sys#setslot blocked 12 (delq thread (##sys#slot blocked 12)))))
493        (##sys#setslot
494         thread 1
495         (lambda ()
496           (##sys#signal exn)
497           (old) ) )
498        (##sys#setslot thread 3 'blocked)
499        (##sys#thread-unblock! thread) ) ) )
500
501
502;;; Don't block in the repl: (by Chris Double)
503
504(set! ##sys#read-prompt-hook
505  (let ([old ##sys#read-prompt-hook])
506    (lambda ()
507      (when (or (##core#inline "C_i_tty_forcedp") (##sys#tty-port? ##sys#standard-input))
508        (old)
509        (##sys#thread-block-for-i/o! ##sys#current-thread 0 #:input)
510        (thread-yield!)))))
511
512
513;;; Waiting for I/O on file-descriptor
514
515(define (thread-wait-for-i/o! fd #!optional (mode #:all))
516  (##sys#check-exact fd 'thread-wait-for-i/o!)
517  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode) 
518  (thread-yield!) )
519
520
521)
Note: See TracBrowser for help on using the repository browser.