source: project/chicken/branches/chicken-3/srfi-18.scm @ 13411

Last change on this file since 13411 was 13411, checked in by Ivan Raikov, 11 years ago

Reverted srfi-18.scm to that of Chicken 3.4.0

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