391 lines
11 KiB
Scheme
391 lines
11 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; Multitasking
|
|
|
|
; A thread has:
|
|
; - dynamic environment
|
|
; - continuation: #f if the thread is current or finished,
|
|
; a primitive continuation otherwise.
|
|
; - env-for-spawn - initial dynamic environment for threads spawned
|
|
; by this thread
|
|
; - run status (active, stopped, done) - used only for stop & start
|
|
; operations
|
|
; - uid - no semantic content.
|
|
|
|
; Date: Mon, 31 Aug 92 18:17:23 -0400
|
|
; From: "Guillermo J. Rozas" <jinx@zurich.ai.mit.edu>
|
|
;
|
|
; 1: Instead of requesting a periodic timer interrupt from the system,
|
|
; request one-shot interrupts, and re-request at the end of each throw
|
|
; (in the argument to within-continuation). Thus the time to "task
|
|
; switch" becomes "system time" and each thread gets the full time
|
|
; slice.
|
|
|
|
|
|
; Threads
|
|
|
|
(define-record-type thread :thread
|
|
(really-make-thread dynamic-env
|
|
continuation env-for-spawn
|
|
status queue uid name)
|
|
thread?
|
|
(dynamic-env thread-dynamic-env) ;Must be first! (See fluid.scm)
|
|
(continuation thread-continuation set-thread-continuation!)
|
|
(env-for-spawn thread-env-for-spawn)
|
|
(status thread-status set-thread-status!)
|
|
(queue thread-queue set-thread-queue!)
|
|
(uid thread-uid)
|
|
(name thread-name)) ;for debugging
|
|
|
|
(define *thread-uid* 0)
|
|
|
|
(define (make-thread thunk env-for-spawn name)
|
|
(let ((thread (really-make-thread env-for-spawn
|
|
(compose-continuation
|
|
(lambda (ignore)
|
|
(thread-top-level thunk))
|
|
#f)
|
|
env-for-spawn
|
|
'stopped
|
|
runnable-threads
|
|
*thread-uid*
|
|
name)))
|
|
(set! *thread-uid* (+ *thread-uid* 1))
|
|
thread))
|
|
|
|
(define (thread-top-level thunk)
|
|
(set-enabled-interrupts! all-interrupts)
|
|
(thunk)
|
|
(finish-current-thread))
|
|
|
|
(define (finish-current-thread)
|
|
(set-enabled-interrupts! no-interrupts)
|
|
(set-thread-status! (current-thread) 'done)
|
|
(schedule-thread (another-thread)))
|
|
|
|
; Spawn a new thread
|
|
|
|
(define (spawn thunk . name-option)
|
|
(let* ((name (if (null? name-option) #f (car name-option)))
|
|
(thread (make-thread thunk
|
|
(thread-env-for-spawn (current-thread))
|
|
name)))
|
|
(start-thread thread)
|
|
thread))
|
|
|
|
|
|
; --------------------
|
|
; Scheduler
|
|
|
|
(define runnable-threads (make-queue))
|
|
|
|
(define (make-ready! thread)
|
|
(move-to-queue thread runnable-threads))
|
|
|
|
(define (handle-timer-interrupt ei)
|
|
;; Interrupts are disabled at this point
|
|
(schedule-interrupt *quantum*) ;Allow another one to come along
|
|
;; (dispatch)
|
|
(make-ready! (current-thread))
|
|
(switch-to-thread (another-thread)) ;(suspend-this-thread)
|
|
(set-enabled-interrupts! ei))
|
|
|
|
(define (suspend-this-thread) ;Call this with interrupts disabled
|
|
(switch-to-thread (another-thread)))
|
|
|
|
(define (switch-to-thread thread)
|
|
(primitive-cwcc
|
|
(lambda (cont)
|
|
(set-thread-continuation! (current-thread) cont)
|
|
(schedule-thread thread))))
|
|
|
|
(define (schedule-thread thread) ;Call with interrupts disabled
|
|
(set-current-thread! thread)
|
|
(schedule-interrupt *quantum*)
|
|
(let ((cont (thread-continuation (current-thread))))
|
|
(set-thread-continuation! (current-thread) #f)
|
|
(with-continuation cont unspecific)))
|
|
|
|
(define (unspecific) (if #f #f))
|
|
|
|
(define (another-thread) ;Call with interrupts disabled
|
|
(if (queue-empty? runnable-threads)
|
|
(begin (signal 'deadlock)
|
|
(error "no threads to run"))
|
|
(dequeue runnable-threads)))
|
|
|
|
(define (dispatch) ;Interrupts disabled
|
|
(make-ready! (current-thread))
|
|
(suspend-this-thread))
|
|
|
|
|
|
(define (relinquish-timeslice)
|
|
(with-interrupts-inhibited dispatch))
|
|
|
|
; --------------------
|
|
; Initialization
|
|
|
|
; (with-multitasking thunk) initializes for multitasking, then starts
|
|
; up a thread for the execution of thunk. That thread and all others
|
|
; created will run in the dynamic context of the call to
|
|
; with-multitasking. The call to with-multitasking finally returns
|
|
; only when the scheduler runs out of things to do.
|
|
|
|
(define interrupt/alarm (enum interrupt alarm))
|
|
|
|
(define (with-multitasking thunk)
|
|
(set! runnable-threads (make-queue))
|
|
(set! *quantum* (quotient one-second 2))
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(let ((swap! (let ((save handle-timer-interrupt))
|
|
(lambda ()
|
|
(schedule-interrupt 0) ;Turn off alarm
|
|
(let ((temp
|
|
(vector-ref interrupt-handlers interrupt/alarm)))
|
|
(vector-set! interrupt-handlers interrupt/alarm save)
|
|
(set! save temp))))))
|
|
(dynamic-wind
|
|
swap!
|
|
(lambda ()
|
|
(call-with-current-continuation
|
|
(lambda (deadlock)
|
|
(with-handler (lambda (c punt)
|
|
(if (deadlock? c) (deadlock 0) (punt)))
|
|
(lambda ()
|
|
(call-with-current-continuation
|
|
(lambda (terminate)
|
|
(with-handler (lambda (c punt)
|
|
(if (terminate? c)
|
|
(terminate 0)
|
|
(punt)))
|
|
(lambda ()
|
|
;; Schedule-thread never returns.
|
|
(schedule-thread (make-thread thunk
|
|
(get-dynamic-env)
|
|
'initial))))))
|
|
;; Interrupts enabled here, probably
|
|
(finish-current-thread))))))
|
|
swap!)))))
|
|
|
|
(define-condition-type 'terminate '())
|
|
(define terminate? (condition-predicate 'terminate))
|
|
(define-condition-type 'deadlock '())
|
|
(define deadlock? (condition-predicate 'deadlock))
|
|
|
|
(define *quantum* #f)
|
|
|
|
(define no-interrupts 0)
|
|
|
|
; --------------------
|
|
; Random operations: start, stop, kill, interrupt
|
|
|
|
(define (terminate-current-thread)
|
|
(signal 'terminate)
|
|
(error "can't terminate current thread")
|
|
0) ;suppress compiler warning
|
|
|
|
(define (start-thread thread)
|
|
(if (thread? thread)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(if (eq? (thread-status thread) 'stopped)
|
|
(begin (set-thread-status! thread 'active)
|
|
(move-to-queue (current-thread) runnable-threads)
|
|
(switch-to-thread thread)
|
|
#t)
|
|
(eq? (thread-status thread) 'active))))
|
|
(call-error "invalid argument" start-thread thread)))
|
|
|
|
(define (stop-thread thread)
|
|
(if (thread? thread)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(if (eq? (thread-status thread) 'active)
|
|
(let ((q (thread-queue thread)))
|
|
(if q (delete-from-queue! q thread))
|
|
(set-thread-status! thread 'stopped)
|
|
(if (eq? thread (current-thread))
|
|
(suspend-this-thread))
|
|
#t)
|
|
(eq? (thread-status thread) 'stopped))))
|
|
(call-error "invalid argument" stop-thread thread)))
|
|
|
|
(define (kill-thread thread)
|
|
(interrupt-thread thread terminate-current-thread))
|
|
|
|
(define (interrupt-thread thread thunk)
|
|
(if (thread? thread)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(cond ((eq? thread (current-thread))
|
|
(thunk))
|
|
((stop-thread thread)
|
|
(set-thread-queue! thread runnable-threads)
|
|
(set-thread-continuation!
|
|
thread
|
|
(compose-continuation
|
|
(lambda (ignore)
|
|
(thunk))
|
|
(or (thread-continuation thread)
|
|
(error "this shouldn't happen" thread))))
|
|
(start-thread thread))
|
|
(else #f))))
|
|
(call-error "invalid argument" interrupt-thread thread)))
|
|
|
|
(define (move-to-queue thread q)
|
|
(set-thread-queue! thread q)
|
|
(enqueue q thread))
|
|
|
|
; --------------------
|
|
; Locks (= semaphores)
|
|
|
|
(define-record-type lock :lock
|
|
(really-make-lock owner queue uid)
|
|
lock?
|
|
(owner lock-owner set-lock-owner!)
|
|
(queue lock-queue)
|
|
(uid lock-uid))
|
|
|
|
(define *lock-uid* 0)
|
|
|
|
(define (make-lock)
|
|
(let ((uid *lock-uid*))
|
|
(set! *lock-uid* (+ uid 1))
|
|
(really-make-lock #f (make-queue) uid)))
|
|
|
|
(define (obtain-lock lock) ;Interrupts enabled
|
|
(if (lock? lock)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(let loop ()
|
|
(if (let ((owner (lock-owner lock)))
|
|
(and owner
|
|
(not (eq? owner (current-thread)))
|
|
(not (eq? (thread-status owner) 'done))))
|
|
(begin (move-to-queue (current-thread)
|
|
(lock-queue lock))
|
|
(suspend-this-thread)
|
|
(loop))
|
|
(set-lock-owner! lock (current-thread))))))
|
|
(call-error "invalid argument" obtain-lock lock)))
|
|
|
|
(define (release-lock lock) ;Interrupts enabled
|
|
(if (eq? (lock-owner lock) (current-thread))
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(set-lock-owner! lock #f)
|
|
(if (not (queue-empty? (lock-queue lock)))
|
|
(begin (make-ready! (current-thread))
|
|
(switch-to-thread (dequeue (lock-queue lock)))))))))
|
|
|
|
(define (with-lock lock thunk) ;Interrupts enabled
|
|
(if (eq? (lock-owner lock) (current-thread))
|
|
(thunk)
|
|
(dynamic-wind (lambda () (obtain-lock lock))
|
|
thunk
|
|
(lambda () (release-lock lock)))))
|
|
|
|
|
|
; --------------------
|
|
; Condition variables (single-assignment cells)
|
|
|
|
(define-record-type condvar :condvar
|
|
(really-make-condvar queue id)
|
|
condvar?
|
|
(queue condvar-queue set-condvar-queue!) ; #f means it has been set
|
|
(value condvar-value set-condvar-value!)
|
|
(id condvar-id))
|
|
|
|
(define (make-condvar . id-option)
|
|
(really-make-condvar (make-queue)
|
|
(if (null? id-option) #f (car id-option))))
|
|
|
|
(define (condvar-ref condvar) ;Interrupts enabled
|
|
(if (condvar? condvar)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(let loop ()
|
|
(if (condvar-queue condvar)
|
|
(begin (move-to-queue (current-thread)
|
|
(condvar-queue condvar))
|
|
(suspend-this-thread)
|
|
(loop))
|
|
(condvar-value condvar)))))
|
|
(call-error "invalid argument" condvar-ref condvar)))
|
|
|
|
(define (condvar-set! condvar value) ;Interrupts enabled
|
|
(if (condvar? condvar)
|
|
(if (with-interrupts-inhibited
|
|
(lambda ()
|
|
(let ((q (condvar-queue condvar)))
|
|
(if q
|
|
(begin (set-condvar-value! condvar value)
|
|
(set-condvar-queue! condvar #f)
|
|
(if (queue-empty? q)
|
|
#f
|
|
(let ((first (dequeue q)))
|
|
(let loop ()
|
|
(if (queue-empty? q)
|
|
(begin (make-ready! (current-thread))
|
|
(switch-to-thread first)
|
|
#f)
|
|
(begin (make-ready! (dequeue q))
|
|
(loop)))))))
|
|
;; OK to store the same value twice.
|
|
(not (eq? value (condvar-value condvar)))))))
|
|
(error "condition variable is already assigned"
|
|
(condvar-value condvar) value))
|
|
(call-error "invalid argument" condvar-set! condvar value)))
|
|
|
|
(define (kill-condvar condvar)
|
|
(for-each kill-thread (with-interrupts-inhibited
|
|
(lambda ()
|
|
(if (condvar-queue condvar)
|
|
(queue->list (condvar-queue condvar))
|
|
'())))))
|
|
|
|
|
|
; --------------------
|
|
; Input
|
|
|
|
(define (thread-read-char port)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(let loop ()
|
|
(if (char-ready? port)
|
|
(read-char port)
|
|
(begin (dispatch)
|
|
(loop)))))))
|
|
|
|
(define (thread-peek-char port)
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(let loop ()
|
|
(if (char-ready? port)
|
|
(peek-char port)
|
|
(begin (dispatch)
|
|
(loop)))))))
|
|
|
|
; --------------------
|
|
; Silliness
|
|
|
|
(define (active-threads) ;debugging utility
|
|
(with-interrupts-inhibited
|
|
(lambda ()
|
|
(queue->list runnable-threads))))
|
|
|
|
|
|
(define-record-discloser :thread
|
|
(lambda (thread)
|
|
(cons 'thread
|
|
(cons (thread-uid thread)
|
|
(let ((name (thread-name thread)))
|
|
(if name
|
|
(list name)
|
|
'()))))))
|
|
|
|
;(put 'with-interrupts-inhibited 'scheme-indent-hook 0)
|
|
;(put 'with-handler 'scheme-indent-hook 1)
|