diff options
Diffstat (limited to 'ps08_conspiracies')
| -rw-r--r-- | ps08_conspiracies/conspire.scm | 383 | ||||
| -rw-r--r-- | ps08_conspiracies/load.scm | 8 | ||||
| -rw-r--r-- | ps08_conspiracies/ps.txt | 1013 | ||||
| -rw-r--r-- | ps08_conspiracies/try-two-ways.scm | 157 |
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 +|# |