Skip to content

coroutines in common lisp with bordeaux-threads

Turns out threads are a lot easier without beer and after a good nights sleep.  Following up on last night’s defeat (see coroutines in common lisp), I re-read the documentation this morning and got my locks sorted out.

I now use one lock and two condition variables (CV).  From the bordeaux-threads API docs:

A condition variable provides a mechanism for threads to put themselves to sleep while waiting for the state of something to change, then to be subsequently woken by another thread which has changed the state.

I thought of these CVs like events in Java/C#/Javascript.  Telling one thread to CONDITION-WAIT on a CV is kinda like telling it to listen to that event, and have another thread CONDITION-NOTIFY on a CV is kinda like firing the event.  It took me a long time to understand the importance of CONDITION-WAIT atomically releasing a lock, and reacquiring it before continuing execution in that thread.  That mechanism let me coordinate some sequential execution between the threads, eliminating the race conditions that beat me last night.

I also added the ability to send a value into the coroutine by setting the return value of yield.

I used one CV to tell the coroutine it should run to the next yield, and another CV for the coroutine to tell the caller that a value was ready for it.  I had a few let bindings for my shared memory, closing variables into both the coroutine and caller functions.  The coroutine doesn’t spawn a new thread until the first time it’s funcalled.  I have a somewhat poor mechanism for determining if the coroutine is done; you specify a sigil value and the coroutine yields that as the final value (kind of like eof-value in stream reading functions).  I tried to use thread-alive-p, but ran into race conditions.  I have a few ideas for how to improve that.

Here’s the latest make-coroutine macro and test function:

(defmacro make-coroutine ((&key (coroutine-done-value :done))
			  &body body)
  (alexandria:with-gensyms ((yield-cv "there a value ready for pickup")
			    (run-cv "coroutine should run")
			    (lock "lock")
			    (val "shared memory")
			    (yield-result "return value of yield in the corouting")
			    (thrfn "thread function body"))
    `(let* ((,yield-cv (bordeaux-threads:make-condition-variable
			 :name "yield"))
	    (,run-cv (bordeaux-threads:make-condition-variable
			 :name "run"))
	    (,lock (bordeaux-threads:make-lock "coroutine lock"))
	    ,val ,yield-result
	    (,thrfn (lambda ()	  
		      (flet ((yield (&optional n)
			       (setf ,val n)
			       ;;signal that a value is ready for pickup
			       (bordeaux-threads:condition-notify ,yield-cv)
			       ;;wait for a chance to run
			       (bordeaux-threads:condition-wait ,run-cv ,lock)
			(bordeaux-threads:acquire-lock ,lock)
			(yield ,coroutine-done-value)
			(bordeaux-threads:release-lock ,lock)))))

       ;;function to pull values from the coroutine
       (let ((alive-p T) thr)
	 (lambda (&key (send nil send-suppliedp))
	   (when alive-p
	     (bordeaux-threads:with-lock-held (,lock)
	       (if thr
		   (bordeaux-threads:condition-notify ,run-cv)
		   (setf thr (bordeaux-threads:make-thread
			      ,thrfn :name "coroutine")))
	       (bordeaux-threads:condition-wait ,yield-cv ,lock)

	       (setf ,yield-result
		     (if send-suppliedp send ,val))

	       (when (eql ,coroutine-done-value ,val)
		 (setf alive-p nil)
		 (bordeaux-threads:condition-notify ,run-cv))

(defun coroutine-test ()
  (let ((cor (make-coroutine (:coroutine-done-value :done)
	       (yield 1)
	       (yield 4)))
	(cor2 (make-coroutine ()
		(yield (yield (yield 4)))
    (assert (eql 1 (funcall cor)) )
    (assert (null (funcall cor)))
    (assert (eql 4 (funcall cor)))
    (assert (eql :done (funcall cor)))
    (assert (eql :done (funcall cor)))

    (assert (eql 4 (funcall cor2)))
    (assert (eql 4 (funcall cor2 :send 6)))
    (assert (eql 6 (funcall cor2)))
    (assert (eql :done (funcall cor2)))))

I’ll probably play with it more tonight, maybe put together a stand-alone repo / library.