[plt-scheme] The concurrency package in SICP

> Unfortunately, the granularity for a thread's context switch is a bit 
> large, so you might not see the interplay that you'd like using native 
> threads. According to the message thread above, you might be able to use 
> engines to get finer control over context switching, and Jens Axel 
> Soegaard has a nice implementation here:
>
>   http://list.cs.brown.edu/pipermail/plt-scheme/2002-September/000620.html
>
> It might not be too bad to take his work and adapt it to provide the 
> PARALLEL-EXECUTE and MAKE-SERIALIZER primitives you'll want.

Hi Joshua,

Ok, I've done so and kludged Jens's code up to provide both a 
PARALLEL-EXECUTE and a MAKE-SERIALIZER (as well as a TEST-AND-SET!) as a 
module language, using the engines framework that Jens wrote up earlier.

My kludge is really ugly and I'm not completely sure it's correct. 
Still, at least it should help you see the process switching a lot more 
frequently.  The code follows as an attachment 'concurrency.ss', and is 
intended to be a module language.

For example:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module test-concurrency2 "concurrency.ss"
   (provide (all-defined))
   (require (lib "etc.ss"))

   (define (test-1)
     (define x 10)
     (parallel-execute (lambda () (set! x (* x x)))
                       (lambda () (set! x (+ x 1))))
     x)

   (define (test-2)
     (define x 10)
     (define s (make-serializer))
     (parallel-execute (s (lambda () (set! x (* x x))))
                       (s (lambda () (set! x (+ x 1)))))
     x)

   (printf "test-1: ~a~n" (build-list 20 (lambda (i) (test-1))))
   (printf "test-2: ~a~n" (build-list 20 (lambda (i) (test-2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

I haven't personally seen test-1 emitting 100, but I've seen the other 
four values (101, 121, 110, and 11) with some frequency.


I'll CC Jens and see if he might consider adding some variation of this to 
his SICP planet package.  Best of wishes and Happy New Year!
-------------- next part --------------
(module concurrency mzscheme
  ;; concurrency: SICP concurrency primitives
  ;; adapted from http://list.cs.brown.edu/pipermail/plt-scheme/2002-September/000620.html
  
  ;;; Sources:
  ;;; Dorai Sitaram, "Learn Scheme in a Fixnum of Dayes", chapter 15
  ;;; Dyvig, http://www.scheme.com/tspl2d/examples.html#g2433
  (provide (all-from-except mzscheme #%app #%datum set!))
  
  (provide make-serializer
           parallel-execute
           test-and-set!
           (rename timed-datum #%datum)
           (rename timed-apply #%app)
           (rename timed-set! set!))
  
  (require (only (lib "list.ss") first rest sort))
  
  
  (define yield-handler (lambda () (void)))
  (define clock 0)
  
  (define (start-timer ticks new-handler)
    (set! yield-handler new-handler)
    (set! clock ticks))
  
  (define (stop-timer)
    (let ([time-left clock])
      (set! clock 0)
      time-left))
  
  (define (decrement-timer)
    (if (> clock 0)
        (begin
          (set! clock (- clock 1))
          (if (= clock 0)
              (yield-handler)))))
  
  
  (define (random-shuffle a-list)
    (map rest
         (sort (map (lambda (x) (cons (random) x)) a-list)
               (lambda (x y) (< (first x) (first y))))))
  
  (define (parallel-execute . thunks)
    (round-robin (map make-engine (random-shuffle thunks))))
  
  
  (define (dole-out-gas)
    (add1 (random 7)))
  
  (define (round-robin engs)
    (if (null? engs)
        '()
        ((car engs) (dole-out-gas)
                    (lambda (ticks value)
                      (cons value (round-robin (cdr engs))))
                    (lambda (eng)
                      (round-robin
                       (append (cdr engs) (list eng)))))))
  
  
  
  (define make-engine
    (let ([do-complete #f]
          [do-expire #f])
      (define (timer-handler)
        (start-timer (call/cc do-expire) timer-handler))
      
      (define (new-engine resume)
        (lambda (ticks complete expire)
          ((call/cc (lambda (escape)
                      (set! do-complete
                            (lambda (ticks value)
                              (escape (lambda () (complete ticks value)))))
                      (set! do-expire
                            (lambda (resume)
                              (escape (lambda () (expire (new-engine resume))))))
                      (resume ticks))))))
      (lambda (proc)
        (new-engine
         (lambda (ticks)
           (start-timer ticks timer-handler)
           (let ((value (proc)))
             (let ((ticks (stop-timer)))
               (do-complete ticks value))))))))
  
  
  (define-syntax timed-datum
    (syntax-rules ()
      [(_ . datum)
       (begin
         (decrement-timer)
         (#%datum . datum))]))
  
  (define-syntax timed-apply
    (syntax-rules ()
      ((_ operator rand ... . last-rand)
       (begin
         (decrement-timer)
         (#%app (begin (decrement-timer) operator)
                (begin (decrement-timer) rand) ...
                . (begin (decrement-timer) last-rand))))
      ((_ operator rand ...)
       (begin
         (decrement-timer)
         (#%app (begin (decrement-timer) operator)
                (begin (decrement-timer) rand) ...)))))
  
  (define-syntax timed-set!
    (syntax-rules ()
      ((_ e arg ...)
       (begin
         (decrement-timer)
         (set! e (begin (decrement-timer) arg) ...)))))
  
  
  
  ;; The following definitions are adapted from SICP
  ;;
  ;; http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-23.html#call_footnote_Temp_430
  
  (define (make-serializer)
    (let ((mutex (timed-apply make-mutex)))
      (lambda (p)
        (define (serialized-p . args)
          (timed-apply mutex 'acquire)
          (let ((val (timed-apply apply p args)))
            (timed-apply mutex 'release)
            val))
        serialized-p)))
  
  (define (make-mutex)
    (let ((cell (timed-apply list #f)))
      (define (the-mutex m)
        (cond ((timed-apply eq? m 'acquire)
               (if (timed-apply test-and-set! cell)
                   (timed-apply the-mutex 'acquire)))
              ((timed-apply eq? m 'release)
               (timed-apply clear! cell))))
      the-mutex))
  
  (define (clear! cell)
    (timed-apply set-car! cell #f))
  
  (define (test-and-set! cell)
    (if (car cell)
        #t
        (begin (set-car! cell #t)
               #f))))