That "Thunking" Noise
Coroutines for the DIYer

There's a game that I've been working on for quite some time, a few minutes here, a couple hours there. Realizing that this cyberpunk-themed game could use a credible hacking mechanic, I weighed a few options and eventually settled on an in-game programming system. To avoid situations like halting the game over an infinite loop of the player's making, or having a player's programs do an absurd amount of work in a single turn, I needed some way to control execution that fit within the overall simulation loop.

A reasonable way out of this situation is to embed some sort of scripting language, have it compile to some sort of bytecode representation, and then step the bytecode interpreter as needed over whatever programs the player types in. However, I also had the related issue that various entities (NPCs and devices) can have complex behaviors spread across multiple turns. State machines and behavior trees work nicely in a lot of cases, but sometimes conventional code just reads more naturally.

In the last article, we approached an implementation of Python-style iterators in Common Lisp, and then we pushed it a bit until we ran into a problem, RLE decoding, that we could not solve cleanly. That problem, and the two problems I already mentioned, can be attacked very nicely using something called coroutines, which are subroutines that can be suspended and later resumed at will. In this article, we'll explore how to conjure them using the more basic terms of a language that doesn't already have them. In particular, we'll employ thunks, i.e., functions that take no arguments, as a key element.

It turns out that you can make just about anything out of thunks.

The Python version of an RLE decoder that we used before, modulo a minor bug fix, is as follows:

def rle_decode(src):
    src = iter(src)
    for c in src:
	if c != '~':
	    yield c
	elif not (n := ord(next(src))):
	    yield '~'
	else:
	    d = next(src)
	    for i in range(n): # fixes an off-by-one error in the original
		yield d

The Common Lisp variation was less straightforward. To make it work, we had to explicitly treat the input stream as a series of variable-length directives, interpret those directives to generate partial outputs, and then combine them. The Python version is equivalent, but the stages of decoding are implicit. As the last article laid out, for the Lisp implementation, "It was necessary … because the function generating values for the iterator always starts at the beginning on each call; we cannot directly use progress through that function to mark generator state."

To explore what that means, let's step back and reconsider the problem, but with a different interface. We'll just read characters from a stream and print them to *standard-output*:

