/src/channels.lisp
http://github.com/sykopomp/chanl · Lisp · 355 lines · 253 code · 62 blank · 40 comment · 14 complexity · 127d28d6d686846e96a0dc6140e98b3a MD5 · raw file
- ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-
- ;;;;
- ;;;; Copyright © 2009 Kat Marchan, Adlai Chandrasekhar
- ;;;;
- ;;;; Channel Definition
- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (in-package :chanl)
- ;;;
- ;;; Abstract channel interface
- ;;;
- (defclass abstract-channel () ())
- (defgeneric channelp (channel)
- (:method ((anything-else t)) nil)
- (:method ((channel abstract-channel)) t))
- (defgeneric send (chan value &key)
- (:method ((channels null) (value t) &key) (warn "Ignored SEND to empty list"))
- (:method ((channels sequence) value &key (blockp t))
- (loop do (mapc (fun (when (send _ value :blockp nil) (return _)))
- channels)
- unless blockp return nil))
- (:documentation "Tries to send VALUE into CHAN. If a sequence of channels is provided
- instead of a single channel, SEND will send the value into the first channel that doesn't block. If
- BLOCKP is true, SEND will continue to block until it's able to actually send a value. If BLOCKP is
- NIL, SEND will immediately return NIL instead of blocking, if there's no channel available to send
- input into. When SEND succeeds, it returns the channel the value was sent into."))
- (defgeneric recv (chan &key)
- (:method ((channels null) &key) (warn "Ignored RECV from empty list"))
- (:method ((channels sequence) &key (blockp t))
- (loop do (map nil (fun (multiple-value-bind (return-val succeeded) (recv _ :blockp nil)
- (when succeeded (return (values return-val _)))))
- channels)
- unless blockp
- return (values nil nil)))
- (:documentation "Tries to receive from either a single channel, or a sequence of channels. If
- BLOCKP is true, RECV will block until it's possible to receive something. Returns two values: The
- first is the actual value received through the channel. The second is the channel the value was
- received from. When BLOCKP is NIL, RECV will immediately return (values NIL NIL) instead of
- blocking (if it would block)"))
- ;;;
- ;;; Unbuffered channels
- ;;;
- (defvar *secret-unbound-value* (gensym "SECRETLY-UNBOUND-")
- "This value is used as a sentinel in channels.")
- (defclass channel (abstract-channel)
- ((value :initform *secret-unbound-value* :accessor channel-value)
- (readers :initform 0 :accessor channel-readers)
- (writers :initform 0 :accessor channel-writers)
- (lock :initform (bt:make-recursive-lock) :accessor channel-lock)
- (send-ok :initform (bt:make-condition-variable) :accessor channel-send-ok)
- (recv-ok :initform (bt:make-condition-variable) :accessor channel-recv-ok)
- (send-return-wait :initform (bt:make-condition-variable)
- :accessor channel-send-return-wait)
- (recv-grabbed-value-p :initform nil :accessor recv-grabbed-value-p)))
- (defun channel-being-read-p (channel)
- (plusp (channel-readers channel)))
- (defun channel-being-written-p (channel)
- (plusp (channel-writers channel)))
- ;;; Semaphores that delegate locking to the calling context
- (macrolet ((define-channel-state-macro (name place)
- `(defmacro ,name (channel &body body)
- `(unwind-protect (progn (incf (,',place ,channel)) ,@body)
- (decf (,',place ,channel))
- (when (minusp (,',place ,channel))
- (error "Something bad happened"))))))
- (define-channel-state-macro with-write-state channel-writers)
- (define-channel-state-macro with-read-state channel-readers))
- ;;; Sending
- (defmethod send ((channel channel) value &key (blockp t))
- (with-accessors ((lock channel-lock)
- (recv-ok channel-recv-ok))
- channel
- (bt:with-recursive-lock-held (lock)
- (with-write-state channel
- (loop while (send-blocks-p channel)
- if (or blockp (channel-being-read-p channel))
- do (bt:condition-wait (channel-send-ok channel) lock)
- else do (return-from send nil)))
- (bt:condition-notify recv-ok)
- (let ((block-status (channel-being-read-p channel)))
- (channel-insert-value channel value)
- (when block-status
- (loop until (recv-grabbed-value-p channel)
- do (bt:condition-wait (channel-send-return-wait channel) lock)
- finally (setf (recv-grabbed-value-p channel) nil))))
- channel)))
- (defgeneric channel-insert-value (channel value)
- (:method ((channel channel) value)
- (setf (channel-value channel) value)))
- (defgeneric send-blocks-p (channel)
- (:method ((channel channel))
- (not (and (channel-being-read-p channel)
- (eq (channel-value channel)
- *secret-unbound-value*))))
- (:documentation "Returns T if trying to SEND to CHANNEL would block.
- Assumes that the calling context holds the channel's lock."))
- ;;; Receiving
- (defmethod recv ((channel channel) &key (blockp t))
- (with-accessors ((lock channel-lock)
- (send-ok channel-send-ok))
- channel
- (bt:with-recursive-lock-held (lock)
- (with-read-state channel
- (bt:condition-notify send-ok)
- (loop while (recv-blocks-p channel)
- do (if (or blockp (channel-being-written-p channel))
- (bt:condition-wait (channel-recv-ok channel) lock)
- (return-from recv (values nil nil))))
- (multiple-value-prog1
- (values (channel-grab-value channel) channel)
- (setf (recv-grabbed-value-p channel) t)
- (bt:condition-notify (channel-send-return-wait channel)))))))
- (defgeneric recv-blocks-p (channel)
- (:method ((channel channel))
- (eq *secret-unbound-value* (channel-value channel)))
- (:documentation "Returns T if trying to RECV from CHANNEL would block.
- Assumes that the calling context holds the channel's lock."))
- (defgeneric channel-grab-value (channel)
- (:method ((channel channel))
- (shiftf (channel-value channel) *secret-unbound-value*)))
- ;;;
- ;;; Buffered channels
- ;;;
- (defclass buffered-channel (channel) ()
- (:documentation "Abstract class for channels using various buffering styles."))
- (defgeneric channel-buffered-p (channel)
- (:method ((anything-else t)) nil)
- (:method ((channel buffered-channel)) t))
- (defgeneric channel-peek (channel)
- (:documentation
- "Peek at a possible next value CHANNEL would dequeue. An actual call to RECV
- may return a different value, if the previously-peeked one has been received by
- a different thread in the meantime.
- Returns two values: the value of interest or NIL, and a generalized boolean that
- is NIL when there is no available value in the queue."))
- ;;;
- ;;; Stack-buffered channels
- ;;;
- (defclass stack-channel (buffered-channel) ())
- (defmethod initialize-instance :after ((channel stack-channel) &key)
- (setf (channel-value channel) nil))
- (define-print-object ((channel stack-channel))
- (format t "[~A]" (length (channel-value channel))))
- (defmethod channel-peek ((channel stack-channel))
- (if (channel-value channel)
- (values (car (channel-value channel)) t)
- (values nil nil)))
- (defgeneric channel-pop (channel)
- (:method ((channel stack-channel))
- (pop (channel-value channel))))
- (defgeneric channel-push (value channel)
- (:method (value (channel stack-channel))
- (push value (channel-value channel))))
- (defmethod channel-insert-value ((channel stack-channel) value)
- (channel-push value channel))
- (defmethod channel-grab-value ((channel stack-channel))
- (channel-pop channel))
- (defmethod send-blocks-p ((channel stack-channel)) nil)
- (defmethod recv-blocks-p ((channel stack-channel))
- (null (channel-value channel)))
- ;;;
- ;;; Queue-buffered channels.
- ;;;
- (defclass queue-channel (buffered-channel) ()
- (:documentation "These channels buffer objects in some sort of queue."))
- (defgeneric channel-enqueue (value channel)
- (:documentation "Enqueue VALUE in CHANNEL's buffer queue."))
- (defgeneric channel-dequeue (channel)
- (:documentation "Dequeue a value from CHANNEL's buffer queue."))
- (defmethod channel-insert-value ((channel queue-channel) value)
- (channel-enqueue value channel))
- (defmethod channel-grab-value ((channel queue-channel))
- (channel-dequeue channel))
- ;;;
- ;;; Bounded Buffered Channels
- ;;;
- (defconstant +maximum-buffer-size+ (- array-total-size-limit 2)
- "The exclusive upper bound on the size of a channel's buffer.")
- (defclass bounded-channel (queue-channel) ())
- (defmethod initialize-instance :after ((channel bounded-channel) &key (size 1))
- (assert (typep size `(integer 1 ,(1- +maximum-buffer-size+))) (size)
- "Buffer size must be a non-negative fixnum..")
- (setf (channel-value channel) (make-queue size)))
- (define-print-object ((channel bounded-channel))
- (let ((buffer (channel-value channel)))
- (format t "[~A/~A]" (queue-count buffer) (queue-length buffer))))
- (defmethod channel-peek ((channel bounded-channel))
- (queue-peek (channel-value channel)))
- ;;; Sending
- (defmethod send-blocks-p ((channel bounded-channel))
- (queue-full-p (channel-value channel)))
- (defmethod channel-enqueue (value (channel bounded-channel))
- (enqueue value (channel-value channel)))
- ;;; Receiving
- (defmethod recv-blocks-p ((channel bounded-channel))
- (queue-empty-p (channel-value channel)))
- (defmethod channel-dequeue ((channel bounded-channel))
- (dequeue (channel-value channel)))
- ;;;
- ;;; Unbounded Channels
- ;;;
- (defclass unbounded-channel (queue-channel) ())
- (defmethod initialize-instance :after ((channel unbounded-channel) &key)
- (setf (channel-value channel) (cons nil nil)))
- (define-print-object ((channel unbounded-channel))
- (format t "[~A]" (length (car (channel-value channel)))))
- (defmethod channel-peek ((channel unbounded-channel))
- (if (car (channel-value channel))
- (values (caar (channel-value channel)) t)
- (values nil nil)))
- ;;; Sending
- (defmethod send-blocks-p ((channel unbounded-channel)) nil)
- (defmethod channel-enqueue (value (channel unbounded-channel))
- (let ((queue (channel-value channel)))
- (pushend value (car queue) (cdr queue))))
- ;;; Receiving
- (defmethod recv-blocks-p ((channel unbounded-channel))
- (null (car (channel-value channel))))
- (defmethod channel-dequeue ((channel unbounded-channel))
- (pop (car (channel-value channel))))
- ;;;
- ;;; CAS Channels
- ;;;
- (defclass cas-channel (abstract-channel)
- ((vector :initform (vector *secret-unbound-value* 0 0 nil) :accessor channel-vector))
- (:documentation
- "These channels use COMPARE-AND-SWAP to do their thing, instead of locks+condition-vars.
- Ideally, these would be faster than regular channels. In reality, they're not. It's possible
- there might be a way to speed these guys up while keeping the same behavior in the interface,
- but for now, they're about 100x slower, not to mention non-portable."))
- #+ (and ccl (or x86 x86-64))
- (defmethod initialize-instance :before ((channel cas-channel) &key)
- (warn "COMPARE-AND-SWAP on x86-based CCL is experimental and buggy. Beware."))
- #- (or sbcl (and ccl (or x86 x86-64)))
- (defmethod initialize-instance ((channel cas-channel) &key)
- (error "COMPARE-AND-SWAP is not supported on this platform yet.~%Platform details: ~A ~A"
- (lisp-implementation-version) (lisp-implementation-type)))
- (defmethod channel-value ((channel cas-channel))
- (svref (channel-vector channel) 0))
- (defmethod channel-readers ((channel cas-channel))
- (svref (channel-vector channel) 1))
- (defmethod channel-writers ((channel cas-channel))
- (svref (channel-vector channel) 2))
- (defmethod recv-grabbed-value-p ((channel cas-channel))
- (svref (channel-vector channel) 3))
- (defun cas-channel-set (slot-name channel value)
- (let ((index (case slot-name (value 0) (readers 1) (writers 2) (recv-grabbed-value-p 3))))
- (loop for old = (svref (channel-vector channel) index)
- when (eq old (compare-and-swap (svref (channel-vector channel) index) old value))
- return value)))
- (macrolet ((define-cas-channel-state-macro (name place)
- `(defmacro ,name (channel &body body)
- `(unwind-protect
- (progn
- (atomic-incf (svref (channel-vector ,channel) ,',place))
- ,@body)
- (atomic-incf (svref (channel-vector ,channel) ,',place) -1)
- (when (minusp (svref (channel-vector ,channel) ,',place))
- (error "Something bad happened"))))))
- (define-cas-channel-state-macro with-cas-write-state 2)
- (define-cas-channel-state-macro with-cas-read-state 1))
- ;;; writing
- (defmethod send ((channel cas-channel) value &key (blockp t))
- (with-cas-write-state channel
- (loop while (send-blocks-p channel)
- unless (or blockp (channel-being-read-p channel))
- do (return-from send nil))
- (let ((block-status (channel-being-read-p channel)))
- (channel-insert-value channel value)
- (when block-status
- (loop until (recv-grabbed-value-p channel)
- finally (cas-channel-set 'recv-grabbed-value-p channel nil))))
- channel))
- (defmethod send-blocks-p ((channel cas-channel))
- (not (and (channel-being-read-p channel)
- (eq (channel-value channel)
- *secret-unbound-value*))))
- (defmethod channel-insert-value ((channel cas-channel) value)
- (cas-channel-set 'value channel value))
- ;;; reading
- (defmethod recv ((channel cas-channel) &key (blockp t))
- (with-cas-read-state channel
- (loop while (recv-blocks-p channel)
- unless (or blockp (channel-being-written-p channel))
- do (return-from recv (values nil nil)))
- (multiple-value-prog1
- (values (channel-grab-value channel) channel)
- (cas-channel-set 'recv-grabbed-value-p channel t))))
- (defmethod recv-blocks-p ((channel cas-channel))
- (eq *secret-unbound-value* (channel-value channel)))
- (defmethod channel-grab-value ((channel cas-channel))
- (prog1 (channel-value channel)
- (cas-channel-set 'value channel *secret-unbound-value*)))