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

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

trunk/posixwin.scm : unimplimented is syntax
trunk/runtime.c : nl btwn computation & return is distracting
lolevel.scm : added type check helpers
library.scm : moved '##sys#abandon-mutexes' to schedular
posixunix.scm : rmvd some unused decls
schedular.scm : added '##sys#abandon-mutexes' since only used here
tests/runtests.sh : added no init
runtime.c : added "true unix" fudge, rmvd host PCRE fudge
srfi-18 : added OO-procedures - the algorithms read much easier now

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