(defun rle-decode (stream)
  (loop for c = (read-char stream nil nil)
	while c
	do (if (not (eq c #\~))
	       (format t "~a" c)
	       (let ((n (char-code (read-char stream nil nil))))
		 (if (zerop n)
		     (format t "~~")
		     (let ((d (read-char stream nil nil)))
		       (dotimes (i n)
			 (format t "~a" d))))))))

CL-USER> (let ((s (format nil "abc~~~a/def" (code-char 40))))
	   (rle-decode (make-string-input-stream s)))
abc////////////////////////////////////////def
NIL

Discounting some details, this is identical in structure to the Python rle_decode routine. Of particular note is that the places where in Python we yield, in Lisp we print. Now, let's take one more step back, all the way back to the 1990s when children were taught to make flowcharts of their programs:

That in hand, we can pretend for a moment that we never learned about structured programming and write, nearly by inspection, exactly the kind of code that Edsger Dijkstra considered harmful all those years ago:

(defun rle-decode (stream)
  (let (c d i n)
    (tagbody
     :start
       (setf c (read-char stream nil nil))
       (unless c (go :end))

       (when (eq c #\~) (go :get-n))

       (format t "~a" c)
       (go :start)

     :get-n
       (setf n (char-code (read-char stream nil nil)))
       (unless (zerop n) (go :get-d))

       (format t "~~")
       (go :start)

     :get-d
       (setf d (read-char stream nil nil))
       (setf i 0)

     :rld
       (unless (< i n) (go :start))

       (format t "~a" d)
       (incf i)
       (go :rld)

     :end)))

CL-USER> (let ((s (format nil "abc~~~a/def" (code-char 40))))
	   (rle-decode (make-string-input-stream s)))
abc////////////////////////////////////////def
NIL

We now have, in the tagbody, a version of our routine as a linear series of forms punctuated by labels. This is not far from the naïve understanding of programs as series of instructions executed in succession, with the occasional diversion of control flow. To make this point even stronger, let's consider an even simpler situation with no labels or go forms whatsoever, i.e., linear execution:

(tagbody
   (print 'one)
   (print 'two)
   (print 'three)
   (print 'four)
   (print 'five))

The contents of the tagbody is a program, and each form we can think of as an instruction for a machine that knows how to print. We could even write a little interpreter for such a machine

(defun print-vm (insns)
  (dolist (insn insns)
    (destructuring-bind (op &rest args) insn
      (ecase op
	(print (apply #'print args))))))

and call it like so:

CL-USER> (print-vm
	  `((print one)
	    (print two)
	    (print three)
	    (print four)
	    (print five)))

ONE 
TWO 
THREE 
FOUR 
FIVE 
NIL

Rather than expand the interpreter to accommodate all that we would ever want to put into our programs (a never-ending story), or call eval on every "instruction" as we encounter it (a performance hit), let's build our program as a list of individual "instructions," represented by thunks. Even though each thunk can do an arbitrary amount of work, an interpreter for our chosen program representation needs to do remarkably little:

(defun print-vm (insns)
  (dolist (insn insns)
    (funcall insn)))

CL-USER> (print-vm
	  (list
	   (lambda () (print 'one))
	   (lambda () (print 'two))
	   (lambda () (print 'three))
	   (lambda () (print 'four))
	   (lambda () (print 'five))))

ONE 
TWO 
THREE 
FOUR 
FIVE 
NIL

All this (lambda ...) business is going to clutter things, so let's write our first bit of true convenience right now:

(defmacro !! (&body body)
  "make a thunk from `body'"
  `(lambda () ,@body))

With that, our last example becomes

CL-USER> (print-vm
	  (list
	   (!! (print 'one))
	   (!! (print 'two))
	   (!! (print 'three))
	   (!! (print 'four))
	   (!! (print 'five))))

ONE 
TWO 
THREE 
FOUR 
FIVE 
NIL

So far, we haven't done anything terribly interesting, like suspend or resume or manipulate control flow, i.e., the very things we wish to do. So, let's fix that.

As we go along, we'll elaborate what it takes to represent and execute a program, so let's define a little something to keep it all together. For now, we only need to hang on to the list of instructions and something to indicate our progress, an instruction pointer:

(defstruct vm
  insns
  ip)

In a normal CPU, the instruction pointer (a.k.a. program counter) contains the address of the next instruction to be fetched. We will adopt an analogous convention: It will be a pointer into the insns such that (car ip) is the next instruction. With that definition, our first draft of the interpreter writes itself:

(defun execute (vm)
  (loop while (vm-ip vm)
	do (funcall (pop (vm-ip vm)))))

Note how our method of fetching an instruction also causes the ip to advance automatically, ensuring that ip always indicates the next instruction. Maintaining that invariant in execute simplifies many things elsewhere.

Now that we have a basic VM and interpreter,

CL-USER> (let* ((insns (list (!! (print 'one))
			     (!! (print 'two))
			     (!! (print 'three))
			     (!! (print 'four))
			     (!! (print 'five))))
		(vm (make-vm :insns insns :ip insns)))
	   (execute vm))

ONE 
TWO 
THREE 
FOUR 
FIVE 
NIL

Not very compelling yet, is it? What if we had a long list of instructions, and we wanted to execute only a handful at a time? With the addition of a single parameter

(defun execute (vm &optional steps)
  (loop while (vm-ip vm)
	until (and steps (zerop steps))
	do
	   (when steps (decf steps))
	   (funcall (pop (vm-ip vm)))))

we can now get our first taste of suspension and resumption:

CL-USER> (let* ((insns (list (!! (print 'one))
			     (!! (print 'two))
			     (!! (print 'three))
			     (!! (print 'four))
			     (!! (print 'five))))
		(vm (make-vm :insns insns :ip insns)))
	   (execute vm 2)
	   (print '==========)
	   (execute vm))

ONE 
TWO 
========== 
THREE 
FOUR 
FIVE 
NIL

The moment we allowed arbitrary suspension and resumption, we added everything needed to support coroutines in general, and generators in particular. As the last edition of rle-decode shows, though, supporting something and making it convenient are not the same thing. We can fix that, though, with a few tweaks. First, we can give the VM a couple extra slots:

(defstruct vm
  insns
  ip
  tripped
  lbls
  rsp
  dsp
  retval
  yielded)

(define-symbol-macro *vm-retval* (vm-retval *vm*))
(define-symbol-macro *vm-yielded* (vm-yielded *vm*))

Then, we can add a yield instruction,

(defun yield (&optional val)
  (setf *vm-retval* val
	*vm-yielded* t)
  (trip))

tweak execute (not necessary, but nicer),

(defun execute (vm &optional steps)
  (let ((*vm* vm))
    (setf *vm-tripped* nil
	  *vm-yielded* nil)
    (loop while *vm-ip*
	  until (and steps (zerop steps))
	  until *vm-tripped*
	  do
	     (when steps (decf steps))
	     (funcall (pop *vm-ip*)))
    *vm-retval*))

and define an iter method:

(defmethod iter ((vm vm))
  (!!
    (execute vm)
    (if (vm-yielded vm)
	(vm-retval vm)
	(guard (vm-ip vm)))))

Having approximated Python's concept of generators in Common Lisp, we can now express rle-decode in the following thunkified assembly-ish notation:

(defun rle-decode (stream)
  (let (c d i n)
    (iter
     (new-vm
      :start
      (!! (setf c (read-char stream nil nil)))
      (!! (unless c (jmp :end)))

      (!! (when (eq c #\~) (jmp :get-n)))

      (!! (yield c))
      (!! (jmp :start))

      :get-n
      (!! (setf n (char-code (read-char stream nil nil))))
      (!! (unless (zerop n) (jmp :get-d)))

      (!! (yield #\~))
      (!! (jmp :start))

      :get-d
      (!! (setf d (read-char stream nil nil)))
      (!! (setf i 0))

      :rld
      (!! (unless (< i n) (jmp :start)))

      (!! (yield d))
      (!! (incf i))
      (!! (jmp :rld))

      :end))))

Writing in assembly language is great fun, but sometimes other concerns take priority. To make future examples smaller and easier to read, let's build up a small DSL for defining coroutines. A simple wrapper lets us dispense with explicitly indicating thunks:

(defmacro coro (bindings &body body)
  `(let ,bindings
     (new-vm
      ,@ (loop for form in body
	       when (typep form 'label)
		 collect form
	       else
		 collect `(!! ,form)))))

Now we can write

(coro ()
  10 (cool stuff)
  :twenty
  (more cool stuff))

instead of

(let ()
  (new-vm
   10
   (!!
    (cool stuff))
   :twenty
   (!!
    (more cool stuff))))

Suppose in the middle of a coro we wrote

(if test
    true-part
    false-part)

It would be turned into

(!! (if test
	true-part
	false-part))

But what if true-part and false-part were themselves long sequences peppered with yield, and what if we actually wanted to resume those subsequences? We can address that and similar needs by crafting a suite of flattening macros that map fairly conventional syntactic constructs to the more primitive sequences that coro expects. Rather than define them all up front, let's adopt the convention that each such macro's name will begin with '!', and that it will return a list of expanded forms, which may be further subject to expansion. An easy example of what we're going for will be our answer to if:

(defmacro !if (test true &optional false)
  (let ((false-lbl (genlbl))
	(end-lbl (genlbl)))
    `((unless ,test (jmp ,false-lbl))
      ,true
      (jmp ,end-lbl)
      ,false-lbl
      ,false
      ,end-lbl)))

where

(defun genlbl (&optional (prefix "L"))
  (intern (string (gensym prefix)) :keyword))

To expand macros like this, let's create something very specialized and much more limited than a general code walker

(defun expand-thunkifiers (body)
  (let ((expanded t))
    (loop while expanded do
      (setf expanded nil)
      (setf body
	    (loop for form in body
		  when (and form
			    (listp form)
			    (symbolp (car form))
			    (eq #\!
				(aref (symbol-name (car form)) 0)))
		    append
		    (multiple-value-bind (new exp) (macroexpand form)
		      (setf expanded (or expanded exp))
		    new)
		  else
		    collect form)))
    body))

and use it as a helper for our "extended" coroutine wrapper, xcoro:

(defmacro xcoro (bindings &body body)
  `(coro ,bindings
     ,@ (expand-thunkifiers body)))

After a few more thunkifiers,

(defmacro !progn (&body body)
  body)

(defmacro !while (test &body body)
  (let ((top-lbl (genlbl)))
    `(!progn
       ,top-lbl
       (!if ,test (!progn ,@body (jmp ,top-lbl))))))

(defmacro !cond (&body clauses)
  (when clauses
    (destructuring-bind ((test . true) . rest) clauses
      `(!if ,test (!progn ,@true)
	    (!cond ,@rest)))))

we can settle down to writing rle-decode in a way that strongly recalls the original Python version:

(defun rle-decode (stream)
  (iter
   (xcoro (c d i n)
     (!while (setf c (read-char stream nil nil))
       (!cond
	 ((not (eq c #\~))
	  (yield c))
	 ((zerop (setf n (char-code (read-char stream nil nil))))
	  (yield #\~))
	 (t
	  (setf d (read-char stream nil nil))
	  (setf i 0)
	  (!while (< i n)
	    (yield d)
	    (incf i))))))))

Let's finish by making a convenient notion of subroutines. Because we have a dual stack design (i.e., separate data and return stacks), we have many options, but today we'll stick to using them in a coordinated manner that mimics the unified activation record stacks of other systems:

(defmacro !defsub (name args &body body)
  (let ((tmp-sym (gensym)))
    `(!progn
       ,name
       (let ((,tmp-sym (dpop)))
	 (dpush (list ,@args))
	 (setf ,@ (loop for arg in args
			appending `(,arg (pop ,tmp-sym)))))
       ,@body
       (let ((,tmp-sym (dpop)))
	 (setf ,@ (loop for arg in args
			appending `(,arg (pop ,tmp-sym)))))
       (ret))))

(defmacro !call (name &rest args)
  `(!progn
     (dpush (list ,@args))
     (call ,name)))

Long before The Tower of Hanoi became a classic introductory problem when teaching recursion, it was a puzzle for people to solve as a diversion. Using the tools we've developed, let's divert ourselves by making a simulator that consumes moves and prints out the state of the pegs:

(defun hanoi-game (num-disks)
  (let* (src
	 dst
	 (co
	   (xcoro ((peg
		    (list 'a (loop for i from 1 to num-disks collecting i)
			  'b nil
			  'c nil))
		   disk top)
	     (!while t
	       (setf disk (pop (getf peg src))
		     top  (car (getf peg dst)))
	       (!cond
		 ((not disk)
		  (format t "~%Illegal move.  You die.")
		  (ret))
		 ((or (not top) (< disk top))
		  (push disk (getf peg dst)))
		 (t
		  (format t "~%Illegal move.  You die.")
		  (ret)))
	       (call :draw)
	       (!if (= num-disks (length (getf peg 'c)))
		    (!progn
		      (format t "~%You win.  EVERYONE DIES!!!")
		      (ret)))
	       (yield t)
	       (setf *vm-retval* nil))

	     :draw
	     (print peg)
	     (ret))))
    (lambda (s d)
      (setf src s
	    dst d)
      (execute co))))

Clearing *vm-retval* on re-entry allows us to distinguish, outside the coroutine, whether the simulation is still alive and accepting input or dead. We can use that fact to house it in a thin shell,

(defun play-hanoi (disks)
  (let ((hanoi (hanoi-game disks)))
    (loop do
      (print '(move))
      (unless (funcall hanoi (read) (read))
	(return-from play-hanoi nil)))))

That done, we can play

CL-USER> (play-hanoi 2)

(MOVE) a b

(A (2) B (1) C NIL) 
(MOVE) a b

Illegal move.  You die.
NIL

and play some more:

CL-USER> (play-hanoi 2)

(MOVE) a b

(A (2) B (1) C NIL) 
(MOVE) a c

(A NIL B (1) C (2)) 
(MOVE) b c

(A NIL B NIL C (1 2)) 
You win.  EVERYONE DIES!!!
NIL

And when we get tired of playing (because (play-hanoi 64) sounds like a better idea than it is), we can write a coroutine to generate the moves

(defun hanoi-moves (disks)
  (xcoro ((n disks)
	  (src 'a)
	  (tmp 'b)
	  (dst 'c))

    (jmp :main)

    (!defsub :hanoi (n src tmp dst)
      (!if (not (zerop n))
	   (!progn
	     (!call :hanoi (1- n) src dst tmp)
	     (yield (list src dst))
	     (!call :hanoi (1- n) tmp src dst))))

    :main
    (!call :hanoi n src tmp dst)    
    (guard nil)))

and use a little bit of glue to hold the pipeline together:

CL-USER> (let* ((num-disks 3) ; no, we're not simulating 64 disks
		(game (hanoi-game num-disks)))
	   (for ((s d) (hanoi-moves num-disks))
	     (format t "~%~%~a --> ~a" s d)
	     (funcall game s d)))


A --> C
(A (2 3) B NIL C (1)) 

A --> B
(A (3) B (2) C (1)) 

C --> B
(A (3) B (1 2) C NIL) 

A --> C
(A NIL B (1 2) C (3)) 

B --> A
(A (1) B (2) C (3)) 

B --> C
(A (1) B NIL C (2 3)) 

A --> C
(A NIL B NIL C (1 2 3)) 
You win.  EVERYONE DIES!!!
NIL

Earlier I mentioned that among the initial motivations for all of this was to limit the execution of programs from an untrusted source, and we saw briefly the mechanism for accomplishing that very objective. Because any uncontrived example I can think of at this hour would require considerable setup, let's consider the contrived example of counting upwards and marking when the count is divisible by some number:

(defun counter-task (n)
  (xcoro ((i 0))
    (!while t
      (incf i)
      (!if (zerop (mod i n))
	   (!progn
	     (format t " *")
	     (yield))
	   (format t " ~a" i)))))

Note the yield that suspends execution periodically. Without it, each task would be nothing more than an infinite loop. With it, though, each task is an infinite loop that still lets us do other things. As long as a task is still active, we can enter and re-enter as many times as we like:

CL-USER> (let ((co (counter-task 5)))
	   (dotimes (i 3)
	     (execute co)
	     (print 'other-things)))
 1 2 3 4 *
OTHER-THINGS  6 7 8 9 *
OTHER-THINGS  11 12 13 14 *
OTHER-THINGS 
NIL

Now, suppose we had a number of such tasks, and we wanted to ensure that all made progress together over time. We can use a simple round-robin scheduler:

(defun run-tasks (rounds steps &rest tasks)
  (nconc tasks tasks)
  (loop for i below rounds
	for (name . co) = (pop tasks)
	do
	   (format t "~a: " name)
	   (execute co steps)
	   (format t "~%")))

If we choose to let each task choose when to suspend itself, we can simulate cooperative multitasking:

CL-USER> (run-tasks 12 nil
		    (cons 'a (counter-task 3))
		    (cons 'b (counter-task 13))
		    (cons 'c (counter-task 7))
		    (cons 'd (counter-task 25)))
A:  1 2 *
B:  1 2 3 4 5 6 7 8 9 10 11 12 *
C:  1 2 3 4 5 6 *
D:  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 *
A:  4 5 *
B:  14 15 16 17 18 19 20 21 22 23 24 25 *
C:  8 9 10 11 12 13 *
D:  26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 *
A:  7 8 *
B:  27 28 29 30 31 32 33 34 35 36 37 38 *
C:  15 16 17 18 19 20 *
D:  51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 *
NIL

But what if letting a task run long enough to emit 25 numbers doesn't work for us? Or, what if we simply had no idea when or if tasks might yield? What we need is a bit of preemption, which our VM can provide at the level of individual instruction thunks:

CL-USER> (run-tasks 12 20
		    (cons 'a (counter-task 3))
		    (cons 'b (counter-task 13))
		    (cons 'c (counter-task 7))
		    (cons 'd (counter-task 25)))
A:  1 2 *
B:  1 2 3 4
C:  1 2 3 4
D:  1 2 3 4
A:  4 5 *
B:  5 6 7 8
C:  5 6 *
D:  5 6 7 8
A:  7 8 *
B:  9 10 11 12
C:  8 9 10
D:  9 10 11 12
NIL

If each thunk in each task only does a limited amount of work before returning, then the tasks progress at roughly the same apparent rate, the overall system behaves more smoothly, and all is well. (Enforcing that limitation on each thunk's work is a key concern when devising an in-game programming language. The game's playability depends on it.) Without a timer interrupt, this pseudo-preemption is as good as it gets.

In this article, we have covered considerable ground. When we started, we were unable to express run-length decoding as directly in Lisp as we can in Python. From there, we analyzed one notion of a program to evolve a representation that we can arbitrarily suspend and resume, and then we used it to solve the original problem before moving on to considering consumption, recursive generation, and multitasking. En route, we also defined a variety of conveniences that allow us to write code that reads in a nearly conventional manner. We did all of this, by the way, without using third-party libraries and without writing a full-on code walker.

Looking back, one might get the sense that the same approach, i.e., of modeling an idealized notion of a computer and designing in terms of that, would work in any language having only a few basic elements. If that is so, what elements are those; what does that suggest about the relative "power" of different languages; and how far does that power go?

This article uses a few facilities defined previously. For convenience, they are reproduced here.

(define-condition stop-iteration () ())

(defgeneric iter (seq))

(defun guard (pred &optional (condition 'stop-iteration))
  (unless pred
    (error condition)))

(defmethod iter ((seq function)) seq)

(defmacro for ((var seq) &body body)
  (let ((iter-var (gensym)))
    `(let ((,iter-var (iter ,seq)))
       (handler-case
	   (loop for ,var = (funcall ,iter-var)
		 do ,@body)
	 (stop-iteration ())))))