mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
74 lines
2.1 KiB
Scheme
74 lines
2.1 KiB
Scheme
|
|
(define current-time get-time-of-day)
|
|
(define (time? x) (timeval? (if (pair? x) (car x) x)))
|
|
|
|
(define (time->seconds x)
|
|
(timeval-seconds (if (pair? x) (car x) x)))
|
|
|
|
(define (seconds->time x)
|
|
(make-timeval (if (inexact? x) (inexact->exact (round x)) x) 0))
|
|
|
|
(define (timeout->seconds x)
|
|
(if (time? x) (- (time->seconds x) (time->seconds (current-time))) x))
|
|
|
|
(define thread-yield! yield!)
|
|
|
|
(define (thread-join! thread . o)
|
|
(let ((timeout (if (pair? o) (car o) #f)))
|
|
(cond
|
|
((%thread-join! thread (timeout->seconds 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->seconds 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->seconds 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->seconds timeout)))
|
|
(else
|
|
(thread-yield!)
|
|
(not (thread-timeout?))))))
|
|
|
|
(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)))
|