source: project/chicken/trunk/srfi-18.scm @ 15823

Last change on this file since 15823 was 15057, checked in by felix winkelmann, 10 years ago

fix for begin-capturing bug (#47), removed uses of define-macro

File size: 16.1 KB
Line 
1;;;; srfi-18.scm - Simple thread unit - felix
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
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 (unit srfi-18)
30 (uses scheduler)
31 (disable-warning redef)
32 (disable-interrupts)
33 (usual-integrations)
34 (hide ##sys#compute-time-limit) )
35
36(cond-expand
37 [paranoia]
38 [else
39  (declare
40    (no-bound-checks)
41    (no-procedure-checks-for-usual-bindings)
42    (bound-to-procedure
43     ##sys#thread-yield!
44     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
45     ##sys#thread-basic-unblock! gensym ##sys#thread-block-for-timeout! ##sys#thread-kill!
46     ##sys#thread-block-for-termination! make-thread ##sys#exact->inexact ##sys#flonum-fraction truncate
47     ##sys#add-to-ready-queue
48     ##sys#schedule ##sys#make-thread
49     ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
50     ##sys#current-exception-handler ##sys#abandon-mutexes ##sys#check-structure ##sys#structure? ##sys#make-mutex
51     ##sys#delq ##sys#compute-time-limit ##sys#fudge) ) ] )
52
53(include "unsafe-declarations.scm")
54
55(register-feature! 'srfi-18)
56
57(define-syntax dbg
58  (syntax-rules ()
59    ((_ . _) #f)))
60
61
62;;; Helper routines:
63
64(define ##sys#compute-time-limit
65  (let ([truncate truncate])
66    (lambda (tm)
67      (and tm
68           (cond [(##sys#structure? tm 'time) (##sys#slot tm 1)]
69                 [(number? tm) (fx+ (##sys#fudge 16) (inexact->exact (truncate (* tm 1000))))]
70                 [else (##sys#signal-hook #:type-error "invalid timeout argument" tm)] ) ) ) ) )
71
72
73;;; Time objects:
74
75(declare
76  (foreign-declare #<<EOF
77static C_TLS long C_ms;
78#define C_get_seconds   C_seconds(&C_ms)
79EOF
80) )
81
82(define-foreign-variable C_get_seconds double)
83(define-foreign-variable C_startup_time_seconds double)
84(define-foreign-variable C_ms long)
85
86(define (current-time)
87  (let* ([s C_get_seconds]
88         [ss C_startup_time_seconds] 
89         [ms C_ms] )
90    (##sys#make-structure
91     'time
92     (inexact->exact (truncate (+ (* (- s ss) 1000) C_ms)))
93     s
94     C_ms) ) )
95
96(define srfi-18:current-time current-time)
97
98(define (time->seconds tm)
99  (##sys#check-structure tm 'time 'time->seconds)
100  (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )
101
102(define (time->milliseconds tm)
103  (##sys#check-structure tm 'time 'time->milliseconds)
104  (+ (inexact->exact (* (- (##sys#slot tm 2) C_startup_time_seconds) 1000))
105     (##sys#slot tm 3) ) )
106
107(define (seconds->time n)
108  (##sys#check-number n 'seconds->time)
109  (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
110         [ms (truncate (* 1000 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
111         [n3 (inexact->exact (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
112    (##sys#make-structure 'time n3 (truncate n) (inexact->exact ms)) ) )
113
114(define (milliseconds->time nms)
115  (##sys#check-exact nms 'milliseconds->time)
116  (let ((s (+ C_startup_time_seconds (/ nms 1000))))
117    (##sys#make-structure 'time nms s 0) ) )
118
119(define (time? x) (##sys#structure? x 'time))
120
121(define srfi-18:time? time?)
122
123
124;;; Exception handling:
125
126(define raise ##sys#signal)
127
128(define (join-timeout-exception? x) 
129  (and (##sys#structure? x 'condition)
130       (memq 'join-timeout-exception (##sys#slot x 1)) ) )
131
132(define (abandoned-mutex-exception? x)
133  (and (##sys#structure? x 'condition)
134       (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )
135
136(define (terminated-thread-exception? x)
137  (and (##sys#structure? x 'condition)
138       (memq 'terminated-thread-exception (##sys#slot x 1)) ) )
139
140(define (uncaught-exception? x)
141  (and (##sys#structure? x 'condition)
142       (memq 'uncaught-exception (##sys#slot x 1)) ) )
143
144(define uncaught-exception-reason
145  (condition-property-accessor 'uncaught-exception 'reason) )
146
147
148;;; Threads:
149
150(define make-thread
151  (let ((gensym gensym))
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 thread)
178  (##sys#check-structure thread 'thread 'thread-specific)
179  (##sys#slot thread 10) )
180
181(define (thread-specific-set! thread x)
182  (##sys#check-structure thread 'thread 'thread-specific-set!)
183  (##sys#setslot thread 10 x) )
184
185(define (thread-quantum thread)
186  (##sys#check-structure thread 'thread 'thread-quantum)
187  (##sys#slot thread 9) )
188
189(define (thread-quantum-set! thread q)
190  (##sys#check-structure thread 'thread 'thread-quantum-set!)
191  (##sys#check-exact q 'thread-quantum-set!)
192  (##sys#setislot thread 9 (fxmax q 10)) )
193
194(define (thread-name x)
195  (##sys#check-structure x 'thread 'thread-name)
196  (##sys#slot x 6) )
197
198(define thread-start!
199  (let ([make-thread make-thread])
200    (lambda (thread)
201      (if (procedure? thread)
202          (set! thread (make-thread thread))
203          (##sys#check-structure thread 'thread 'thread-start!) )
204      (unless (eq? 'created (##sys#slot thread 3))
205        (##sys#error 'thread-start! "thread cannot be started a second time" thread) )
206      (##sys#setslot thread 3 'ready)
207      (##sys#add-to-ready-queue thread) 
208      thread) ) )
209
210(define thread-yield! ##sys#thread-yield!) ;In library.scm
211
212(define thread-join!
213  (lambda (thread . timeout)
214    (##sys#check-structure thread 'thread 'thread-join!)
215    (let* ((limit (and (pair? timeout) (##sys#compute-time-limit (##sys#slot timeout 0))))
216           (rest (and (pair? timeout) (##sys#slot timeout 1)))
217           (tosupplied (and rest (pair? rest)))
218           (toval (and tosupplied (##sys#slot rest 0))) )
219      (##sys#call-with-current-continuation
220       (lambda (return)
221         (let ([ct ##sys#current-thread])
222           (when limit (##sys#thread-block-for-timeout! ct limit))
223           (##sys#setslot
224            ct 1
225            (lambda ()
226              (case (##sys#slot thread 3)
227                [(dead)
228                 (unless (##sys#slot ct 13) ; not unblocked by timeout
229                   (##sys#remove-from-timeout-list ct))
230                 (apply return (##sys#slot thread 2))]
231                [(terminated)
232                 (return 
233                  (##sys#signal
234                   (##sys#make-structure 
235                    'condition '(uncaught-exception)
236                    (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) ]
237                [else
238                 (return
239                  (if tosupplied
240                      toval
241                      (##sys#signal
242                       (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ] ) ) )
243           (##sys#thread-block-for-termination! ct thread) 
244           (##sys#schedule) ) ) ) ) ) )
245           
246(define (thread-terminate! thread)
247  (##sys#check-structure thread 'thread 'thread-terminate!)
248  (when (eq? thread ##sys#primordial-thread)
249    ((##sys#exit-handler)) )
250  (##sys#setslot thread 2 (list (##core#undefined)))
251  (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
252  (##sys#thread-kill! thread 'terminated)
253  (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
254
255(define (thread-suspend! thread)
256  (##sys#check-structure thread 'thread 'thread-suspend!)
257  (##sys#setslot thread 3 'suspended)
258  (when (eq? thread ##sys#current-thread)
259    (##sys#call-with-current-continuation
260     (lambda (return)
261       (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
262       (##sys#schedule) ) ) ) )
263
264(define (thread-resume! thread)
265  (##sys#check-structure thread 'thread 'thread-resume!)
266  (when (eq? (##sys#slot thread 3) 'suspended)
267    (##sys#setslot thread 3 'ready)
268    (##sys#add-to-ready-queue thread) ) )
269
270(define (thread-sleep! tm)
271  (define (sleep limit loc)
272    (##sys#call-with-current-continuation
273     (lambda (return)
274       (let ((ct ##sys#current-thread))
275         (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
276         (##sys#thread-block-for-timeout! ct limit)
277         (##sys#schedule) ) ) ) )
278  (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
279  (sleep (##sys#compute-time-limit tm) 'thread-sleep!) )
280
281
282;;; Mutexes:
283
284(define (mutex? x) (##sys#structure? x 'mutex))
285
286(define make-mutex
287  (let ((gensym gensym))
288    (lambda id
289      (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
290             (m (##sys#make-mutex id ##sys#current-thread)) )
291        m) ) ) )
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 (##sys#compute-time-limit (car ms-and-t)))]
316           [threadsup (fx> (length ms-and-t) 1)]
317           [thread (and threadsup (cadr ms-and-t))] 
318           [abd (##sys#slot mutex 4)] )
319      (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
320      (##sys#call-with-current-continuation
321       (lambda (return)
322         (let ([ct ##sys#current-thread])
323           (define (switch)
324             (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
325             (##sys#schedule) )
326           (define (check)
327             (when abd
328               (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
329           (dbg ct ": locking " mutex)
330           (cond [(not (##sys#slot mutex 5))
331                  (if (and threadsup (not thread))
332                      (begin
333                        (##sys#setislot mutex 2 #f)
334                        (##sys#setislot mutex 5 #t) )
335                      (let* ([t (or thread ct)]
336                             [ts (##sys#slot t 3)] )
337                        (if (or (eq? 'terminated ts) (eq? 'dead ts))
338                            (##sys#setislot mutex 4 #t)
339                            (begin
340                              (##sys#setislot mutex 5 #t)
341                              (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
342                              (##sys#setslot mutex 2 t) ) ) ) )
343                  (check)
344                  (return #t) ]
345                 [limit
346                  (check)
347                  (##sys#setslot
348                   ct 1 
349                   (lambda ()
350                     (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
351                     (unless (##sys#slot ct 13)  ; not unblocked by timeout
352                       (##sys#remove-from-timeout-list ct))
353                     (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
354                     (##sys#setslot mutex 2 thread)
355                     (return #f) ))
356                  (##sys#thread-block-for-timeout! ct limit)
357                  (switch) ]
358                 [else
359                  (##sys#setslot ct 3 'sleeping)
360                  (##sys#setslot ct 1 (lambda () (return #t)))
361                  (switch) ] ) ) ) ) ) ) )
362
363(define mutex-unlock!
364  (lambda (mutex . cvar-and-to)
365    (##sys#check-structure mutex 'mutex 'mutex-unlock!)
366    (let ([ct ##sys#current-thread]
367          [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
368          [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
369      (dbg ct ": unlocking " mutex)
370      (when cvar (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
371      (##sys#call-with-current-continuation
372       (lambda (return)
373         (let ([waiting (##sys#slot mutex 3)]
374               [limit (and timeout (##sys#compute-time-limit timeout))] 
375               [result #t] )
376           (##sys#setislot mutex 4 #f)
377           (##sys#setislot mutex 5 #f)
378           (##sys#setslot ct 8 (##sys#delq mutex (##sys#slot ct 8)))
379           (##sys#setslot ct 1 (lambda () (return result)))
380           (when cvar
381             (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
382             (cond [limit
383                    (##sys#setslot 
384                     ct 1
385                     (lambda () 
386                       (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
387                       (unless (##sys#slot ct 13)  ; not unblocked by timeout
388                         (##sys#remove-from-timeout-list ct))
389                       (return #f) ) )
390                    (##sys#thread-block-for-timeout! ct limit) ]
391                   [else
392                    (##sys#setslot ct 3 'sleeping)] ) )
393           (unless (null? waiting)
394             (let* ([wt (##sys#slot waiting 0)]
395                    [wts (##sys#slot wt 3)] )
396               (##sys#setslot mutex 3 (##sys#slot waiting 1))
397               (##sys#setislot mutex 5 #t)
398               (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
399                 (##sys#setslot mutex 2 wt)
400                 (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
401                 (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
402           (##sys#schedule) ) ) ) ) ) )
403
404
405;;; Condition variables:
406
407(define make-condition-variable
408  (let ([gensym gensym])
409    (lambda name
410      (##sys#make-structure
411       'condition-variable 
412       (if (pair? name)                 ; #1 name
413           (car name)
414           (gensym 'condition-variable) )
415       '()                              ; #2 list of waiting threads
416       (##core#undefined) ) ) ) )       ; #3 specific
417
418(define (condition-variable? x)
419  (##sys#structure? x 'condition-variable) )
420
421(define (condition-variable-specific cv)
422  (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
423  (##sys#slot cv 3) )
424
425(define (condition-variable-specific-set! cv x)
426  (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
427  (##sys#setslot cv 3 x) )
428
429(define (condition-variable-signal! cvar)
430  (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
431  (dbg "signalling " cvar)
432  (let ([ts (##sys#slot cvar 2)])
433    (unless (null? ts)
434      (let* ([t0 (##sys#slot ts 0)]
435             [t0s (##sys#slot t0 3)] )
436        (##sys#setslot cvar 2 (##sys#slot ts 1))
437        (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
438          (##sys#thread-basic-unblock! t0) ) ) ) ) )
439
440(define (condition-variable-broadcast! cvar)
441  (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
442  (dbg "broadcasting " cvar)
443  (##sys#for-each
444   (lambda (ti)
445     (let ([tis (##sys#slot ti 3)])
446       (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
447         (##sys#thread-basic-unblock! ti) ) ) )
448   (##sys#slot cvar 2) )
449  (##sys#setislot cvar 2 '()) )
450
451
452;;; Change continuation of thread to signal an exception:
453
454(define (thread-signal! thread exn)
455  (##sys#check-structure thread 'thread 'thread-signal!)
456  (if (eq? thread ##sys#current-thread)
457      (##sys#signal exn)
458      (let ([old (##sys#slot thread 1)])
459        (##sys#setslot
460         thread 1
461         (lambda ()
462           (##sys#signal exn)
463           (old) ) )
464        (##sys#thread-unblock! thread) ) ) )
465
466
467;;; Don't block in the repl: (by Chris Double)
468
469(unless (eq? (build-platform) 'msvc)
470  (set! ##sys#read-prompt-hook
471    (let ([old ##sys#read-prompt-hook]
472          [thread-yield! thread-yield!] )
473      (lambda ()
474        (when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
475          (old)
476          (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
477          (thread-yield!)))) ) )
478
479
480;;; Waiting for I/O on file-descriptor
481
482(define (thread-wait-for-i/o! fd #!optional (mode #:all))
483  (##sys#check-exact fd 'thread-wait-for-i/o!)
484  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode) 
485  (thread-yield!) )
Note: See TracBrowser for help on using the repository browser.