summaryrefslogtreecommitdiffstats
path: root/ps08_conspiracies/conspire.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ps08_conspiracies/conspire.scm')
-rw-r--r--ps08_conspiracies/conspire.scm383
1 files changed, 383 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)))
+|#