mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 06:39:17 +02:00
65 lines
1.7 KiB
Scheme
65 lines
1.7 KiB
Scheme
|
|
(define thread-yield! yield!)
|
|
|
|
(define (thread-join! thread . o)
|
|
(let ((timeout (if (pair? o) (car o) #f)))
|
|
(cond
|
|
((%thread-join! thread timeout))
|
|
(else
|
|
(thread-yield!)
|
|
(if (thread-timeout?)
|
|
(if (and (pair? o) (pair? (cdr o)))
|
|
(cadr o)
|
|
(error "timed out waiting for thread" thread))
|
|
#t)))))
|
|
|
|
(define (thread-terminate! thread)
|
|
(if (%thread-terminate! thread) ;; need to yield if terminating ourself
|
|
(thread-yield!)))
|
|
|
|
(define (thread-sleep! timeout)
|
|
(%thread-sleep! timeout)
|
|
(thread-yield!))
|
|
|
|
(define (mutex-lock! mutex . o)
|
|
(let ((timeout (and (pair? o) (car o)))
|
|
(thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t)))
|
|
(cond ((%mutex-lock! mutex timeout thread))
|
|
(else
|
|
(thread-yield!)
|
|
(not (thread-timeout?))))))
|
|
|
|
(define (mutex-unlock! mutex . o)
|
|
(let ((condvar (and (pair? o) (car o)))
|
|
(timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f)))
|
|
(cond ((%mutex-unlock! mutex condvar timeout))
|
|
(else
|
|
(thread-yield!)
|
|
(not (thread-timeout?))))))
|
|
|
|
(define current-time get-time-of-day)
|
|
(define time? timeval?)
|
|
|
|
(define (join-timeout-exception? x)
|
|
(and (exception? x)
|
|
(equal? (exception-message x) "timed out waiting for thread")))
|
|
|
|
;; XXXX flush out exception types
|
|
(define (abandoned-mutex-exception? x) #f)
|
|
(define (terminated-thread-exception? x) #f)
|
|
(define (uncaught-exception? x) #f)
|
|
(define (uncaught-exception-reason x) #f)
|
|
|
|
;; signal runner
|
|
|
|
(define (signal-runner)
|
|
(let lp ()
|
|
(let ((n (pop-signal!)))
|
|
(cond
|
|
((integer? n)
|
|
(let ((handler (get-signal-handler n)))
|
|
(if (procedure? handler)
|
|
(handler n))))
|
|
(else
|
|
(thread-sleep! #t))))
|
|
(lp)))
|