1 ;;;; Occam-like channels
3 ;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 2.1 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (ice-9 occam-channel)
20 #:use-syntax (ice-9 syncase)
21 #:use-module (oop goops)
22 #:use-module (ice-9 threads)
25 oc:lock oc:unlock oc:consequence
26 oc:immediate-dispatch oc:late-dispatch oc:first-channel
27 oc:set-handshake-channel oc:unset-handshake-channel)
28 #:export (make-channel
33 handshake-channel mutex
35 immediate-receive late-receive
39 (define no-data '(no-data))
40 (define receiver-waiting '(receiver-waiting))
42 (define-class <channel> ())
44 (define-class <data-channel> (<channel>)
45 (handshake-channel #:accessor handshake-channel)
46 (data #:accessor data #:init-value no-data)
47 (cv #:accessor cv #:init-form (make-condition-variable))
48 (mutex #:accessor mutex #:init-form (make-mutex)))
50 (define-method (initialize (ch <data-channel>) initargs)
52 (set! (handshake-channel ch) ch))
54 (define-method (make-channel)
55 (make <data-channel>))
57 (define-method (sender-waiting? (ch <data-channel>))
58 (not (eq? (data ch) no-data)))
60 (define-method (receiver-waiting? (ch <data-channel>))
61 (eq? (data ch) receiver-waiting))
63 (define-method (immediate-receive (ch <data-channel>))
64 (signal-condition-variable (cv ch))
65 (let ((res (data ch)))
66 (set! (data ch) no-data)
69 (define-method (late-receive (ch <data-channel>))
70 (let ((res (data ch)))
71 (set! (data ch) no-data)
74 (define-method (? (ch <data-channel>))
75 (lock-mutex (mutex ch))
76 (let ((res (cond ((receiver-waiting? ch)
77 (unlock-mutex (mutex ch))
78 (scm-error 'misc-error '?
79 "another process is already receiving on ~A"
82 (immediate-receive ch))
84 (set! (data ch) receiver-waiting)
85 (wait-condition-variable (cv ch) (mutex ch))
87 (unlock-mutex (mutex ch))
90 (define-method (! (ch <data-channel>))
93 (define-method (! (ch <data-channel>) (x <top>))
94 (lock-mutex (mutex (handshake-channel ch)))
95 (cond ((receiver-waiting? ch)
97 (signal-condition-variable (cv (handshake-channel ch))))
99 (unlock-mutex (mutex (handshake-channel ch)))
100 (scm-error 'misc-error '! "another process is already sending on ~A"
104 (wait-condition-variable (cv ch) (mutex ch))))
105 (unlock-mutex (mutex (handshake-channel ch))))
109 (define-class <port-channel> (<channel>)
110 (port #:accessor port #:init-keyword #:port))
112 (define-method (make-channel (port <port>))
113 (make <port-channel> #:port port))
115 (define-method (? (ch <port-channel>))
118 (define-method (! (ch <port-channel>))
121 (define-class <timer-channel> (<channel>))
123 (define the-timer (make <timer-channel>))
125 (define timer-cv (make-condition-variable))
126 (define timer-mutex (make-mutex))
131 (define (timeofday->us t)
132 (+ (* 1000000 (car t)) (cdr t)))
134 (define (us->timeofday n)
135 (cons (quotient n 1000000)
136 (remainder n 1000000)))
138 (define-method (? (ch <timer-channel>))
139 (timeofday->us (gettimeofday)))
141 (define-method (? (ch <timer-channel>) (t <integer>))
142 (lock-mutex timer-mutex)
143 (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
144 (unlock-mutex timer-mutex))
148 ;;; CLAUSE ::= ((? CH) FORM ...)
149 ;;; | (EXP (? CH) FORM ...)
152 ;;; where FORM ... can be => (lambda (x) ...)
154 ;;; *fixme* Currently only handles <data-channel>:s
157 (define-syntax oc:lock
159 ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
160 ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
161 ((_ (exp form ...)) #f)))
163 (define-syntax oc:unlock
165 ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
166 ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
167 ((_ (exp form ...)) #f)))
169 (define-syntax oc:consequence
172 ((_ data => (lambda (x) e1 e2 ...))
173 (let ((x data)) e1 e2 ...))
175 (begin data e1 e2 ...))))
177 (define-syntax oc:immediate-dispatch
180 ((sender-waiting? ch)
181 (oc:consequence (immediate-receive ch) e1 ...)))
182 ((_ (exp (? ch) e1 ...))
183 ((and exp (sender-waiting? ch))
184 (oc:consequence (immediate-receive ch) e1 ...)))
188 (define-syntax oc:late-dispatch
191 ((sender-waiting? ch)
192 (oc:consequence (late-receive ch) e1 ...)))
193 ((_ (exp (? ch) e1 ...))
194 ((and exp (sender-waiting? ch))
195 (oc:consequence (late-receive ch) e1 ...)))
199 (define-syntax oc:first-channel
201 ((_ ((? ch) e1 ...) c2 ...)
203 ((_ (exp (? ch) e1 ...) c2 ...)
206 (first-channel c2 ...))))
208 (define-syntax oc:set-handshake-channel
210 ((_ ((? ch) e1 ...) handshake)
211 (set! (handshake-channel ch) handshake))
212 ((_ (exp (? ch) e1 ...) handshake)
213 (and exp (set! (handshake-channel ch) handshake)))
214 ((_ (exp e1 ...) handshake)
217 (define-syntax oc:unset-handshake-channel
220 (set! (handshake-channel ch) ch))
221 ((_ (exp (? ch) e1 ...))
222 (and exp (set! (handshake-channel ch) ch)))
228 (define (else-clause? x)
229 (syntax-case x (else)
231 ((_ (else e1 e2 ...)) #t)
232 ((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))
234 (syntax-case x (else)
240 (let ((res (cond (oc:immediate-dispatch c1)
241 (oc:immediate-dispatch c2) ...)))
249 (let ((res (cond (oc:immediate-dispatch c1)
250 (oc:immediate-dispatch c2) ...
251 (else (let ((ch (oc:first-channel c1 c2 ...)))
252 (oc:set-handshake-channel c1 ch)
253 (oc:set-handshake-channel c2 ch) ...
254 (wait-condition-variable (cv ch)
256 (oc:unset-handshake-channel c1)
257 (oc:unset-handshake-channel c2) ...
258 (cond (oc:late-dispatch c1)
259 (oc:late-dispatch c2) ...))))))