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