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

Last change on this file since 14940 was 13138, checked in by Kon Lovett, 11 years ago

Chgd "can not" to "cannot" - saves bytes you know ;-)

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