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

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

defaults.make : chking of svnrev sep from svnrev fil as a target
lolevel.scm : comment fix
runtime.c : use of C defines for platform info, reflow of some comments/code due to > 100 chars long, cl -> closure (like other procs), use of macros rather than open-coded block access, added return value testing for FreeLibrary? & shl_unlaod.
library.scm : refactored make-property-condition & condition-property-accessor so ##sy# routine available, make ##sys# routines for breakpoint condition, placed 'continuation, etc, on breakpoint condition & not exn.
chicken.h : use of C defines for platform info, added comments, C_CHAR_SHIFT.
posixunix.scm, posixwin.scm : added use of Unit ports
scheduler.scm : use of library breakpoint condition routines, placed 'continuation, etc, on breakpoint condition & not exn
srfi-18.scm : renamed some -inlines (match chicken-thread-object-inlines)

File size: 23.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#timeout->limit ##sys#sleep-current-thread) )
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     condition? condition-predicate signal
44     ##sys#thread-yield!
45     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
46     ##sys#thread-basic-unblock! gensym ##sys#thread-block-for-timeout! ##sys#thread-kill!
47     ##sys#thread-block-for-termination! make-thread ##sys#exact->inexact ##sys#flonum-fraction truncate
48     ##sys#add-to-ready-queue
49     ##sys#schedule ##sys#make-thread
50     ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
51     ##sys#current-exception-handler ##sys#check-structure ##sys#structure? ##sys#make-mutex
52     ##sys#delq ##sys#timeout->limit ##sys#fudge) ) ] )
53
54(cond-expand
55 [unsafe
56  (eval-when (compile)
57    (define-macro (##sys#check-structure . _) '(##core#undefined))
58    (define-macro (##sys#check-range . _) '(##core#undefined))
59    (define-macro (##sys#check-pair . _) '(##core#undefined))
60    (define-macro (##sys#check-list . _) '(##core#undefined))
61    (define-macro (##sys#check-symbol . _) '(##core#undefined))
62    (define-macro (##sys#check-string . _) '(##core#undefined))
63    (define-macro (##sys#check-char . _) '(##core#undefined))
64    (define-macro (##sys#check-exact . _) '(##core#undefined))
65    (define-macro (##sys#check-port . _) '(##core#undefined))
66    (define-macro (##sys#check-number . _) '(##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;;; Helpers
78
79(define-inline (%append-item ls x)
80  (##sys#append ls (list x)) )
81
82
83;;; Time object helpers:
84
85;; Time layout:
86;
87; Clock time is since Unix-epoch (Jan 1, 1970 00:00 am) since C Library routines are used.
88;
89; 0     Tag - 'time (symbol)
90; 1     Milliseconds since startup (fixnum)
91; 2     Seconds (integer)
92; 3     Milliseconds (fixnum)
93
94(define-inline (%time? x)
95  (##sys#structure? x 'time) )
96
97(define-inline (%time-timeout tm)
98  (##sys#slot tm 1) )
99
100(define-inline (%time-seconds tm)
101  (##sys#slot tm 2) )
102
103(define-inline (%time-milliseconds tm)
104  (##sys#slot tm 3) )
105
106(define-inline (%check-time x loc)
107  (##sys#check-structure x 'time loc) )
108
109; Enforces the representation constraints
110(define-inline (%make-time nms s ms)
111  (##sys#make-structure 'time
112   (inexact->exact (truncate nms))
113   (truncate s)
114   (inexact->exact (truncate ms))) )
115
116
117;;; Thread object helpers:
118
119;; Thread layout:
120;
121; 0     Tag - 'thread
122; 1     Thunk (procedure)
123; 2     Results (list-of object)
124; 3     State (symbol)
125; 4     Block-timeout (fixnum or #f)
126; 5     State buffer (vector)
127;       0       Dynamic winds (list)
128;       1       Standard input (port)
129;       2       Standard output (port)
130;       3       Standard error (port)
131;       4       Exception handler (procedure)
132;       5       Parameters (vector)
133; 6     Name (object)
134; 7     Reason (condition of #f)
135; 8     Mutexes (list-of mutex)
136; 9     Quantum (fixnum)
137; 10    Specific (object)
138; 11    Block object (thread or (pair-of fd io-mode))
139; 12    Recipients (list-of thread)
140; 13    Unblocked by timeout? (boolean)
141
142(define-inline (%thread? x)
143  (##sys#structure? x 'thread) )
144
145(define-inline (%thread-thunk th)
146  (##sys#slot th 1) )
147
148(define-inline (%thread-thunk-set! th tk)
149  (##sys#setslot th 1 tk) )
150
151(define-inline (%thread-results th)
152  (##sys#slot th 2) )
153
154(define-inline (%thread-results-set! th rs)
155  (##sys#setslot th 2 rs) )
156
157(define-inline (%thread-state th)
158  (##sys#slot th 3) )
159
160(define-inline (%thread-state-set! th st)
161  (##sys#setslot th 3 st) )
162
163(define-inline (%thread-block-timeout th)
164  (##sys#slot th 4) )
165
166(define-inline (%thread-block-timeout-set! th to)
167  (##sys#setislot th 4 to) )
168
169(define-inline (%thread-block-timeout-clear! th)
170  (%thread-block-timeout-set! th #f) )
171
172(define-inline (%thread-state-buffer th)
173  (##sys#slot th 5) )
174
175(define-inline (%thread-state-buffer-set! th v)
176  (##sys#setslot th 5 v) )
177
178(define-inline (%thread-name th)
179  (##sys#slot th 6) )
180
181(define-inline (%thread-reason th)
182  (##sys#slot th 7) )
183
184(define-inline (%thread-reason-set! th cd)
185  (##sys#setslot th 7 cd) )
186
187(define-inline (%thread-mutexes th)
188  (##sys#slot th 8) )
189
190(define-inline (%thread-mutexes-set! th wt)
191  (##sys#setslot th 8 wx) )
192
193(define-inline (%thread-mutexes-empty? th)
194  (null? (%thread-mutexes th)) )
195
196(define-inline (%thread-mutexes-empty! th)
197  (##sys#setislot th 8 '()) )
198
199(define-inline (%thread-mutexes-add! th mx)
200  (%thread-mutexes-set! th (cons mx (%thread-mutexes th))) )
201
202(define-inline (%thread-mutexes-delete! th mx)
203  (%thread-mutexes-set! th (##sys#delq mx (%thread-mutexes th))) )
204
205(define-inline (%thread-quantum th)
206  (##sys#slot th 9) )
207
208(define-inline (%thread-quantum-set! th qt)
209  (##sys#setislot th 9 qt) )
210
211(define-inline (%thread-specific th)
212  (##sys#slot th 10) )
213
214(define-inline (%thread-specific-set! th x)
215  (##sys#setslot th 10 x) )
216
217(define-inline (%thread-block-object th)
218  (##sys#slot th 11) )
219
220(define-inline (%thread-block-object-set! th x)
221  (##sys#setslot th 11 x) )
222
223(define-inline (%thread-block-object-clear! th)
224  (##sys#setislot th 11 #f) )
225
226(define-inline (%thread-recipients th)
227  (##sys#slot th 12) )
228
229(define-inline (%thread-recipients-set! th x)
230  (##sys#setslot th 12 x) )
231
232(define-inline (%thread-recipients-empty! th)
233  (##sys#setislot th 12 '()) )
234
235(define-inline (%thread-recipients-add! th rth)
236  (%thread-recipients-set! t (cons rth (%thread-recipients t))) )
237
238(define-inline (%thread-recipients-process! th tk)
239  (let ([rs (%thread-recipients t)])
240    (unless (null? rs) (for-each tk rs) ) )
241  (thread-recipients-empty! t) )
242
243(define-inline (%thread-unblocked-by-timeout? th)
244  (##sys#slot th 13) )
245
246(define-inline (%thread-unblocked-by-timeout-set! th f)
247  (##sys#setislot th 13 f) )
248
249(define-inline (%make-thread nm tk #!optional (qt (%thread-quantum ##sys#current-thread)))
250  (##sys#make-thread tk 'created nm qt) )
251
252(define-inline (%check-thread x loc)
253  (##sys#check-structure x 'thread loc) )
254
255
256;;; Mutex object helpers:
257
258;; Mutex layout:
259;
260; 0     Tag - 'mutex
261; 1     Name (object)
262; 2     Thread (thread or #f)
263; 3     Waiting threads (FIFO list)
264; 4     Abandoned? (boolean)
265; 5     Locked? (boolean)
266; 6     Specific (object)
267
268(define-inline (%mutex? x)
269  (##sys#structure? x 'mutex) )
270
271(define-inline (%mutex-name mx)
272  (##sys#slot mx 1) )
273
274(define-inline (%mutex-thread mx)
275  (##sys#slot mx 2) )
276
277(define-inline (%mutex-thread-set! mx th)
278  (##sys#setslot mx 2 th) )
279
280(define-inline (%mutex-thread-clear! mx)
281  (##sys#setislot mx 2 #f) )
282
283(define-inline (%mutex-waiters mx)
284  (##sys#slot mx 3) )
285
286(define-inline (%mutex-waiters-set! mx wt)
287  (##sys#setslot mx 3 wt) )
288
289(define-inline (%mutex-waiters-add! mx th)
290  (%mutex-waiters-set! mx (%append-item (%mutex-waiters mx) th)) )
291
292(define-inline (%mutex-waiters-delete! mx th)
293  (%mutex-waiters-set! mx (##sys#delq th (%mutex-waiters mx))) )
294
295(define-inline (%mutex-waiters-empty? mx)
296  (null? (%mutex-waiters mx)) )
297
298(define-inline (%mutex-waiters-empty! mx)
299  (##sys#setislot mx 3 '()) )
300
301(define-inline (%mutex-waiters-pop! mx)
302  (let* ([wt (%mutex-waiters mx)]
303         [top (car wt)])
304    (%mutex-waiters-set! mx (cdr wt))
305    top ) )
306
307(define-inline (%mutex-abandoned? mx)
308  (##sys#slot mx 4) )
309
310(define-inline (%mutex-abandoned-set! mx f)
311  (##sys#setislot mx 4 f) )
312
313(define-inline (%mutex-locked? mx)
314  (##sys#slot mx 5) )
315
316(define-inline (%mutex-locked-set! mx f)
317  (##sys#setislot mx 5 f) )
318
319(define-inline (%mutex-specific mx)
320  (##sys#slot mx 6) )
321
322(define-inline (%mutex-specific-set! mx x)
323  (##sys#setslot mx 6 x) )
324
325(define-inline (%make-mutex id)
326  (##sys#make-mutex id ##sys#current-thread) )
327
328(define-inline (%check-mutex x loc)
329  (##sys#check-structure x 'mutex loc) )
330
331
332;;; Condition-variable object:
333
334;; Condition-variable layout:
335;
336; 0     Tag - 'condition-variable
337; 1     Name (object)
338; 2     Waiting threads (FIFO list)
339; 3     Specific (object)
340
341(define-inline (%condition-variable? x)
342  (##sys#structure? x 'condition-variable) )
343
344(define-inline (%condition-variable-name cv)
345  (##sys#slot cv 1) )
346
347(define-inline (%condition-variable-waiters cv)
348  (##sys#slot cv 2) )
349
350(define-inline (%condition-variable-waiters-set! cv x)
351  (##sys#setslot cv 2 x) )
352
353(define-inline (%condition-variable-waiters-add! cv th)
354  (%condition-variable-waiters-set! cv (%append-item (%condition-variable-waiters cv) th)) )
355
356(define-inline (%condition-variable-waiters-delete! cv th)
357  (%condition-variable-waiters-set! cv (##sys#delq th (%condition-variable-waiters cv))) )
358
359(define-inline (%condition-variable-waiters-empty? mx)
360  (null? (%condition-variable-waiters mx)) )
361
362(define-inline (%condition-variable-waiters-pop! mx)
363  (let* ([wt (%condition-variable-waiters mx)]
364         [top (car wt)])
365    (%condition-variable-waiters-set! mx (cdr wt))
366    top ) )
367
368(define-inline (%condition-variable-waiters-clear! cv)
369  (##sys#setislot cv 2 '()) )
370
371(define-inline (%condition-variable-specific cv)
372  (##sys#slot cv 3) )
373
374(define-inline (%condition-variable-specific-set! cv x)
375  (##sys#setslot cv 3 x) )
376
377(define-inline (%make-condition-variable nm #!optional (wt '()) (sp (void)))
378  (##sys#make-structure 'condition-variable nm wt sp) )
379
380(define-inline (%check-condition-variable x loc)
381    (##sys#check-structure x 'condition-variable loc) )
382
383
384;;; Time objects:
385
386#>
387static C_TLS long C_ms;
388#define C_get_seconds   C_seconds(&C_ms)
389<#
390
391(define-foreign-variable C_startup_time_seconds double)
392(define-foreign-variable C_get_seconds double)
393(define-foreign-variable C_ms long)
394
395(define-inline (%seconds-since-startup s)
396  (max 0 (- s C_startup_time_seconds)) )
397
398(define-inline (%seconds-after-startup s)
399  (max 0 (+ s C_startup_time_seconds)) )
400
401(define-inline (%seconds->milliseconds s)
402  (* (##sys#flonum-fraction (##sys#exact->inexact s)) 1000) )
403
404(define-inline (%milliseconds->seconds ms)
405  (/ ms 1000) )
406
407(define-inline (%milliseconds-since-startup s)
408  (%seconds->milliseconds (%seconds-since-startup s)) )
409
410(define ##sys#timeout->limit
411  (let ([truncate truncate])
412    (lambda (tm loc)
413      (and tm
414           (cond [(%time? tm)
415                  (%time-timeout tm) ]
416                 [(number? tm)
417                  (fx+ (##sys#fudge 16)
418                       (inexact->exact (truncate (%seconds->milliseconds tm)))) ]
419                 [else
420                  (##sys#signal-hook
421                   #:type-error loc "bad argument type - invalid timeout object" tm) ] ) ) ) ) )
422
423(define (current-time)
424  (let* ([s C_get_seconds]
425         [ms C_ms])
426    (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
427
428(define (time->seconds tm)
429  (%check-time tm 'time->seconds)
430  (+ (%time-seconds tm) (%milliseconds->seconds (%time-milliseconds tm))) )
431
432(define (seconds->time s)
433  (##sys#check-number s 'seconds->time)
434  (let ([ms (%seconds->milliseconds s)]) ; milliseconds since startup
435    (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
436
437(define (time->milliseconds tm)
438  (%check-time tm 'time->milliseconds)
439  (+ (%milliseconds-since-startup (%time-seconds tm)) (%time-milliseconds tm)) )
440
441(define (milliseconds->time nms)
442  (##sys#check-integer nms 'milliseconds->time)
443  (let ([s (%milliseconds->seconds nms)])
444    (%make-time nms (%seconds-after-startup s) (%seconds->milliseconds s)) ) )
445
446(define (time? x) (%time? x))
447
448;; For SRFI-19 identifier conflict
449
450(define srfi-18:current-time current-time)
451(define srfi-18:time? time?)
452
453
454;;; Exception handling:
455
456(define raise signal)
457
458(define join-timeout-exception? (condition-predicate 'join-timeout-exception))
459
460(define abandoned-mutex-exception? (condition-predicate 'join-timeout-exception))
461
462(define terminated-thread-exception? (condition-predicate 'terminated-thread-exception))
463
464(define uncaught-exception? (condition-predicate 'uncaught-exception))
465
466(define uncaught-exception-reason (condition-property-accessor 'uncaught-exception 'reason))
467
468
469;;; Threads:
470
471(define make-thread)
472(let ([gensym gensym])
473  (set! make-thread
474    (lambda (thunk #!optional (name (gensym 'thread)))
475      (##sys#check-closure thunk 'make-thread)
476      (%make-thread
477       name
478       (lambda ()
479         (##sys#call-with-values
480          thunk
481          (lambda results
482            (%thread-results-set! thread results)
483            (##sys#thread-kill! thread 'dead)
484            (##sys#schedule))))))) )
485
486(define (thread? x) (%thread x))
487
488(define (current-thread) ##sys#current-thread)
489
490(define (thread-state thread)
491  (%check-thread thread 'thread-state)
492  (%thread-state thread) )
493
494(define (thread-specific thread)
495  (%check-thread thread 'thread-specific)
496  (%thread-specific thread) )
497
498(define (thread-specific-set! thread x)
499  (%check-thread thread 'thread-specific-set!)
500  (%thread-specific-set! thread x) )
501
502(define (thread-quantum thread)
503  (%check-thread thread 'thread-quantum)
504  (%thread-quantum thread) )
505
506(define (thread-quantum-set! thread q)
507  (%check-thread thread 'thread-quantum-set!)
508  (##sys#check-exact q 'thread-quantum-set!)
509  (%thread-quantum-set! thread (fxmax q 10)) )
510
511(define (thread-name x)
512  (%check-thread x 'thread-name)
513  (%thread-name x) )
514
515(define thread-start!
516  (let ([make-thread make-thread])
517    (lambda (thread)
518      (if (procedure? thread)
519          (set! thread (make-thread thread))
520          (%check-thread thread 'thread-start!) )
521      (unless (eq? 'created (%thread-state thread))
522        (##sys#error 'thread-start! "thread already started" thread) )
523      (%thread-state-set! thread 'ready)
524      (##sys#add-to-ready-queue thread)
525      thread ) ) )
526
527(define thread-yield! ##sys#thread-yield!) ;In library.scm
528
529(define (thread-join! thread #!optional timeout timeout-val)
530  (%check-thread thread 'thread-join!)
531  (let ([limit (and timeout (##sys#timeout->limit timeout 'thread-join!))])
532    (##sys#call-with-current-continuation
533     (lambda (return)
534       (let ([ct ##sys#current-thread])
535         (when limit (##sys#thread-block-for-timeout! ct limit))
536         (%thread-thunk-set! ct
537          (lambda ()
538            (case (%thread-state thread)
539              [(dead)
540               (apply return (%thread-results thread))]
541              [(terminated)
542               (return
543                (signal
544                 (make-property-condition 'uncaught-exception 'reason (%thread-reason thread)))) ]
545              [else
546               (return
547                (or timeout-val
548                    (signal (make-property-condition 'join-timeout-exception)))) ] ) ) )
549         (##sys#thread-block-for-termination! ct thread)
550         (##sys#schedule) ) ) ) ) )
551
552(define (thread-terminate! thread)
553  (%check-thread thread 'thread-terminate!)
554  (when (eq? ##sys#primordial-thread thread) ((##sys#exit-handler)) )
555  (%thread-results-set! thread (list (void)))
556  (%thread-reason-set! thread (make-property-condition 'terminated-thread-exception))
557  (##sys#thread-kill! thread 'terminated)
558  (when (eq? ##sys#current-thread thread) (##sys#schedule)) )
559
560(define (thread-suspend! thread)
561  (%check-thread thread 'thread-suspend!)
562  (%thread-state-set! thread 'suspended)
563  (when (eq? ##sys#current-thread thread)
564    (##sys#call-with-current-continuation
565     (lambda (return)
566       (%thread-thunk-set! thread (lambda () (return (void))))
567       (##sys#schedule) ) ) ) )
568
569(define (thread-resume! thread)
570  (%check-thread thread 'thread-resume!)
571  (when (eq? 'suspended (%thread-state thread))
572    (%thread-state-set! thread 'ready)
573    (##sys#add-to-ready-queue thread) ) )
574
575(define (##sys#sleep-current-thread limit)
576  (##sys#call-with-current-continuation
577   (lambda (return)
578     (let ([ct ##sys#current-thread])
579       (%thread-thunk-set! ct (lambda () (return (void))))
580       (##sys#thread-block-for-timeout! ct limit)
581       (##sys#schedule) ) ) ) )
582
583(define (thread-sleep! timeout)
584  (##sys#sleep-current-thread (##sys#timeout->limit timeout 'thread-sleep!)) )
585
586
587;;; Change continuation of thread to signal an exception:
588
589(define (thread-signal! thread exn)
590  (%check-thread thread 'thread-signal!)
591  (if (eq? ##sys#current-thread thread)
592      (signal exn)
593      (let ([old (%thread-thunk thread)])
594        (%thread-thunk-set! thread (lambda () (signal exn) (old)))
595        (##sys#thread-unblock! thread) ) ) )
596
597
598;;; Waiting for I/O on file-descriptor
599
600(define (thread-wait-for-i/o! fd #!optional (mode #:all))
601  (##sys#check-exact fd 'thread-wait-for-i/o!)
602  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
603  (thread-yield!) )
604
605
606;;; Mutexes:
607
608(define make-mutex)
609(let ([gensym gensym])
610  (set! make-mutex
611    (lambda (#!optional (id (gensym 'mutex)))
612      (%make-mutex id) ) ) )
613
614(define (mutex? x) (%mutex x))
615
616(define (mutex-name mutex)
617  (%check-mutex mutex 'mutex-specific)
618  (%mutex-name mutex) )
619
620(define (mutex-specific mutex)
621  (%check-mutex mutex 'mutex-specific)
622  (%mutex-specific mutex) )
623
624(define (mutex-specific-set! mutex x)
625  (%check-mutex mutex 'mutex-specific-set!)
626  (%mutex-specific-set! mutex x) )
627
628(define (mutex-state mutex)
629  (%check-mutex mutex 'mutex-state)
630  (cond [(%mutex-locked? mutex)    (or (%mutex-thread mutex) 'not-owned)]
631        [(%mutex-abandoned? mutex) 'abandoned]
632        [else                      'not-abandoned] ) )
633
634(define (mutex-lock! mutex #!optional timeout (thread (void)))
635  (%check-mutex mutex 'mutex-lock!)
636  (let* ([limit (and timeout (##sys#timeout->limit timeout 'mutex-lock!))]
637         [threadsup (not (eq? (void) thread))]
638         [thread (and threadsup thread)]
639         [abd (%mutex-abandoned? mutex)] )
640    (when thread (%check-thread thread 'mutex-lock!))
641    (##sys#call-with-current-continuation
642     (lambda (return)
643       (let ([ct ##sys#current-thread])
644         (define (switch)
645           (%mutex-waiters-add! mutex ct)
646           (##sys#schedule) )
647         (define (check)
648           (when abd
649             (return (signal (make-property-condition 'abandoned-mutex-exception))) ) )
650         (dbg ct ": locking " mutex)
651         (cond [(not (%mutex-locked? mutex))
652                (if (and threadsup (not thread))
653                    (begin
654                      (%mutex-thread-clear! mutex)
655                      (%mutex-locked-set! mutex #t) )
656                    (let* ([th (or thread ct)]
657                           [ts (%thread-state th)] )
658                      (if (or (eq?'terminated ts) (eq? 'dead ts))
659                          (%mutex-abandoned-set! mutex #t)
660                          (begin
661                            (%mutex-locked-set! mutex #t)
662                            (%thread-mutexes-add! th mutex)
663                            (%mutex-thread-set! mutex th) ) ) ) )
664                (check)
665                (return #t) ]
666               [limit
667                (check)
668                (%thread-thunk-set! ct
669                 (lambda ()
670                   (%mutex-waiters-delete! mutex ct)
671                   (%thread-mutexes-add! ##sys#current-thread mutex)
672                   (%mutex-thread-set! mutex thread)
673                   #f))
674                (##sys#thread-block-for-timeout! ct limit)
675                (switch) ]
676               [else
677                (%thread-state-set! ct 'sleeping)
678                (%thread-thunk-set! ct (lambda () (return #t)))
679                (switch) ] ) ) ) ) ) )
680
681(define (mutex-unlock! mutex #!optional cv timeout)
682  (%check-mutex mutex 'mutex-unlock!)
683  (let ([ct ##sys#current-thread])
684    (dbg ct ": unlocking " mutex)
685    (##sys#call-with-current-continuation
686     (lambda (return)
687       (let ([limit (and timeout (##sys#timeout->limit timeout 'mutex-unlock!))]
688             [result #t] )
689         (%mutex-abandoned-set! mutex #f)
690         (%mutex-locked-set! mutex #f)
691         (%thread-mutexes-delete! ct mutex)
692         (%thread-thunk-set! ct (lambda () (return result)))
693         (when cv
694           (%check-condition-variable cv 'mutex-unlock!)
695           (%condition-variable-waiters-add! cv ct)
696           (cond [limit
697                  (%thread-thunk-set! ct
698                   (lambda ()
699                     (%condition-variable-waiters-delete! cv ct)
700                     (return #f)))
701                  (##sys#thread-block-for-timeout! ct limit) ]
702                 [else
703                  (%thread-state-set! ct 'sleeping) ] ) )
704         (unless (%mutex-waiters-empty? mutex)
705           (let* ([wt (%mutex-waiters-pop! mutex)]
706                  [wts (%thread-state wt)] )
707             (%mutex-locked-set! mutex #t)
708             (when (or (eq? 'blocked wts) (eq? 'sleeping wts))
709               (%mutex-thread-set! mutex wt)
710               (%thread-mutexes-add! wt mutex)
711               (when (eq? 'sleeping wts) (##sys#add-to-ready-queue wt) ) ) ) )
712         (##sys#schedule) ) ) ) ) )
713
714
715;;; Condition variables:
716
717(define make-condition-variable)
718(let ([gensym gensym])
719  (set! make-condition-variable
720    (lambda (#!optional (name (gensym 'condition-variable)))
721      (%make-condition-variable name))) )
722
723(define (condition-variable? x) (%condition-variable? x) )
724
725(define (condition-variable-name cv)
726  (%check-condition-variable cv 'condition-variable-name)
727  (%condition-variable-name cv) )
728
729(define (condition-variable-specific cv)
730  (%check-condition-variable cv 'condition-variable-specific)
731  (%condition-variable-specific cv) )
732
733(define (condition-variable-specific-set! cv x)
734  (%check-condition-variable cv 'condition-variable-specific-set!)
735  (%condition-variable-specific-set! cv x) )
736
737(define (condition-variable-signal! cv)
738  (%check-condition-variable cv 'condition-variable-signal!)
739  (dbg "signalling " cv)
740  (unless (%condition-variable-waiters-empty? cv)
741    (let* ([t0 (%condition-variable-waiters-pop! cv)]
742           [t0s (%thread-state t0)] )
743      (when (or (eq? 'blocked t0s) (eq? 'sleeping t0s))
744        (##sys#thread-basic-unblock! t0) ) ) ) )
745
746(define (condition-variable-broadcast! cv)
747  (%check-condition-variable cv 'condition-variable-broadcast!)
748  (dbg "broadcasting " cv)
749  (##sys#for-each
750   (lambda (ti)
751     (let ([tis (%thread-state ti)])
752       (when (or (eq? 'blocked tis) (eq? 'sleeping tis))
753         (##sys#thread-basic-unblock! ti) ) ) )
754   (%condition-variable-waiters cv) )
755  (%condition-variable-waiters-clear! cv) )
756
757
758;;; Don't block in the repl: (by Chris Double)
759
760(unless (eq? 'msvc (build-platform))
761  (set! ##sys#read-prompt-hook
762    (let ([old ##sys#read-prompt-hook]
763          [thread-yield! thread-yield!] )
764      (lambda ()
765        (when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
766          (old)
767          (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
768          (thread-yield!)))) ) )
Note: See TracBrowser for help on using the repository browser.