|
| 1 | +;;; Coroutines |
| 2 | +;;; |
| 3 | +;;; This is a simple example explaining how to implement coroutines in Scheme using |
| 4 | +;;; call/cc. The code is based on Matt Might's blog post on "Continuations by example: |
| 5 | +;;; Exceptions, time-traveling search, generators, threads, and coroutines" at his |
| 6 | +;;; site http://matt.might.net/. The article can be found here: https://goo.gl/pyCHCu . |
| 7 | +;;; |
| 8 | +;;; The code below introduces the following API for implementing simple coroutine-based |
| 9 | +;;; applications: |
| 10 | +;;; |
| 11 | +;;; - (spawn thunk) puts a thread for thunk into the thread queue. |
| 12 | +;;; - (quit) kills the current thread and removes it from the thread queue. |
| 13 | +;;; - (yield) hands control from the current thread to another thread. |
| 14 | +;;; - (start-threads) starts executing threads in the thread queue. |
| 15 | +;;; - (halt) exits all threads. |
| 16 | +;;; |
| 17 | +;;; Author: Matt Might (might@uab.edu) |
| 18 | + |
| 19 | +(import (srfi 31)) |
| 20 | + |
| 21 | +; *thread-queue* : list[continuation] |
| 22 | +(define *thread-queue* '()) |
| 23 | + |
| 24 | +; halt : continuation |
| 25 | +(define halt #f) |
| 26 | + |
| 27 | +;; (current-continuation) -> continuation | any value |
| 28 | +;; This procedure returns the continuation in which it was evaluated. A conditional |
| 29 | +;; pattern can be used to detect whether the continuation was just created, or the |
| 30 | +;; continuation has been invoked from some later point: |
| 31 | +;; ``` |
| 32 | +;; (let ((cc (current-continuation))) |
| 33 | +;; (cond ((procedure? cc) body) |
| 34 | +;; ((future-value? cc) handling-body) |
| 35 | +;; (else (error "Contract violation!")))) |
| 36 | +;; ``` |
| 37 | +(define (current-continuation) |
| 38 | + (call-with-current-continuation (lambda (cc) (cc cc)))) |
| 39 | + |
| 40 | +;; (spawn thunk) |
| 41 | +;; Puts a thread for thunk into the thread queue. |
| 42 | +(define (spawn thunk) |
| 43 | + (let ((cc (current-continuation))) |
| 44 | + (if (procedure? cc) |
| 45 | + (set! *thread-queue* (append *thread-queue* (list cc))) |
| 46 | + (begin (thunk) |
| 47 | + (quit))))) |
| 48 | + |
| 49 | +;; (yield) |
| 50 | +;; Hands control from the current thread to another thread. |
| 51 | +(define (yield) |
| 52 | + (let ((cc (current-continuation))) |
| 53 | + (if (and (procedure? cc) (pair? *thread-queue*)) |
| 54 | + (let ((next-thread (car *thread-queue*))) |
| 55 | + (set! *thread-queue* (append (cdr *thread-queue*) (list cc))) |
| 56 | + (next-thread 'resume))))) |
| 57 | + |
| 58 | +;; (quit) |
| 59 | +;; Kills the current thread and removes it from the thread queue. |
| 60 | +(define (quit) |
| 61 | + (if (pair? *thread-queue*) |
| 62 | + (let ((next-thread (car *thread-queue*))) |
| 63 | + (set! *thread-queue* (cdr *thread-queue*)) |
| 64 | + (next-thread 'resume)) |
| 65 | + (halt))) |
| 66 | + |
| 67 | +;; (start-threads) |
| 68 | +;; Starts executing threads in the thread queue. As a side effect, this function |
| 69 | +;; initializes `halt`. |
| 70 | +(define (start-threads) |
| 71 | + (let ((cc (current-continuation))) |
| 72 | + (if cc |
| 73 | + (begin |
| 74 | + (set! halt (lambda () (cc #f))) |
| 75 | + (if (pair? *thread-queue*) |
| 76 | + (begin |
| 77 | + (let ((next-thread (car *thread-queue*))) |
| 78 | + (set! *thread-queue* (cdr *thread-queue*)) |
| 79 | + (next-thread 'resume)))))))) |
| 80 | + |
| 81 | +;; Example of a simple program using three coroutines |
| 82 | + |
| 83 | +(define counter 10) |
| 84 | + |
| 85 | +(define (make-coroutine name) |
| 86 | + (rec (loop) |
| 87 | + (if (< counter 0) |
| 88 | + (begin (display "quitting thread ") |
| 89 | + (display name) |
| 90 | + (newline) |
| 91 | + (quit))) |
| 92 | + (display "in thread ") |
| 93 | + (display name) |
| 94 | + (display "; counter = ") |
| 95 | + (display counter) |
| 96 | + (newline) |
| 97 | + (set! counter (- counter 1)) |
| 98 | + (yield) |
| 99 | + (loop))) |
| 100 | + |
| 101 | +(spawn (make-coroutine 'a)) |
| 102 | +(spawn (make-coroutine 'b)) |
| 103 | +(spawn (make-coroutine 'c)) |
| 104 | + |
| 105 | +(start-threads) |
| 106 | + |
0 commit comments