/src/channels.lisp

  1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-
  2;;;;
  3;;;; Copyright © 2009 Kat Marchan, Adlai Chandrasekhar
  4;;;;
  5;;;; Channel Definition
  6;;;;
  7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8(in-package :chanl)
  9
 10;;;
 11;;; Abstract channel interface
 12;;;
 13(defclass abstract-channel () ())
 14
 15(defgeneric channelp (channel)
 16  (:method ((anything-else t)) nil)
 17  (:method ((channel abstract-channel)) t))
 18
 19(defgeneric send (chan value &key)
 20  (:method ((channels null) (value t) &key) (warn "Ignored SEND to empty list"))
 21  (:method ((channels sequence) value &key (blockp t))
 22    (loop do (mapc (fun (when (send _ value :blockp nil) (return _)))
 23                   channels)
 24       unless blockp return nil))
 25  (:documentation "Tries to send VALUE into CHAN. If a sequence of channels is provided
 26instead of a single channel, SEND will send the value into the first channel that doesn't block.  If
 27BLOCKP is true, SEND will continue to block until it's able to actually send a value. If BLOCKP is
 28NIL, SEND will immediately return NIL instead of blocking, if there's no channel available to send
 29input into. When SEND succeeds, it returns the channel the value was sent into."))
 30
 31(defgeneric recv (chan &key)
 32  (:method ((channels null) &key) (warn "Ignored RECV from empty list"))
 33  (:method ((channels sequence) &key (blockp t))
 34    (loop do (map nil (fun (multiple-value-bind (return-val succeeded) (recv _ :blockp nil)
 35                             (when succeeded (return (values return-val _)))))
 36                  channels)
 37       unless blockp
 38       return (values nil nil)))
 39  (:documentation "Tries to receive from either a single channel, or a sequence of channels.  If
 40BLOCKP is true, RECV will block until it's possible to receive something.  Returns two values: The
 41first is the actual value received through the channel.  The second is the channel the value was
 42received from. When BLOCKP is NIL, RECV will immediately return (values NIL NIL) instead of
 43blocking (if it would block)"))
 44
 45;;;
 46;;; Unbuffered channels
 47;;;
 48(defvar *secret-unbound-value* (gensym "SECRETLY-UNBOUND-")
 49  "This value is used as a sentinel in channels.")
 50
 51(defclass channel (abstract-channel)
 52  ((value :initform *secret-unbound-value* :accessor channel-value)
 53   (readers :initform 0 :accessor channel-readers)
 54   (writers :initform 0 :accessor channel-writers)
 55   (lock :initform (bt:make-recursive-lock) :accessor channel-lock)
 56   (send-ok :initform (bt:make-condition-variable) :accessor channel-send-ok)
 57   (recv-ok :initform (bt:make-condition-variable) :accessor channel-recv-ok)
 58   (send-return-wait :initform (bt:make-condition-variable)
 59                     :accessor channel-send-return-wait)
 60   (recv-grabbed-value-p :initform nil :accessor recv-grabbed-value-p)))
 61
 62(defun channel-being-read-p (channel)
 63  (plusp (channel-readers channel)))
 64
 65(defun channel-being-written-p (channel)
 66  (plusp (channel-writers channel)))
 67
 68;;; Semaphores that delegate locking to the calling context
 69(macrolet ((define-channel-state-macro (name place)
 70             `(defmacro ,name (channel &body body)
 71                `(unwind-protect (progn (incf (,',place ,channel)) ,@body)
 72                   (decf (,',place ,channel))
 73                   (when (minusp (,',place ,channel))
 74                     (error "Something bad happened"))))))
 75  (define-channel-state-macro with-write-state channel-writers)
 76  (define-channel-state-macro with-read-state channel-readers))
 77
 78;;; Sending
 79(defmethod send ((channel channel) value &key (blockp t))
 80  (with-accessors ((lock channel-lock)
 81                   (recv-ok channel-recv-ok))
 82      channel
 83    (bt:with-recursive-lock-held (lock)
 84      (with-write-state channel
 85        (loop while (send-blocks-p channel)
 86           if (or blockp (channel-being-read-p channel))
 87           do (bt:condition-wait (channel-send-ok channel) lock)
 88           else do (return-from send nil)))
 89      (bt:condition-notify recv-ok)
 90      (let ((block-status (channel-being-read-p channel)))
 91        (channel-insert-value channel value)
 92        (when block-status
 93          (loop until (recv-grabbed-value-p channel)
 94             do (bt:condition-wait (channel-send-return-wait channel) lock)
 95             finally (setf (recv-grabbed-value-p channel) nil))))
 96      channel)))
 97
 98(defgeneric channel-insert-value (channel value)
 99  (:method ((channel channel) value)
100    (setf (channel-value channel) value)))
101
102(defgeneric send-blocks-p (channel)
103  (:method ((channel channel))
104    (not (and (channel-being-read-p channel)
105              (eq (channel-value channel)
106                  *secret-unbound-value*))))
107  (:documentation "Returns T if trying to SEND to CHANNEL would block.
108
109Assumes that the calling context holds the channel's lock."))
110
111;;; Receiving
112(defmethod recv ((channel channel) &key (blockp t))
113  (with-accessors ((lock channel-lock)
114                   (send-ok channel-send-ok))
115      channel
116    (bt:with-recursive-lock-held (lock)
117      (with-read-state channel
118        (bt:condition-notify send-ok)
119        (loop while (recv-blocks-p channel)
120           do (if (or blockp (channel-being-written-p channel))
121                  (bt:condition-wait (channel-recv-ok channel) lock)
122                  (return-from recv (values nil nil))))
123        (multiple-value-prog1
124            (values (channel-grab-value channel) channel)
125          (setf (recv-grabbed-value-p channel) t)
126          (bt:condition-notify (channel-send-return-wait channel)))))))
127
128(defgeneric recv-blocks-p (channel)
129  (:method ((channel channel))
130    (eq *secret-unbound-value* (channel-value channel)))
131  (:documentation "Returns T if trying to RECV from CHANNEL would block.
132
133Assumes that the calling context holds the channel's lock."))
134
135(defgeneric channel-grab-value (channel)
136  (:method ((channel channel))
137    (shiftf (channel-value channel) *secret-unbound-value*)))
138
139;;;
140;;; Buffered channels
141;;;
142(defclass buffered-channel (channel) ()
143  (:documentation "Abstract class for channels using various buffering styles."))
144
145(defgeneric channel-buffered-p (channel)
146  (:method ((anything-else t)) nil)
147  (:method ((channel buffered-channel)) t))
148
149(defgeneric channel-peek (channel)
150  (:documentation
151   "Peek at a possible next value CHANNEL would dequeue. An actual call to RECV
152may return a different value, if the previously-peeked one has been received by
153a different thread in the meantime.
154
155Returns two values: the value of interest or NIL, and a generalized boolean that
156is NIL when there is no available value in the queue."))
157
158;;;
159;;; Stack-buffered channels
160;;;
161(defclass stack-channel (buffered-channel) ())
162
163(defmethod initialize-instance :after ((channel stack-channel) &key)
164  (setf (channel-value channel) nil))
165
166(define-print-object ((channel stack-channel))
167  (format t "[~A]" (length (channel-value channel))))
168
169(defmethod channel-peek ((channel stack-channel))
170  (if (channel-value channel)
171      (values (car (channel-value channel)) t)
172      (values nil nil)))
173
174(defgeneric channel-pop (channel)
175  (:method ((channel stack-channel))
176    (pop (channel-value channel))))
177
178(defgeneric channel-push (value channel)
179  (:method (value (channel stack-channel))
180    (push value (channel-value channel))))
181
182(defmethod channel-insert-value ((channel stack-channel) value)
183  (channel-push value channel))
184(defmethod channel-grab-value ((channel stack-channel))
185  (channel-pop channel))
186
187(defmethod send-blocks-p ((channel stack-channel)) nil)
188(defmethod recv-blocks-p ((channel stack-channel))
189  (null (channel-value channel)))
190
191;;;
192;;; Queue-buffered channels.
193;;;
194(defclass queue-channel (buffered-channel) ()
195  (:documentation "These channels buffer objects in some sort of queue."))
196
197(defgeneric channel-enqueue (value channel)
198  (:documentation "Enqueue VALUE in CHANNEL's buffer queue."))
199(defgeneric channel-dequeue (channel)
200  (:documentation "Dequeue a value from CHANNEL's buffer queue."))
201
202(defmethod channel-insert-value ((channel queue-channel) value)
203  (channel-enqueue value channel))
204
205(defmethod channel-grab-value ((channel queue-channel))
206  (channel-dequeue channel))
207
208;;;
209;;; Bounded Buffered Channels
210;;;
211(defconstant +maximum-buffer-size+ (- array-total-size-limit 2)
212  "The exclusive upper bound on the size of a channel's buffer.")
213
214(defclass bounded-channel (queue-channel) ())
215
216(defmethod initialize-instance :after ((channel bounded-channel) &key (size 1))
217  (assert (typep size `(integer 1 ,(1- +maximum-buffer-size+))) (size)
218          "Buffer size must be a non-negative fixnum..")
219  (setf (channel-value channel) (make-queue size)))
220
221(define-print-object ((channel bounded-channel))
222  (let ((buffer (channel-value channel)))
223    (format t "[~A/~A]" (queue-count buffer) (queue-length buffer))))
224
225(defmethod channel-peek ((channel bounded-channel))
226  (queue-peek (channel-value channel)))
227
228;;; Sending
229(defmethod send-blocks-p ((channel bounded-channel))
230  (queue-full-p (channel-value channel)))
231
232(defmethod channel-enqueue (value (channel bounded-channel))
233  (enqueue value (channel-value channel)))
234
235;;; Receiving
236(defmethod recv-blocks-p ((channel bounded-channel))
237  (queue-empty-p (channel-value channel)))
238
239(defmethod channel-dequeue ((channel bounded-channel))
240  (dequeue (channel-value channel)))
241
242;;;
243;;; Unbounded Channels
244;;;
245(defclass unbounded-channel (queue-channel) ())
246
247(defmethod initialize-instance :after ((channel unbounded-channel) &key)
248  (setf (channel-value channel) (cons nil nil)))
249
250(define-print-object ((channel unbounded-channel))
251  (format t "[~A]" (length (car (channel-value channel)))))
252
253(defmethod channel-peek ((channel unbounded-channel))
254  (if (car (channel-value channel))
255      (values (caar (channel-value channel)) t)
256      (values nil nil)))
257
258;;; Sending
259(defmethod send-blocks-p ((channel unbounded-channel)) nil)
260
261(defmethod channel-enqueue (value (channel unbounded-channel))
262  (let ((queue (channel-value channel)))
263    (pushend value (car queue) (cdr queue))))
264
265;;; Receiving
266(defmethod recv-blocks-p ((channel unbounded-channel))
267  (null (car (channel-value channel))))
268
269(defmethod channel-dequeue ((channel unbounded-channel))
270  (pop (car (channel-value channel))))
271
272;;;
273;;; CAS Channels
274;;;
275(defclass cas-channel (abstract-channel)
276  ((vector :initform (vector *secret-unbound-value* 0 0 nil) :accessor channel-vector))
277  (:documentation
278   "These channels use COMPARE-AND-SWAP to do their thing, instead of locks+condition-vars.
279Ideally, these would be faster than regular channels. In reality, they're not. It's possible
280there might be a way to speed these guys up while keeping the same behavior in the interface,
281but for now, they're about 100x slower, not to mention non-portable."))
282
283#+ (and ccl (or x86 x86-64))
284(defmethod initialize-instance :before ((channel cas-channel) &key)
285  (warn "COMPARE-AND-SWAP on x86-based CCL is experimental and buggy. Beware."))
286
287#- (or sbcl (and ccl (or x86 x86-64)))
288(defmethod initialize-instance ((channel cas-channel) &key)
289  (error "COMPARE-AND-SWAP is not supported on this platform yet.~%Platform details: ~A ~A"
290         (lisp-implementation-version) (lisp-implementation-type)))
291
292(defmethod channel-value ((channel cas-channel))
293  (svref (channel-vector channel) 0))
294(defmethod channel-readers ((channel cas-channel))
295  (svref (channel-vector channel) 1))
296(defmethod channel-writers ((channel cas-channel))
297  (svref (channel-vector channel) 2))
298(defmethod recv-grabbed-value-p ((channel cas-channel))
299  (svref (channel-vector channel) 3))
300
301(defun cas-channel-set (slot-name channel value)
302  (let ((index (case slot-name (value 0) (readers 1) (writers 2) (recv-grabbed-value-p 3))))
303    (loop for old = (svref (channel-vector channel) index)
304         when (eq old (compare-and-swap (svref (channel-vector channel) index) old value))
305         return value)))
306
307(macrolet ((define-cas-channel-state-macro (name place)
308             `(defmacro ,name (channel &body body)
309                `(unwind-protect
310                      (progn
311                        (atomic-incf (svref (channel-vector ,channel) ,',place))
312                        ,@body)
313                   (atomic-incf (svref (channel-vector ,channel) ,',place) -1)
314                   (when (minusp (svref (channel-vector ,channel) ,',place))
315                     (error "Something bad happened"))))))
316  (define-cas-channel-state-macro with-cas-write-state 2)
317  (define-cas-channel-state-macro with-cas-read-state 1))
318
319;;; writing
320(defmethod send ((channel cas-channel) value &key (blockp t))
321  (with-cas-write-state channel
322    (loop while (send-blocks-p channel)
323       unless (or blockp (channel-being-read-p channel))
324       do (return-from send nil))
325    (let ((block-status (channel-being-read-p channel)))
326      (channel-insert-value channel value)
327      (when block-status
328        (loop until (recv-grabbed-value-p channel)
329           finally (cas-channel-set 'recv-grabbed-value-p channel nil))))
330    channel))
331
332(defmethod send-blocks-p ((channel cas-channel))
333  (not (and (channel-being-read-p channel)
334            (eq (channel-value channel)
335                *secret-unbound-value*))))
336
337(defmethod channel-insert-value ((channel cas-channel) value)
338  (cas-channel-set 'value channel value))
339
340;;; reading
341(defmethod recv ((channel cas-channel) &key (blockp t))
342  (with-cas-read-state channel
343    (loop while (recv-blocks-p channel)
344       unless (or blockp (channel-being-written-p channel))
345       do (return-from recv (values nil nil)))
346    (multiple-value-prog1
347        (values (channel-grab-value channel) channel)
348      (cas-channel-set 'recv-grabbed-value-p channel t))))
349
350(defmethod recv-blocks-p ((channel cas-channel))
351  (eq *secret-unbound-value* (channel-value channel)))
352
353(defmethod channel-grab-value ((channel cas-channel))
354  (prog1 (channel-value channel)
355    (cas-channel-set 'value channel *secret-unbound-value*)))