/src/channels.lisp

http://github.com/sykopomp/chanl · Lisp · 355 lines · 253 code · 62 blank · 40 comment · 14 complexity · 127d28d6d686846e96a0dc6140e98b3a MD5 · raw file

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