summaryrefslogtreecommitdiffstats
path: root/ps08_conspiracies
diff options
context:
space:
mode:
Diffstat (limited to 'ps08_conspiracies')
-rw-r--r--ps08_conspiracies/conspire.scm383
-rw-r--r--ps08_conspiracies/load.scm8
-rw-r--r--ps08_conspiracies/ps.txt1013
-rw-r--r--ps08_conspiracies/try-two-ways.scm157
4 files changed, 1561 insertions, 0 deletions
diff --git a/ps08_conspiracies/conspire.scm b/ps08_conspiracies/conspire.scm
new file mode 100644
index 0000000..ba2d665
--- /dev/null
+++ b/ps08_conspiracies/conspire.scm
@@ -0,0 +1,383 @@
+;;;; CONSPIRE: Time Sharing in Scheme
+;;; "Processes scheming together
+;;; constitute a conspiracy"
+
+;;; The essence of this system is that the state of a
+;;; thread is specified by its continuation. To switch
+;;; threads we need to make a continuation, store it
+;;; for the scheduler, and then retrieve a thread from
+;;; the scheduler and start it running. The thread has
+;;; an identity, even though its continuation changes
+;;; from time to time.
+
+;;; A running thread can block itself until some
+;;; predicate thunk becomes true by calling
+;;; conspire:switch-threads with the predicate.
+
+(define (conspire:switch-threads runnable?)
+ (without-interrupts
+ (lambda ()
+ (conspire:save-current-thread runnable?
+ conspire:start-next-thread))))
+
+(define (conspire:save-current-thread runnable? after-save)
+ (call-with-current-continuation
+ (lambda (current-continuation)
+ (conspire:set-continuation! *running-thread*
+ current-continuation)
+ (conspire:add-to-schedule! runnable?
+ *running-thread*)
+ (after-save))))
+
+(define (conspire:start-next-thread)
+ (set! *running-thread*
+ (conspire:get-runnable-thread-from-schedule!))
+ ((conspire:continuation *running-thread*) unspecific))
+
+
+;;; A thread can explicitly yield control, remaining
+;;; runnable.
+
+(define (conspire:thread-yield)
+ (conspire:switch-threads conspire:runnable))
+
+(define conspire:runnable (lambda () #t))
+
+;;; A thread can kill itself by starting some other thread
+;;; without saving itself for rescheduling.
+
+(define (conspire:kill-current-thread)
+ (without-interrupts
+ (lambda ()
+ (conspire:start-next-thread))))
+
+(define (conspire:kill-threads threads)
+ (without-interrupts
+ (lambda ()
+ (for-each conspire:delete-from-schedule! threads)
+ (if (memq *running-thread* threads)
+ (conspire:kill-current-thread)))))
+
+;;; A thread can make another thread and continue running.
+;;; The thunk specified is the work order for the new thread.
+;;; When the thunk returns the thread kills itself.
+
+(define (conspire:make-thread runnable? thunk)
+ (call-with-current-continuation
+ (lambda (current-continuation)
+ (within-continuation *root-continuation*
+ (lambda ()
+ (without-interrupts
+ (lambda ()
+ (call-with-current-continuation
+ (lambda (new-continuation)
+ (let ((new-thread
+ (conspire:make-new-thread new-continuation)))
+ (conspire:add-to-schedule! runnable? new-thread)
+ (current-continuation new-thread))))))
+ (thunk)
+ (conspire:kill-current-thread))))))
+
+
+
+;;; A simple scheduler is just round-robin.
+
+(define (conspire:add-to-schedule! runnable? thread)
+ (queue:add-to-end! *thread-queue*
+ (cons runnable? thread)))
+
+(define (conspire:get-runnable-thread-from-schedule!)
+ (if (not (queue:empty? *thread-queue*))
+ (let lp ((first (queue:get-first *thread-queue*)))
+ (if ((car first)) ; runnable?
+ (cdr first)
+ (begin
+ (queue:add-to-end! *thread-queue* first)
+ (lp (queue:get-first *thread-queue*)))))
+ (error "No current thread")))
+
+(define (conspire:delete-from-schedule! thread)
+ (let ((entry
+ (find-matching-item
+ (queue:front-ptr *thread-queue*)
+ (lambda (entry)
+ (eq? (cdr entry) thread)))))
+ (if entry
+ (queue:delete-from-queue! *thread-queue*
+ entry))))
+
+;;; We use the queue design similar to SICP Section 3.3.2
+
+(define-record-type queue
+ (queue:make-record front-ptr rear-ptr)
+ queue?
+ (front-ptr queue:front-ptr queue:set-front-ptr!)
+ (rear-ptr queue:rear-ptr queue:set-rear-ptr!))
+
+(define (queue:make)
+ (queue:make-record '() '()))
+
+(define (queue:empty? queue)
+ (null? (queue:front-ptr queue)))
+
+(define (queue:get-first queue)
+ (if (null? (queue:front-ptr queue))
+ (error "get-first called with an empty queue" queue)
+ (let ((first (car (queue:front-ptr queue)))
+ (rest (cdr (queue:front-ptr queue))))
+ (queue:set-front-ptr! queue rest)
+ (if (null? rest)
+ (queue:set-rear-ptr! queue '()))
+ first)))
+
+(define (queue:add-to-end! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((null? (queue:front-ptr queue))
+ (queue:set-front-ptr! queue new-pair)
+ (queue:set-rear-ptr! queue new-pair))
+ (else
+ (set-cdr! (queue:rear-ptr queue) new-pair)
+ (queue:set-rear-ptr! queue new-pair))))
+ 'done)
+
+(define (queue:delete-from-queue! queue item)
+ (queue:set-front-ptr! queue
+ (delq item
+ (queue:front-ptr queue)))
+ (if (pair? (queue:front-ptr queue))
+ (queue:set-rear-ptr! queue
+ (last-pair (queue:front-ptr queue)))
+ (queue:set-rear-ptr! queue '()))
+ 'done)
+
+(define-record-type conspire:thread
+ (conspire:make-new-thread continuation)
+ conspire:thread?
+ (continuation conspire:continuation
+ conspire:set-continuation!))
+
+
+;;; Startup: have to make queue and first process
+
+(define (with-conspiracy thunk)
+ (fluid-let ((*running-thread*
+ (conspire:make-new-thread unspecific))
+ (*thread-queue* (queue:make))
+ (*root-continuation*))
+ (call-with-current-continuation
+ (lambda (k)
+ (set! *root-continuation* k)
+ (thunk)))))
+
+(define *running-thread*)
+
+(define *thread-queue*)
+
+(define *root-continuation*)
+
+#|
+;;; An elementary example:
+
+(define (loop n)
+ (let lp ((i 0))
+ (if (< global-counter 1)
+ 'done
+ (begin (set! global-counter (- global-counter 1))
+ (if (= i n)
+ (begin (write-line `(,n ,global-counter))
+ (conspire:thread-yield)
+ (lp 0))
+ (lp (+ i 1)))))))
+
+(define global-counter)
+
+(with-conspiracy
+ (lambda ()
+ (set! global-counter 200)
+ (conspire:make-thread conspire:runnable (lambda () (loop 31)))
+ (conspire:make-thread conspire:runnable (lambda () (loop 37)))
+ (repl/start (push-repl (nearest-repl/environment))
+ "; Entering conspiracy")))
+
+(pp *thread-queue*)
+#[queue 4]
+(front-ptr
+ ((#[compound-procedure 6 conspire:runnable] . #[conspire:thread 7])
+ (#[compound-procedure 6 conspire:runnable] . #[conspire:thread 5])))
+(rear-ptr
+ ((#[compound-procedure 6 conspire:runnable] . #[conspire:thread 5])))
+
+(conspire:thread-yield)
+(31 168)
+(37 130)
+;Unspecified return value
+
+;;; Got back to repl.
+
+(conspire:thread-yield)
+(31 98)
+(37 60)
+;Unspecified return value
+
+(conspire:thread-yield)
+(31 28)
+;Unspecified return value
+
+(conspire:thread-yield)
+;Unspecified return value
+
+(pp *thread-queue*)
+#[queue 4]
+(front-ptr ())
+(rear-ptr ())
+
+(abort->previous) ; Get out of repl.
+|#
+
+;;; Preemptive scheduling.
+
+(define conspire:quantum 10)
+
+(define conspire:running? #f)
+
+;;; This is an MIT Scheme specific detail. register-timer-event is
+;;; the MIT Scheme mechanism for delivering a timer interrupt -- when
+;;; the time specified by its first argument expires, it invokes the
+;;; second argument.
+
+(define (start-time-sharing)
+ (let lp ()
+ (if *debugging-time-sharing* (display "."))
+ (if conspire:running?
+ (begin
+ (register-timer-event conspire:quantum
+ lp)
+ (conspire:thread-yield))))
+ 'done)
+
+(define *debugging-time-sharing* #f)
+
+
+(define (with-time-sharing-conspiracy thunk)
+ (fluid-let ((conspire:running? #t))
+ (with-conspiracy
+ (lambda ()
+ (start-time-sharing)
+ (thunk)))))
+
+(define (conspire:null-job)
+ (conspire:thread-yield)
+ (if (queue:empty? *thread-queue*)
+ 'done
+ (conspire:null-job)))
+
+#|
+;;; Our elementary example, again
+
+(define (loop n)
+ (let lp ((i 0))
+ (if (< global-counter 1)
+ 'done
+ (begin (set! global-counter (- global-counter 1))
+ (if (= i n)
+ (begin (write-line `(,n ,global-counter))
+ (lp 0))
+ (lp (+ i 1)))))))
+
+
+(define global-counter)
+
+(with-time-sharing-conspiracy
+ (lambda ()
+ (set! global-counter 100000)
+ (conspire:make-thread conspire:runnable (lambda () (loop 5555)))
+ (conspire:make-thread conspire:runnable (lambda () (loop 4444)))
+ (conspire:null-job)))
+
+(5555 94444)
+(5555 88888)
+(5555 83332)
+(5555 77776)
+(4444 71412)
+(4444 66967)
+(4444 62522)
+(4444 58077)
+(4444 53632)
+(4444 49187)
+(4444 44742)
+(5555 39853)
+(5555 34297)
+(5555 28741)
+(5555 23185)
+(5555 17629)
+(4444 9782)
+(4444 5337)
+(4444 892)
+;Value: done
+|#
+
+;;; Interlocks
+
+(define-record-type conspire:lock
+ (conspire:make-lock-cell state)
+ conspire:lock?
+ (state conspire:lock-state conspire:set-lock-state!))
+
+(define (conspire:make-lock)
+ (conspire:make-lock-cell #f))
+
+(define (test-and-set-lock?! cell)
+ (if (not (conspire:lock? cell))
+ (error "Bad lock"))
+ (without-interrupts
+ (lambda ()
+ (if (eq? (conspire:lock-state cell) #f)
+ (begin (conspire:set-lock-state! cell #t)
+ #t)
+ #f))))
+
+(define (conspire:unlock cell)
+ (conspire:set-lock-state! cell #f))
+
+(define (conspire:acquire-lock lock)
+ (if (test-and-set-lock?! lock)
+ 'OK
+ (conspire:switch-threads
+ (lambda () (test-and-set-lock?! lock)))))
+
+#|
+;;; Our elementary example again:
+
+(define global-counter-lock (conspire:make-lock))
+
+(define (loop n)
+ (let lp ((i 0))
+ (let delaylp ((k 100))
+ (if (> k 0)
+ (delaylp (- k 1))))
+ (conspire:acquire-lock global-counter-lock)
+ (if (< global-counter 1)
+ (begin
+ (conspire:unlock global-counter-lock)
+ 'done)
+ (begin (set! global-counter (- global-counter 1))
+ (if (= i n)
+ (begin (write-line `(,n ,global-counter))
+ (conspire:unlock global-counter-lock)
+ (lp 0))
+ (begin
+ (conspire:unlock global-counter-lock)
+ (lp (+ i 1)))))))
+ (write-line `(,n terminating)))
+
+(define global-counter)
+
+(set! conspire:quantum 5)
+
+(with-time-sharing-conspiracy
+ (lambda ()
+ (set! global-counter 100000)
+ (conspire:make-thread conspire:runnable (lambda () (loop 999)))
+ (conspire:make-thread conspire:runnable (lambda () (loop 1000)))
+ (conspire:null-job)))
+|#
diff --git a/ps08_conspiracies/load.scm b/ps08_conspiracies/load.scm
new file mode 100644
index 0000000..f4945db
--- /dev/null
+++ b/ps08_conspiracies/load.scm
@@ -0,0 +1,8 @@
+;; On The Fringes of Fun with Control Structures
+(load "same-fringe")
+
+;; Communication among Threads
+(load "conspire")
+(load "try-two-ways")
+
+':have-fun!
diff --git a/ps08_conspiracies/ps.txt b/ps08_conspiracies/ps.txt
new file mode 100644
index 0000000..4ca0dee
--- /dev/null
+++ b/ps08_conspiracies/ps.txt
@@ -0,0 +1,1013 @@
+
+ MASSACHVSETTS INSTITVTE OF TECHNOLOGY
+ Department of Electrical Engineering and Computer Science
+
+ 6.945 Spring 2009
+ Problem Set 8
+
+ Issued: Wed. 1 Apr. 2009 Due: Wed. 15 Apr. 2009
+
+____
+Note: This problem set is not due until 15 April. You now have a term
+ project to work on, so we will lighten up on the problem sets.
+
+Readings:
+
+ Online MIT/GNU Scheme Documentation,
+ Section 10.6: Streams - cons-stream, etc.
+ Section 2.3: Dynamic Binding - fluid-let
+ Section 12.4: Continuations - call-with-current-continuation &
+ within-continuation
+
+ Here is a nice paper about continuations and threads:
+ http://repository.readscheme.org/ftp/papers/sw2003/Threads.pdf
+
+ In fact, there is an entire bibliography of stuff about this on:
+ http://library.readscheme.org/page6.html
+
+ The MIT/GNU Scheme reference manual is here:
+ http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/
+
+
+Code: load.scm, conspire.scm, try-two-ways.scm (attached)
+ same-fringe.scm (not attached, since it is all shown here in line)
+
+
+ On The Fringes of Fun with Control Structures
+
+Let's look at a variety of ways to solve a famous problem, the classic
+"same fringe" problem. This is the content of the lecture we had on
+Monday, 16 March 2009.
+
+The "fringe" of a tree is defined to be the ordered list of terminal
+leaves of the tree encountered when the tree is traversed in some
+standard order, say depth-first left-to-right. We can easily compute
+the fringe of a tree represented as a list structure. In the programs
+that follow we add an explicit test to exclude the empty list from the
+answer:
+
+ (define (fringe subtree)
+ (cond ((pair? subtree)
+ (append (fringe (car subtree))
+ (fringe (cdr subtree))))
+ ((null? subtree) '())
+ (else (list subtree))))
+
+Where append is usually defined as:
+
+ (define (append l1 l2)
+ (if (pair? l1)
+ (cons (car l1) (append (cdr l1) l2))
+ l2))
+
+So the fringe of a typical tree is:
+
+#|
+ (fringe '((a b) c ((d)) e (f ((g h)))))
+ ;Value: (a b c d e f g h)
+
+ (fringe '(a b c ((d) () e) (f (g (h)))))
+ ;Value: (a b c d e f g h)
+|#
+
+That was a horribly inefficient computation, because append keeps
+copying parts of the fringe over and over.
+
+-------------
+Problem 8.1:
+
+What is the worst-case algorithmic complexity of this procedure in
+both time and space? This is a bit tricky because your answer depends
+on how you decide to measure the input argument. Is it the length of
+the fringe? The number of nodes? Is the depth of the tree relevant?
+So make sure you explain your answer clearly.
+
+For example, O(N), O(N lg N), O(N^2), etc. might all be correct
+depending on how you define N. Please be specific.
+-------------
+
+
+Here is a nicer procedure that computes the fringe, without any
+nasty re-copying.
+
+ (define (fringe subtree)
+ (define (walk subtree ans)
+ (cond ((pair? subtree)
+ (walk (car subtree)
+ (walk (cdr subtree) ans)))
+ ((null? subtree) ans)
+ (else (cons subtree ans))))
+ (walk subtree '()))
+
+So the "same fringe" problem appears really simple:
+
+ (define (same-fringe? tree1 tree2)
+ (equal? (fringe tree1) (fringe tree2)))
+
+Indeed, this works:
+
+ #|
+ (same-fringe? '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (f (g (h)))))
+ ;Value: #t
+
+ (same-fringe? '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f (h)))))
+ ;Value: #f
+ |#
+
+Unfortunately, this requires computing the entire fringe of each tree
+before comparing the fringes. Suppose that the trees were very big,
+but that they were likely to differ early in the fringe. This would
+be a terrible strategy. We would rather have a way of generating the
+next element of the fringe of each tree only as needed to compare them.
+
+One way to do this is with "lazy evaluation". This method requires
+examining only as much of the input trees as is necessary to decide
+when two fringes are not the same:
+
+ (define (lazy-fringe subtree)
+ (cond ((pair? subtree)
+ (stream-append-deferred (lazy-fringe (car subtree))
+ (lambda () (lazy-fringe (cdr subtree)))))
+ ((null? subtree) the-empty-stream)
+ (else (stream subtree))))
+
+ (define (lazy-same-fringe? tree1 tree2)
+ (let lp ((f1 (lazy-fringe tree1))
+ (f2 (lazy-fringe tree2)))
+ (cond ((and (stream-null? f1) (stream-null? f2)) #t)
+ ((or (stream-null? f1) (stream-null? f2)) #f)
+ ((eq? (stream-car f1) (stream-car f2))
+ (lp (stream-cdr f1) (stream-cdr f2)))
+ (else #f))))
+
+ (define (stream-append-deferred stream1 stream2-thunk)
+ (if (stream-pair? stream1)
+ (cons-stream (stream-car stream1)
+ (stream-append-deferred (stream-cdr stream1)
+ stream2-thunk))
+ (stream2-thunk)))
+
+ (define the-empty-stream (stream))
+
+ #|
+ (lazy-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (f (g (h)))))
+ ;Value: #t
+
+ (lazy-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f (h)))))
+ ;Value: #f
+ |#
+
+-------------
+Problem 8.2:
+
+This implementation of fringe has the same problem of copying the
+stream that our original fringe program had copying the list.
+
+A. What would have gone wrong had we not thunkified the second argument
+ to be appended and instead just used the stream-append procedure:
+
+ (define (stream-append stream1 stream2)
+ (if (stream-pair? stream1)
+ (cons-stream (stream-car stream1)
+ (stream-append (stream-cdr stream1) stream2))
+ stream2))
+
+B. Redefine lazy-fringe to be a stream-based program that eliminates this
+ re-copying while avoiding unnecessary subtree fringe generation, using
+ a technique similar to the "nicer" (walk-based) fringe above.
+ [Hint: Consider the cons-stream special form with deferred cdr walk.]
+-------------
+
+An alternative incremental idea is to make coroutines that generate
+the fringes, using an explicit continuation argument and local state.
+
+Notice that in the following code we invent a special object *done*.
+Because it is a newly consed list, this object is eq? only to itself,
+so it cannot be confused with any other object. This is a very common
+device for making unique objects.
+
+ (define *done* (list '*done*))
+
+ (define (coroutine-fringe-generator tree)
+ (define (resume-thunk)
+ (walk tree (lambda () *done*)))
+ (define (walk subtree continue)
+ (cond ((null? subtree)
+ (continue))
+ ((pair? subtree)
+ (walk (car subtree)
+ (lambda ()
+ (walk (cdr subtree)
+ continue))))
+ (else
+ (set! resume-thunk continue)
+ subtree)))
+ (lambda () (resume-thunk)))
+
+ (define (coroutine-same-fringe? tree1 tree2)
+ (let ((f1 (coroutine-fringe-generator tree1))
+ (f2 (coroutine-fringe-generator tree2)))
+ (let lp ((x1 (f1)) (x2 (f2)))
+ (cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
+ ((or (eq? x1 *done*) (eq? x2 *done*)) #f)
+ ((eq? x1 x2) (lp (f1) (f2)))
+ (else #f)))))
+
+Also notice the peculiar SET! assignment in this code. This makes it
+possible for the procedures f1 and f2 (two distinct results of calling
+the fringe generator) to maintain independent resume continuations
+each time they are re-invoked to proceed generating their fringes.
+This assignment is what gives each new fringe generator its own
+dynamic local state.
+
+ #|
+ (coroutine-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (f (g (h)))))
+ ;Value: #t
+
+ (coroutine-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f (h)))))
+ ;Value: #f
+ |#
+
+-------------
+Problem 8.3:
+
+Why is it necessary to use the expression "(lambda () (resume-thunk))"
+rather than just "resume-thunk" as the returned value of the fringe
+generator? Aren't they the same, by the eta rule of lambda calculus?
+-------------
+
+We can abstract this control structure, using continuations. Now
+things get very complicated. Here, a procedure that is to be used as
+a coroutine takes an argument: return. Its value is a thunk that can
+be called to start the coroutine computing.
+
+When the execution of the coroutine thunk calls the return procedure
+that was passed to its creator, it saves its state as a new thunk that
+invokes the continuation of the return. It then invokes a procedure
+with a value that the caller of the thunk will see as the value of the
+thunk.
+
+ (define (make-coroutine his-job) ;; his-job ::= (.\ (return) ...)
+ (let ((resume-thunk) (k_yield))
+
+ (define (my-job value)
+ (call-with-current-continuation
+ (lambda (k_his-job)
+ (set! resume-thunk (lambda () (k_his-job unspecific)))
+ (k_yield value))))
+
+ (define (his-job-coroutine-thunk)
+ (call-with-current-continuation
+ (lambda (k_my-job)
+ (set! k_yield k_my-job)
+ (resume-thunk))))
+
+ (set! resume-thunk (his-job my-job))
+
+ his-job-coroutine-thunk))
+
+With this abstraction, we can make a fringe generator producer and
+fringe comparator consumer rather elegantly:
+
+ (define *done* (list '*done*))
+
+ (define (acs-coroutine-same-fringe? tree1 tree2)
+ (let ((f1 (make-coroutine (acs-coroutine-fringe-generator tree1)))
+ (f2 (make-coroutine (acs-coroutine-fringe-generator tree2))))
+ (let lp ((x1 (f1)) (x2 (f2)))
+ (cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
+ ((or (eq? x1 *done*) (eq? x2 *done*)) #f)
+ ((eq? x1 x2) (lp (f1) (f2)))
+ (else #f)))))
+
+ (define (acs-coroutine-fringe-generator tree)
+ (lambda (return)
+
+ (define (lp tree)
+ (cond ((pair? tree)
+ (lp (car tree))
+ (lp (cdr tree)))
+ ((null? tree) unspecific)
+ (else
+ (return tree))))
+
+ (define (initial-generation-coroutine-thunk)
+ (lp tree)
+ (return *done*))
+
+ initial-generation-coroutine-thunk))
+
+ #|
+ (acs-coroutine-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (f (g (h)))))
+ ;Value: #t
+
+ (acs-coroutine-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f (h)))))
+ ;Value: #f
+
+ (acs-coroutine-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f ))))
+ ;Value: #f
+ |#
+
+-------------
+Problem 8.4:
+
+Suppose I accidentally left out the return when done, so that the last
+line of the fringe generator's initial generation coroutine thunk were
+just *done* rather than "(return *done*)". What behavior would I get?
+Why? (I actually made this mistake. It took me about a 1/2 hour to
+figure out what went wrong! --GJS)
+-------------
+
+
+ Communication among Threads
+
+Now that we are all warmed up about continuations, you are ready to
+look at the time-sharing thread code in "conspire.scm", and the
+parallel execution code in "try-two-ways.scm". The time-sharing
+monitor can easily implement coroutines. You have an example with an
+explicit thread-yield in the first simple example in "conspire.scm".
+The return procedure above can be thought of as a thread yield.
+However, the coroutines in the time-shared environment do not easily
+communicate except through shared variables.
+
+Time-sharing systems, such as GNU/Linux, provide explicit mechanisms,
+such as pipes, to make it easy for processes to communicate. A pipe is
+basically a FIFO communication channel which provides a reader and a
+writer. The writer puts things into the pipe and the reader takes
+them out. If we had pipes in conspire we could write the same-fringe?
+program as follows:
+
+ (define *done* (list '*done*))
+
+ (define (piped-same-fringe? tree1 tree2)
+ (let ((p1 (make-pipe)) (p2 (make-pipe)))
+ (let ((thread1
+ (conspire:make-thread
+ conspire:runnable
+ (lambda ()
+ (piped-fringe-generator tree1 (pipe-writer p1)))))
+ (thread2
+ (conspire:make-thread
+ conspire:runnable
+ (lambda ()
+ (piped-fringe-generator tree2 (pipe-writer p2)))))
+ (f1 (pipe-reader p1))
+ (f2 (pipe-reader p2)))
+ (let lp ((x1 (f1)) (x2 (f2)))
+ (cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
+ ((or (eq? x1 *done*) (eq? x2 *done*)) #f)
+ ((eq? x1 x2) (lp (f1) (f2)))
+ (else #f))))))
+
+ (define (piped-fringe-generator tree return)
+ (define (lp tree)
+ (cond ((pair? tree)
+ (lp (car tree))
+ (lp (cdr tree)))
+ ((null? tree) unspecific)
+ (else
+ (return tree))))
+ (lp tree)
+ (return *done*))
+
+-------------
+Problem 8.5:
+
+Implement the pipe mechanism implied by the program above. It should
+work under the conspire time-sharing monitor. Remember, if the pipe
+is empty a reader must wait until something is available to be read.
+Also, since this is supposed to work under preemptive time sharing,
+the pipe must be correctly interlocked.
+-------------
+
+With appropriate abstraction we can make the program look almost
+exactly the same as the coroutine version:
+
+ (define *done* (list '*done*))
+
+ (define (tf-piped-same-fringe? tree1 tree2)
+ (let ((f1 (make-threaded-filter (tf-piped-fringe-generator tree1)))
+ (f2 (make-threaded-filter (tf-piped-fringe-generator tree2))))
+ (let lp ((x1 (f1)) (x2 (f2)))
+ (cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
+ ((or (eq? x1 *done*) (eq? x2 *done*)) #f)
+ ((eq? x1 x2) (lp (f1) (f2)))
+ (else #f)))))
+
+ (define (tf-piped-fringe-generator tree)
+ (lambda (return)
+ (define (lp tree)
+ (cond ((pair? tree)
+ (lp (car tree))
+ (lp (cdr tree)))
+ ((null? tree) unspecific)
+ (else
+ (return tree))))
+ (lp tree)
+ (return *done*)))
+
+ #|
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (tf-piped-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (f (g (h)))))
+ ))
+ ;Value: #t
+
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (tf-piped-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f (h)))))
+ ))
+ ;Value: #f
+
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (tf-piped-same-fringe?
+ '((a b) c ((d)) e (f ((g h))))
+ '(a b c ((d) () e) (g (f ))))
+ ))
+ ;Value: #f
+ |#
+
+-------------
+Problem 8.6:
+
+Write make-threaded-filter to implement this interface. Demonstrate
+your program.
+-------------
+
+;;;; File: load.scm
+
+;; On The Fringes of Fun with Control Structures
+(load "same-fringe")
+
+;; Communication among Threads
+(load "conspire")
+(load "try-two-ways")
+
+':have-fun!
+
+;;;; File: conspire.scm
+
+;;;; CONSPIRE: Time Sharing in Scheme
+;;; "Processes scheming together
+;;; constitute a conspiracy"
+
+;;; The essence of this system is that the state of a
+;;; thread is specified by its continuation. To switch
+;;; threads we need to make a continuation, store it
+;;; for the scheduler, and then retrieve a thread from
+;;; the scheduler and start it running. The thread has
+;;; an identity, even though its continuation changes
+;;; from time to time.
+
+;;; A running thread can block itself until some
+;;; predicate thunk becomes true by calling
+;;; conspire:switch-threads with the predicate.
+
+(define (conspire:switch-threads runnable?)
+ (without-interrupts
+ (lambda ()
+ (conspire:save-current-thread runnable?
+ conspire:start-next-thread))))
+
+(define (conspire:save-current-thread runnable? after-save)
+ (call-with-current-continuation
+ (lambda (current-continuation)
+ (conspire:set-continuation! *running-thread*
+ current-continuation)
+ (conspire:add-to-schedule! runnable?
+ *running-thread*)
+ (after-save))))
+
+(define (conspire:start-next-thread)
+ (set! *running-thread*
+ (conspire:get-runnable-thread-from-schedule!))
+ ((conspire:continuation *running-thread*) unspecific))
+
+
+;;; A thread can explicitly yield control, remaining
+;;; runnable.
+
+(define (conspire:thread-yield)
+ (conspire:switch-threads conspire:runnable))
+
+(define conspire:runnable (lambda () #t))
+
+;;; A thread can kill itself by starting some other thread
+;;; without saving itself for rescheduling.
+
+(define (conspire:kill-current-thread)
+ (without-interrupts
+ (lambda ()
+ (conspire:start-next-thread))))
+
+(define (conspire:kill-threads threads)
+ (without-interrupts
+ (lambda ()
+ (for-each conspire:delete-from-schedule! threads)
+ (if (memq *running-thread* threads)
+ (conspire:kill-current-thread)))))
+
+;;; A thread can make another thread and continue running.
+;;; The thunk specified is the work order for the new thread.
+;;; When the thunk returns the thread kills itself.
+
+(define (conspire:make-thread runnable? thunk)
+ (call-with-current-continuation
+ (lambda (current-continuation)
+ (within-continuation *root-continuation*
+ (lambda ()
+ (without-interrupts
+ (lambda ()
+ (call-with-current-continuation
+ (lambda (new-continuation)
+ (let ((new-thread
+ (conspire:make-new-thread new-continuation)))
+ (conspire:add-to-schedule! runnable? new-thread)
+ (current-continuation new-thread))))))
+ (thunk)
+ (conspire:kill-current-thread))))))
+
+
+
+;;; A simple scheduler is just round-robin.
+
+(define (conspire:add-to-schedule! runnable? thread)
+ (queue:add-to-end! *thread-queue*
+ (cons runnable? thread)))
+
+(define (conspire:get-runnable-thread-from-schedule!)
+ (if (not (queue:empty? *thread-queue*))
+ (let lp ((first (queue:get-first *thread-queue*)))
+ (if ((car first)) ; runnable?
+ (cdr first)
+ (begin
+ (queue:add-to-end! *thread-queue* first)
+ (lp (queue:get-first *thread-queue*)))))
+ (error "No current thread")))
+
+(define (conspire:delete-from-schedule! thread)
+ (let ((entry
+ (find-matching-item
+ (queue:front-ptr *thread-queue*)
+ (lambda (entry)
+ (eq? (cdr entry) thread)))))
+ (if entry
+ (queue:delete-from-queue! *thread-queue*
+ entry))))
+
+;;; We use the queue design similar to SICP Section 3.3.2
+
+(define-record-type queue
+ (queue:make-record front-ptr rear-ptr)
+ queue?
+ (front-ptr queue:front-ptr queue:set-front-ptr!)
+ (rear-ptr queue:rear-ptr queue:set-rear-ptr!))
+
+(define (queue:make)
+ (queue:make-record '() '()))
+
+(define (queue:empty? queue)
+ (null? (queue:front-ptr queue)))
+
+(define (queue:get-first queue)
+ (if (null? (queue:front-ptr queue))
+ (error "get-first called with an empty queue" queue)
+ (let ((first (car (queue:front-ptr queue)))
+ (rest (cdr (queue:front-ptr queue))))
+ (queue:set-front-ptr! queue rest)
+ (if (null? rest)
+ (queue:set-rear-ptr! queue '()))
+ first)))
+
+(define (queue:add-to-end! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((null? (queue:front-ptr queue))
+ (queue:set-front-ptr! queue new-pair)
+ (queue:set-rear-ptr! queue new-pair))
+ (else
+ (set-cdr! (queue:rear-ptr queue) new-pair)
+ (queue:set-rear-ptr! queue new-pair))))
+ 'done)
+
+(define (queue:delete-from-queue! queue item)
+ (queue:set-front-ptr! queue
+ (delq item
+ (queue:front-ptr queue)))
+ (if (pair? (queue:front-ptr queue))
+ (queue:set-rear-ptr! queue
+ (last-pair (queue:front-ptr queue)))
+ (queue:set-rear-ptr! queue '()))
+ 'done)
+
+(define-record-type conspire:thread
+ (conspire:make-new-thread continuation)
+ conspire:thread?
+ (continuation conspire:continuation
+ conspire:set-continuation!))
+
+
+;;; Startup: have to make queue and first process
+
+(define (with-conspiracy thunk)
+ (fluid-let ((*running-thread*
+ (conspire:make-new-thread unspecific))
+ (*thread-queue* (queue:make))
+ (*root-continuation*))
+ (call-with-current-continuation
+ (lambda (k)
+ (set! *root-continuation* k)
+ (thunk)))))
+
+(define *running-thread*)
+
+(define *thread-queue*)
+
+(define *root-continuation*)
+
+#|
+;;; An elementary example:
+
+(define (loop n)
+ (let lp ((i 0))
+ (if (< global-counter 1)
+ 'done
+ (begin (set! global-counter (- global-counter 1))
+ (if (= i n)
+ (begin (write-line `(,n ,global-counter))
+ (conspire:thread-yield)
+ (lp 0))
+ (lp (+ i 1)))))))
+
+(define global-counter)
+
+(with-conspiracy
+ (lambda ()
+ (set! global-counter 200)
+ (conspire:make-thread conspire:runnable (lambda () (loop 31)))
+ (conspire:make-thread conspire:runnable (lambda () (loop 37)))
+ (repl/start (push-repl (nearest-repl/environment))
+ "; Entering conspiracy")))
+
+(pp *thread-queue*)
+#[queue 4]
+(front-ptr
+ ((#[compound-procedure 6 conspire:runnable] . #[conspire:thread 7])
+ (#[compound-procedure 6 conspire:runnable] . #[conspire:thread 5])))
+(rear-ptr
+ ((#[compound-procedure 6 conspire:runnable] . #[conspire:thread 5])))
+
+(conspire:thread-yield)
+(31 168)
+(37 130)
+;Unspecified return value
+
+;;; Got back to repl.
+
+(conspire:thread-yield)
+(31 98)
+(37 60)
+;Unspecified return value
+
+(conspire:thread-yield)
+(31 28)
+;Unspecified return value
+
+(conspire:thread-yield)
+;Unspecified return value
+
+(pp *thread-queue*)
+#[queue 4]
+(front-ptr ())
+(rear-ptr ())
+
+(abort->previous) ; Get out of repl.
+|#
+
+;;; Preemptive scheduling.
+
+(define conspire:quantum 10)
+
+(define conspire:running? #f)
+
+;;; This is an MIT Scheme specific detail. register-timer-event is
+;;; the MIT Scheme mechanism for delivering a timer interrupt -- when
+;;; the time specified by its first argument expires, it invokes the
+;;; second argument.
+
+(define (start-time-sharing)
+ (let lp ()
+ (if *debugging-time-sharing* (display "."))
+ (if conspire:running?
+ (begin
+ (register-timer-event conspire:quantum
+ lp)
+ (conspire:thread-yield))))
+ 'done)
+
+(define *debugging-time-sharing* #f)
+
+
+(define (with-time-sharing-conspiracy thunk)
+ (fluid-let ((conspire:running? #t))
+ (with-conspiracy
+ (lambda ()
+ (start-time-sharing)
+ (thunk)))))
+
+(define (conspire:null-job)
+ (conspire:thread-yield)
+ (if (queue:empty? *thread-queue*)
+ 'done
+ (conspire:null-job)))
+
+#|
+;;; Our elementary example, again
+
+(define (loop n)
+ (let lp ((i 0))
+ (if (< global-counter 1)
+ 'done
+ (begin (set! global-counter (- global-counter 1))
+ (if (= i n)
+ (begin (write-line `(,n ,global-counter))
+ (lp 0))
+ (lp (+ i 1)))))))
+
+
+(define global-counter)
+
+(with-time-sharing-conspiracy
+ (lambda ()
+ (set! global-counter 100000)
+ (conspire:make-thread conspire:runnable (lambda () (loop 5555)))
+ (conspire:make-thread conspire:runnable (lambda () (loop 4444)))
+ (conspire:null-job)))
+
+(5555 94444)
+(5555 88888)
+(5555 83332)
+(5555 77776)
+(4444 71412)
+(4444 66967)
+(4444 62522)
+(4444 58077)
+(4444 53632)
+(4444 49187)
+(4444 44742)
+(5555 39853)
+(5555 34297)
+(5555 28741)
+(5555 23185)
+(5555 17629)
+(4444 9782)
+(4444 5337)
+(4444 892)
+;Value: done
+|#
+
+;;; Interlocks
+
+(define-record-type conspire:lock
+ (conspire:make-lock-cell state)
+ conspire:lock?
+ (state conspire:lock-state conspire:set-lock-state!))
+
+(define (conspire:make-lock)
+ (conspire:make-lock-cell #f))
+
+(define (test-and-set-lock?! cell)
+ (if (not (conspire:lock? cell))
+ (error "Bad lock"))
+ (without-interrupts
+ (lambda ()
+ (if (eq? (conspire:lock-state cell) #f)
+ (begin (conspire:set-lock-state! cell #t)
+ #t)
+ #f))))
+
+(define (conspire:unlock cell)
+ (conspire:set-lock-state! cell #f))
+
+(define (conspire:acquire-lock lock)
+ (if (test-and-set-lock?! lock)
+ 'OK
+ (conspire:switch-threads
+ (lambda () (test-and-set-lock?! lock)))))
+
+#|
+;;; Our elementary example again:
+
+(define global-counter-lock (conspire:make-lock))
+
+(define (loop n)
+ (let lp ((i 0))
+ (let delaylp ((k 100))
+ (if (> k 0)
+ (delaylp (- k 1))))
+ (conspire:acquire-lock global-counter-lock)
+ (if (< global-counter 1)
+ (begin
+ (conspire:unlock global-counter-lock)
+ 'done)
+ (begin (set! global-counter (- global-counter 1))
+ (if (= i n)
+ (begin (write-line `(,n ,global-counter))
+ (conspire:unlock global-counter-lock)
+ (lp 0))
+ (begin
+ (conspire:unlock global-counter-lock)
+ (lp (+ i 1)))))))
+ (write-line `(,n terminating)))
+
+(define global-counter)
+
+(set! conspire:quantum 5)
+
+(with-time-sharing-conspiracy
+ (lambda ()
+ (set! global-counter 100000)
+ (conspire:make-thread conspire:runnable (lambda () (loop 999)))
+ (conspire:make-thread conspire:runnable (lambda () (loop 1000)))
+ (conspire:null-job)))
+|#
+
+;;;; File: try-two-ways.scm
+
+(define (try-two-ways thunk1 thunk2)
+ (let ((value) (done? #f))
+ (let ((thread1
+ (conspire:make-thread
+ conspire:runnable
+ (lambda ()
+ (set! value (thunk1))
+ (set! done? #t))))
+ (thread2
+ (conspire:make-thread
+ conspire:runnable
+ (lambda ()
+ (set! value (thunk2))
+ (set! done? #t)))))
+
+ (conspire:switch-threads
+ (lambda () done?))
+
+ (conspire:kill-threads
+ (list thread1 thread2))
+
+ value)))
+
+(define (test n1 n2)
+ (with-conspiracy
+ (lambda ()
+ (try-two-ways
+ (lambda ()
+ (let lp ((n n1))
+ (if (= n 0)
+ 'a-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (begin (display 'a)
+ (conspire:thread-yield)))
+ (lp (- n 1))))))
+ (lambda ()
+ (let lp ((n n2))
+ (if (= n 0)
+ 'b-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (begin (display 'b)
+ (conspire:thread-yield)))
+ (lp (- n 1))))))))))
+
+#|
+(test 1000000 1200000)
+ababababababababababab
+;Value: a-done
+
+(test 1200000 1000000)
+babababababababababaa
+;Value: b-done
+|#
+
+(define (test1 n1 n2)
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (try-two-ways
+ (lambda ()
+ (let lp ((n n1))
+ (if (= n 0)
+ 'a-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (display 'a))
+ (lp (- n 1))))))
+ (lambda ()
+ (let lp ((n n2))
+ (if (= n 0)
+ 'b-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (display 'b))
+ (lp (- n 1))))))))))
+
+#|
+(test1 1000000 1200000)
+baabbaabbaabbaabbaabb
+;Value: a-done
+
+(test1 1200000 1000000)
+babaabbaabbaabbaabbaa
+;Value: b-done
+|#
+
+;;; Interesting example
+
+;;; Suppose we want to search a list, that
+;;; may be infinite (circular). We could
+;;; use the fast algorithm, but sometimes
+;;; go into an infinite loop, or we could
+;;; use the slow algorithm that marks the
+;;; list (with a hash table) but always
+;;; works. If the statistics are right,
+;;; a better strategy is to time-share the
+;;; two methods and take the one which
+;;; finishes first:
+
+(define (safe-mem? item lst)
+ (let ((table (make-eq-hash-table)))
+ (let lp ((lst lst))
+ (if (pair? lst)
+ (if (hash-table/get table lst #f)
+ #f ;circular
+ (if (eq? item (car lst))
+ #t
+ (begin
+ (hash-table/put! table lst #t)
+ (lp (cdr lst)))))
+ #f))))
+
+(define (unsafe-mem? item lst)
+ (let lp ((lst lst))
+ (if (pair? lst)
+ (if (eq? item (car lst))
+ #t
+ (lp (cdr lst)))
+ #f)))
+
+#|
+(define foo (list 'a 'b 'c 'd))
+;Value: foo
+
+(begin (set-cdr! (last-pair foo) foo) 'foo)
+;Value: foo
+
+(unsafe-mem? 'b foo)
+;Value: #t
+
+(unsafe-mem? 'e foo)
+;Quit!
+
+(safe-mem? 'b foo)
+;Value: #t
+
+(safe-mem? 'e foo)
+;Value: #f
+|#
+
+(define (mem? item lst)
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (try-two-ways
+ (lambda ()
+ (unsafe-mem? item lst))
+ (lambda ()
+ (safe-mem? item lst))))))
+
+#|
+(mem? 'b foo)
+;Value: #t
+
+(mem? 'e foo)
+;Value: #f
+|#
diff --git a/ps08_conspiracies/try-two-ways.scm b/ps08_conspiracies/try-two-ways.scm
new file mode 100644
index 0000000..472fa19
--- /dev/null
+++ b/ps08_conspiracies/try-two-ways.scm
@@ -0,0 +1,157 @@
+(define (try-two-ways thunk1 thunk2)
+ (let ((value) (done? #f))
+ (let ((thread1
+ (conspire:make-thread
+ conspire:runnable
+ (lambda ()
+ (set! value (thunk1))
+ (set! done? #t))))
+ (thread2
+ (conspire:make-thread
+ conspire:runnable
+ (lambda ()
+ (set! value (thunk2))
+ (set! done? #t)))))
+
+ (conspire:switch-threads
+ (lambda () done?))
+
+ (conspire:kill-threads
+ (list thread1 thread2))
+
+ value)))
+
+(define (test n1 n2)
+ (with-conspiracy
+ (lambda ()
+ (try-two-ways
+ (lambda ()
+ (let lp ((n n1))
+ (if (= n 0)
+ 'a-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (begin (display 'a)
+ (conspire:thread-yield)))
+ (lp (- n 1))))))
+ (lambda ()
+ (let lp ((n n2))
+ (if (= n 0)
+ 'b-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (begin (display 'b)
+ (conspire:thread-yield)))
+ (lp (- n 1))))))))))
+
+#|
+(test 1000000 1200000)
+ababababababababababab
+;Value: a-done
+
+(test 1200000 1000000)
+babababababababababaa
+;Value: b-done
+|#
+
+(define (test1 n1 n2)
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (try-two-ways
+ (lambda ()
+ (let lp ((n n1))
+ (if (= n 0)
+ 'a-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (display 'a))
+ (lp (- n 1))))))
+ (lambda ()
+ (let lp ((n n2))
+ (if (= n 0)
+ 'b-done
+ (begin
+ (if (= (remainder n 100000) 0)
+ (display 'b))
+ (lp (- n 1))))))))))
+
+#|
+(test1 1000000 1200000)
+baabbaabbaabbaabbaabb
+;Value: a-done
+
+(test1 1200000 1000000)
+babaabbaabbaabbaabbaa
+;Value: b-done
+|#
+
+;;; Interesting example
+
+;;; Suppose we want to search a list, that
+;;; may be infinite (circular). We could
+;;; use the fast algorithm, but sometimes
+;;; go into an infinite loop, or we could
+;;; use the slow algorithm that marks the
+;;; list (with a hash table) but always
+;;; works. If the statistics are right,
+;;; a better strategy is to time-share the
+;;; two methods and take the one which
+;;; finishes first:
+
+(define (safe-mem? item lst)
+ (let ((table (make-eq-hash-table)))
+ (let lp ((lst lst))
+ (if (pair? lst)
+ (if (hash-table/get table lst #f)
+ #f ;circular
+ (if (eq? item (car lst))
+ #t
+ (begin
+ (hash-table/put! table lst #t)
+ (lp (cdr lst)))))
+ #f))))
+
+(define (unsafe-mem? item lst)
+ (let lp ((lst lst))
+ (if (pair? lst)
+ (if (eq? item (car lst))
+ #t
+ (lp (cdr lst)))
+ #f)))
+
+#|
+(define foo (list 'a 'b 'c 'd))
+;Value: foo
+
+(begin (set-cdr! (last-pair foo) foo) 'foo)
+;Value: foo
+
+(unsafe-mem? 'b foo)
+;Value: #t
+
+(unsafe-mem? 'e foo)
+;Quit!
+
+(safe-mem? 'b foo)
+;Value: #t
+
+(safe-mem? 'e foo)
+;Value: #f
+|#
+
+(define (mem? item lst)
+ (with-time-sharing-conspiracy
+ (lambda ()
+ (try-two-ways
+ (lambda ()
+ (unsafe-mem? item lst))
+ (lambda ()
+ (safe-mem? item lst))))))
+
+#|
+(mem? 'b foo)
+;Value: #t
+
+(mem? 'e foo)
+;Value: #f
+|#