guile18/ice-9/occam-channel.scm

   1 ;;;; Occam-like channels
   2
   3 ;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
   4 ;;;
   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.
   9 ;;
  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.
  14 ;;
  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
  18
  19 (define-module (ice-9 occam-channel)
  20   #:use-syntax (ice-9 syncase)
  21   #:use-module (oop goops)
  22   #:use-module (ice-9 threads)
  23   #:export-syntax (alt
  24                    ;; macro use:
  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
  29             ?
  30             !
  31             make-timer
  32             ;; macro use:
  33             handshake-channel mutex
  34             sender-waiting?
  35             immediate-receive late-receive
  36             )
  37   )
  38
  39 (define no-data '(no-data))
  40 (define receiver-waiting '(receiver-waiting))
  41
  42 (define-class <channel> ())
  43
  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)))
  49
  50 (define-method (initialize (ch <data-channel>) initargs)
  51   (next-method)
  52   (set! (handshake-channel ch) ch))
  53
  54 (define-method (make-channel)
  55   (make <data-channel>))
  56
  57 (define-method (sender-waiting? (ch <data-channel>))
  58   (not (eq? (data ch) no-data)))
  59
  60 (define-method (receiver-waiting? (ch <data-channel>))
  61   (eq? (data ch) receiver-waiting))
  62
  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)
  67     res))
  68
  69 (define-method (late-receive (ch <data-channel>))
  70   (let ((res (data ch)))
  71     (set! (data ch) no-data)
  72     res))
  73
  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"
  80                                (list ch) #f))
  81                    ((sender-waiting? ch)
  82                     (immediate-receive ch))
  83                    (else
  84                     (set! (data ch) receiver-waiting)
  85                     (wait-condition-variable (cv ch) (mutex ch))
  86                     (late-receive ch)))))
  87     (unlock-mutex (mutex ch))
  88     res))
  89
  90 (define-method (! (ch <data-channel>))
  91   (! ch *unspecified*))
  92
  93 (define-method (! (ch <data-channel>) (x <top>))
  94   (lock-mutex (mutex (handshake-channel ch)))
  95   (cond ((receiver-waiting? ch)
  96          (set! (data ch) x)
  97          (signal-condition-variable (cv (handshake-channel ch))))
  98         ((sender-waiting? ch)
  99          (unlock-mutex (mutex (handshake-channel ch)))
 100          (scm-error 'misc-error '! "another process is already sending on ~A"
 101                     (list ch) #f))
 102         (else
 103          (set! (data ch) x)
 104          (wait-condition-variable (cv ch) (mutex ch))))
 105   (unlock-mutex (mutex (handshake-channel ch))))
 106
 107 ;;; Add protocols?
 108
 109 (define-class <port-channel> (<channel>)
 110   (port #:accessor port #:init-keyword #:port))
 111
 112 (define-method (make-channel (port <port>))
 113   (make <port-channel> #:port port))
 114
 115 (define-method (? (ch <port-channel>))
 116   (read (port ch)))
 117
 118 (define-method (! (ch <port-channel>))
 119   (write (port ch)))
 120
 121 (define-class <timer-channel> (<channel>))
 122
 123 (define the-timer (make <timer-channel>))
 124
 125 (define timer-cv (make-condition-variable))
 126 (define timer-mutex (make-mutex))
 127
 128 (define (make-timer)
 129   the-timer)
 130
 131 (define (timeofday->us t)
 132   (+ (* 1000000 (car t)) (cdr t)))
 133
 134 (define (us->timeofday n)
 135   (cons (quotient n 1000000)
 136         (remainder n 1000000)))
 137
 138 (define-method (? (ch <timer-channel>))
 139   (timeofday->us (gettimeofday)))
 140
 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))
 145
 146 ;;; (alt CLAUSE ...)
 147 ;;;
 148 ;;; CLAUSE ::= ((? CH) FORM ...)
 149 ;;;            | (EXP (? CH) FORM ...)
 150 ;;;            | (EXP FORM ...)
 151 ;;;
 152 ;;; where FORM ... can be => (lambda (x) ...)
 153 ;;;
 154 ;;; *fixme* Currently only handles <data-channel>:s
 155 ;;;
 156
 157 (define-syntax oc:lock
 158   (syntax-rules (?)
 159     ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
 160     ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
 161     ((_ (exp form ...)) #f)))
 162
 163 (define-syntax oc:unlock
 164   (syntax-rules (?)
 165     ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
 166     ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
 167     ((_ (exp form ...)) #f)))
 168
 169 (define-syntax oc:consequence
 170   (syntax-rules (=>)
 171     ((_ data) data)
 172     ((_ data => (lambda (x) e1 e2 ...))
 173      (let ((x data)) e1 e2 ...))
 174     ((_ data e1 e2 ...)
 175      (begin data e1 e2 ...))))
 176
 177 (define-syntax oc:immediate-dispatch
 178   (syntax-rules (?)
 179     ((_ ((? ch) e1 ...))
 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 ...)))
 185     ((_ (exp e1 ...))
 186      (exp e1 ...))))
 187
 188 (define-syntax oc:late-dispatch
 189   (syntax-rules (?)
 190     ((_ ((? ch) e1 ...))
 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 ...)))
 196     ((_ (exp e1 ...))
 197      (#f))))
 198
 199 (define-syntax oc:first-channel
 200   (syntax-rules (?)
 201     ((_ ((? ch) e1 ...) c2 ...)
 202      ch)
 203     ((_ (exp (? ch) e1 ...) c2 ...)
 204      ch)
 205     ((_ c1 c2 ...)
 206      (first-channel c2 ...))))
 207
 208 (define-syntax oc:set-handshake-channel
 209   (syntax-rules (?)
 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)
 215      #f)))
 216
 217 (define-syntax oc:unset-handshake-channel
 218   (syntax-rules (?)
 219     ((_ ((? ch) e1 ...))
 220      (set! (handshake-channel ch) ch))
 221     ((_ (exp (? ch) e1 ...))
 222      (and exp (set! (handshake-channel ch) ch)))
 223     ((_ (exp e1 ...))
 224      #f)))
 225
 226 (define-syntax alt
 227   (lambda (x)
 228     (define (else-clause? x)
 229       (syntax-case x (else)
 230         ((_) #f)
 231         ((_ (else e1 e2 ...)) #t)
 232         ((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))
 233
 234     (syntax-case x (else)
 235       ((_ c1 c2 ...)
 236        (else-clause? x)
 237        (syntax (begin
 238                  (oc:lock c1)
 239                  (oc:lock c2) ...
 240                  (let ((res (cond (oc:immediate-dispatch c1)
 241                                   (oc:immediate-dispatch c2) ...)))
 242                    (oc:unlock c1)
 243                    (oc:unlock c2) ...
 244                    res))))
 245       ((_ c1 c2 ...)
 246        (syntax (begin
 247                  (oc:lock c1)
 248                  (oc:lock 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)
 255                                                                    (mutex ch))
 256                                           (oc:unset-handshake-channel c1)
 257                                           (oc:unset-handshake-channel c2) ...
 258                                           (cond (oc:late-dispatch c1)
 259                                                 (oc:late-dispatch c2) ...))))))
 260                    (oc:unlock c1)
 261                    (oc:unlock c2) ...
 262                    res)))))))