blob: 8bdbea33de7da25bd168fafbfc2dc82732a813ea (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
;; Fibers: cooperative, event-driven user-space threads.
;;;; Copyright (C) 2016 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (fibers timers)
#:use-module (fibers scheduler)
#:use-module (fibers operations)
#:use-module (ice-9 atomic)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:export (sleep-operation
timer-operation)
#:replace (sleep))
(define *timer-sched* (make-atomic-box #f))
(define (timer-sched)
(or (atomic-box-ref *timer-sched*)
(let ((sched (make-scheduler)))
(cond
((atomic-box-compare-and-swap! *timer-sched* #f sched))
(else
;; FIXME: Would be nice to clean up this thread at some point.
(call-with-new-thread
(lambda ()
(define (finished?) #f)
(run-scheduler sched finished?)))
sched)))))
(define (timer-operation expiry)
"Make an operation that will succeed when the current time is
greater than or equal to @var{expiry}, expressed in internal time
units. The operation will succeed with no values."
(make-base-operation #f
(lambda ()
(and (< expiry (get-internal-real-time))
values))
(lambda (flag sched resume)
(define (timer)
(match (atomic-box-compare-and-swap! flag 'W 'S)
('W (resume values))
('C (timer))
('S #f)))
(if sched
(schedule-task-at-time sched expiry timer)
(schedule-task
(timer-sched)
(lambda ()
(perform-operation (timer-operation expiry))
(timer)))))))
(define (sleep-operation seconds)
"Make an operation that will succeed with no values when
@var{seconds} have elapsed."
(timer-operation
(+ (get-internal-real-time)
(inexact->exact
(round (* seconds internal-time-units-per-second))))))
(define (sleep seconds)
"Block the calling fiber until @var{seconds} have elapsed."
(perform-operation (sleep-operation seconds)))
|
