blob: 6a41583fd3f16e4db3c024521e7fc99c97e5b0ad (
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
;; Double-ended queue
;;;; Copyright (C) 2016 Andy Wingo <wingo@pobox.com>
;;;;
;;;; 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 deque)
#:use-module (srfi srfi-9)
#:use-module (ice-9 atomic)
#:use-module (ice-9 match)
#:export (make-deque
make-empty-deque
empty-deque?
enqueue
dequeue
dequeue-all
dequeue-match
undequeue
dequeue!
dequeue-all!
enqueue!))
;; A functional double-ended queue ("deque") has a head and a tail,
;; which are both lists. The head is in FIFO order and the tail is in
;; LIFO order.
(define-inlinable (make-deque head tail)
(cons head tail))
(define (make-empty-deque)
(make-deque '() '()))
(define (empty-deque? dq)
(match dq
((() . ()) #t)
(_ #f)))
(define (enqueue dq item)
(match dq
((head . tail)
(make-deque head (cons item tail)))))
;; -> new deque, val | #f, #f
(define (dequeue dq)
(match dq
((() . ()) (values #f #f))
((() . tail)
(dequeue (make-deque (reverse tail) '())))
(((item . head) . tail)
(values (make-deque head tail) item))))
(define (dequeue-all dq)
(match dq
((head . ()) head)
((head . tail) (append head (reverse tail)))))
(define (dequeue-match dq pred)
(match dq
((() . ()) (values #f #f))
((() . tail)
(dequeue (make-deque (reverse tail) '())))
(((item . head) . tail)
(if (pred item)
(values (make-deque head tail) item)
(call-with-values (dequeue-match (make-deque head tail) pred)
(lambda (dq item*)
(values (undequeue dq item) item*)))))))
(define (undequeue dq item)
(match dq
((head . tail)
(make-deque (cons item head) tail))))
(define-inlinable (update! box f)
(let spin ((x (atomic-box-ref box)))
(call-with-values (lambda () (f x))
(lambda (x* ret)
(if (eq? x x*)
ret
(let ((x** (atomic-box-compare-and-swap! box x x*)))
(if (eq? x x**)
ret
(spin x**))))))))
(define* (dequeue! dqbox #:optional default)
(update! dqbox (lambda (dq)
(call-with-values (lambda () (dequeue dq))
(lambda (dq* fiber)
(if dq*
(values dq* fiber)
(values dq default)))))))
(define (dequeue-all! dqbox)
(update! dqbox (lambda (dq)
(values (make-empty-deque)
(dequeue-all dq)))))
(define (enqueue! dqbox item)
(update! dqbox (lambda (dq)
(values (enqueue dq item)
#f))))
|
