Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 159 lines (133 sloc) 4.74 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
#lang racket

(provide make-empty-thread-pool
         current-thread-pool
         get-switch-count
         yield
         threads)

; Store the current state of a thread
(define-struct thread-state (continuation) #:mutable)

; Store a collection of threads in a pool
(define-struct thread-pool (all current switch-count) #:mutable)

; Create a new, empty thread pool
(define (make-empty-thread-pool)
  (make-thread-pool '() '() 0))

; Allow for multiple thread pools
(define current-thread-pool
  (make-parameter (make-empty-thread-pool)))

; Get the number of context switches out of the current thread pool
(define (get-switch-count [pool (current-thread-pool)])
  (thread-pool-switch-count pool))

; Yield control of the current thread to the next thread in the current pool
(define (yield)
  (call-with-current-continuation
   (lambda (k)
     ; Unwrap the current pool
     (define pool (current-thread-pool))
     
     ; Store the current thread state
     (define thread (car (thread-pool-current pool)))
     (set-thread-state-continuation! thread k)
     
     ; Advance to the next thread
     (set-thread-pool-current! pool (cdr (thread-pool-current pool)))
     (when (null? (thread-pool-current pool))
       (set-thread-pool-current! pool (thread-pool-all pool)))
     (set-thread-pool-switch-count! pool (+ 1 (thread-pool-switch-count pool)))
     
     ; Run that thread
     (define next-k (thread-state-continuation (car (thread-pool-current pool))))
     (next-k (void)))))

; Run a given list of thunks in parallel
(define (threads . thunks)
  (call-with-current-continuation
   (lambda (k)
     (when (null? thunks) (error 'threads "must specify at least one thread"))
     
     ; Unwrap the current pool
     (define pool (current-thread-pool))
     
     ; Create the initial thread states
     (define threads
       (map
        (lambda (thunk) (thread-state (lambda (_) (k (thunk)))))
        thunks))
     
     ; Store them in the pool
     (set-thread-pool-current! pool (append (thread-pool-current pool) threads))
     (set-thread-pool-all! pool (append (thread-pool-all pool) threads))
     
     ; Start the first thread
     (define first-k (thread-state-continuation (car (thread-pool-current pool))))
     (first-k (void)))))

; Test with fibonacci numbers
(module+ test
  (printf "--- fibonacci test ---\n")
  
  (define (fib n)
    (yield)
    (if (<= n 1)
        1
        (+ (fib (- n 1)) (fib (- n 2)))))
  
  (parameterize ([current-thread-pool (make-empty-thread-pool)])
    (printf "fib test returned: ~a\n"
            (time
             (threads
              (lambda () (list 10 (fib 10)))
              (lambda () (list 20 (fib 20))))))
    (printf "~a context switches\n" (get-switch-count))))

; Test to make sure creating new thread pools works
(module+ test
  (printf "--- parameterizable test ---\n")
  
  (parameterize ([current-thread-pool (make-empty-thread-pool)])
    (threads
     (lambda () (printf "it worked!\n")))))

; Test with tick/tock
(module+ test
  (printf "--- tick tock test ---\n")
  (define run-for 0.5)
  (define delay 0.001)
  
  (parameterize ([current-thread-pool (make-empty-thread-pool)])
    (time
     (threads
      ; Stop after 1 second
      (lambda ()
        (let loop ([i 0])
          (sleep delay)
          (when (< (* i delay) run-for)
            (yield)
            (loop (+ i 1)))))
      ; Keep printing tick
      (lambda ()
        (let loop ()
          (printf "tick\n")
          (yield)
          (loop)))
      ; Keep printing tock
      (lambda ()
        (let loop ()
          (printf "tock\n")
          (yield)
          (loop)))))
    (printf "~a context switches\n" (get-switch-count))))

; Test context switches
(module+ test
  (printf "--- context switch test ---\n")
  (define iterations 1000)
  
  (parameterize ([current-thread-pool (make-empty-thread-pool)])
    (time
     (threads
      (lambda ()
        (let loop ([i 0])
          (when (< i iterations)
            (yield)
            (loop (+ i 1)))))))
    (printf "~a context switches (target: ~a)\n"
            (get-switch-count)
            iterations)))

; Test nested thead pools.
(module+ test
  (printf "--- nested test ---\n")
  
  (parameterize ([current-thread-pool (make-empty-thread-pool)])
    (threads
     (lambda ()
       (parameterize ([current-thread-pool (make-empty-thread-pool)])
         (threads
          (lambda () (let loop () (printf "tick\n") (yield) (loop)))
          (lambda () (let loop () (printf "tock\n") (yield) (loop))))))
     (lambda ()
       (parameterize ([current-thread-pool (make-empty-thread-pool)])
         (threads
          (lambda () (list 10 (fib 10)))
          (lambda () (list 20 (fib 20)))))))))
Something went wrong with that request. Please try again.