[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Engine operating system (long msg)
/* ---------- "Concurrency in Scheme" ---------- */
From: VERACSD@a.isi.edu
I am in the process of writing a metacircular Lisp interpreter which
accommodates concurrent programming constructs (e.g. parbegin/parend's
and semaphores) and have recently come across *engines* in PC Scheme.
Engines seem like they offer much potential for this sort of thing,
however, they seem somewhat tricky. It is especially unclear to me
how to elegantly handle waits & signals for semaphores.
(There must be a better way than Ben-Ari's Pascal concurreny simulator.)
Any advice, pointers to sources, or code would be much appreciated.
Cris Kobryn
VERACSD.CK@A.ISI.EDU
I also felt their must be a better way thay the Pascal Concurrency
simulator to expose my operating systems classes to concurrency
problems in a high level language. This helped motivate the design of
engines. Here is a simple engine operating system (dispatcher with
semaphores and a few other primitive process operations) that I give
my class, along with some primitive documentation. I hope you enjoy
them.
Chris Haynes
haynes@iuvax.cs.indiana.edu
-----------------------------------------------------------------------------
SCHEME ENGINE OPERATING SYSTEM
Preliminary Documentation
(Spring, 1987)
Christopher T. Haynes
The engine mechanism is documented in the paper "An abstraction of
timed preemption" by C. T. Haynes and D. P. Friedman, to appear in
Computer Languages and also available as Indiana University Computer
Science Department Technical Report No. 178. This paper outlines a
simple dispatcher, similar to that used in this operating system. The
operating system (actually, it is just a dispatcher with trap handler)
documented here is intended to be as simple as possible, yet still be
useful for solving synchronization problems.
No attempt has been made to make this operating system secure. For
example, only the semaphore implementation should be allowed to issue
a WAIT or SIGNAL trap, but this restriction is not enforced. A more
elaborate operating system with a secure semaphore implementation is
described in an earlier paper by Haynes and Friedman, entitled
"Engines build process abstractions," which appeared in the Conference
Record of the 1984 ACM Symposium on LISP and Functional Programming,
pages 18-24.
This operating system is supplied in its Chez Scheme version, but it
may be easily ported to PC Scheme or Scheme84, the other two Scheme
implementations that provide engines.
To run the operating system (after loading it), use
(boot)
This starts the operating system with a single process that runs the
procedure bound to BOOT-THUNK, which is initially defined to be a
read-eval-print loop with the "os>" prompt. To exit from the
operating system, simply (RESET) or make an error!
Whenever any process reads input, time stops! For example, when the
read-eval-print process reads, all computation stops until an
expression has been read.
(spin <n>)
simply loops <n> times. This is a good way for the read-eval-print
process to kill time and let other processes run.
There are two ways to create additional processes.
(parbegin <exp1> ... <expn>)
creates n processes which evaluate <exp1> ... <expn> in parallel while
the parent process (the one that evaluated the PARBEGIN expression) is
blocked, and remains blocked until all the new processes finish
evaluating their expressions and terminate.
(trap 'fork <thunk>)
creates a new process that thaws <thunk>. The thunk should never
return; if it does you get the error message "process tried to
return". The fork operation returns a process object.
(trap 'block <p>)
and
(trap 'unblock <p>)
respectively block and unblock the process associated with process
object <p>.
(trap 'self)
returns the process object of the current proces.
(trap 'pause)
causes the current process to relinquish the rest of its time slice.
Semaphores are the synchronization mechanism of this operating system.
(make-semaphore <n>)
returns a new (general) semaphore with initial value <n>. Semaphores are
objects that respond to the messages WAIT and SIGNAL. That is, if <s>
is a semaphore, then
(<s> 'signal)
and
(<s> 'wait)
are the usual semaphore operations.
The time slice size (in engine ticks) is determined with each
dispatch by thawing the thunk bound to TIME-SLICE. Decreasing the
time slice trades off efficiency for a higher probability of finding
synchronization bugs. Randomness in the time slice increases the
chance of finding bugs by repeating the same test programs, but means
that bugs may not repeatable. Initially, TIME-SLICE is defined to be
(lambda () (+ 5 (random 10))))
The variable DISPATCH-COUNT is incremented with each dispatch. This
provides processes with a crude measure of time.
Assume the file "demo.ss", which follows, has been loaded.
(define time-slice
(lambda () (+ 1 (random 2))))
(define inc-count
(lambda (n)
(recur loop ((n n))
(when (positive? n)
(set!! count (1+ count))
(loop (- n 1))))))
(define count 0)
(define demo
(lambda ()
(set! count 0)
(parbegin (inc-count 100) (inc-count 100))
count))
(define grind
(lambda (x n)
(trap 'fork
(lambda ()
(recur loop ()
(display x)
(flush-output *standard-output*)
(spin n)
(loop))))))
(define a nil)
(define b nil)
(define c nil)
(define s nil)
(define abc
(lambda ()
(set! a (grind 'a 10))
(set! b (grind 'b 20))
(set! c (grind 'c 30))
(set! s (trap 'self))))
We then obtain the following transcript:
> (boot)
os> (demo)
121
os> (demo)
115
os> (abc)
abc#<closure>
os> (spin 50)
aabacaba()
os> (trap 'block a)
*
os> (spin 50)
bcb()
cos> (trap 'block b)
*
os> (spin 100)
ccc()
os> (trap 'unblock b)
b*
os> (spin 100)
cbcbcbb()
os> (reset)
>
When programming in this system using Chez Scheme, use the mutation
operators SET!!, SET-CAR!!, SET-CDR!!, SWAP-BOX!!, SET-BOX!! and
SET-VECTOR!! (instead of the single bang versions) in order to have
more opportunity of discovering synchronization bugs.
Ready processes are maintained in a ring data structure, and processes
blocked on semaphores are kept in queues that are also made of rings.
Processes are ring objects created by MAKE-RING.
MAKE-RING takes a single argument and returns a ring element whose
initial value is the argument value. A ring is a doubly linked
circular list, which may be referenced by any one of its elements. A
ring element, r, respond to messages as follows:
value Returns the current value of r.
set-value! Returns a function that takes a value and makes it the
new value of r.
singleton? Returns true if r is a singleton--a single element ring,
and false otherwise.
left Returns the element to the left of r in the ring.
right Returns the element to the right of r in the ring.
delete! Deletes r, which must not be a singleton, from the ring.
r then becomes a singleton.
insert-left! Returns a function that takes a ring element, which must be
a singleton, and inserts it in the ring to the left of r.
insert-right! Returns a function that takes a ring element, which must be
a singleton, and inserts it in the ring to the left of r.
MAKE-QUEUE is a function of no arguments that returns a new queue
object. Queues are implemented as rings with a distinguished
element, the mark, that separates the head and tail of the queue. A
queue object, q, responds to the following messages as follows:
enq! Returns a functions that takes a ring element and inserts
it at the tail of the queue.
deq! Removes a ring element from the head of the queue and
returns it.
empty? Returns true if the queue is empty, and false otherwise.
-----------------------------------------------------------------------------
;;; Engine Operting System
;;;
;;; Chez Scheme Verion, Spring 1987.
;;;
;;; Author: Chris Haynes (haynes@iuvax.cs.indiana.edu)
;;;
(define-macro! set!! (name value) `(set! ,name (I ,value)))
(define-macro! parbegin exps
`(parbegin-thunks (list . ,(map (lambda (exp) `(lambda () ,exp))
exps))))
(define set-car!! (lambda (pair obj) (set-car! pair obj)))
(define set-cdr!! (lambda (pair obj) (set-cdr! pair obj)))
(define swap-box!! (lambda (box obj) (swap-box! box obj)))
(define set-box!! (lambda (box obj) (set-box! box obj)))
(define vector-set!! (lambda (vector n obj) (vector-set! vector n obj)))
(define I (lambda (x) x))
(define make-ring
(let ((singleton? (lambda (elt) (eq? (cadr elt) elt)))
(key (box 'unique)))
(lambda (value)
(let* ((elt (cons '* '*))
(cdr-elt (cons elt elt)))
(set-cdr!! elt cdr-elt)
(set-car!! elt
(lambda (msg)
(if (eq? msg key)
elt
(case msg
(value value)
(set-value! (lambda (x) (set!! value x)))
(singleton? (singleton? elt))
(left (caar cdr-elt))
(right (cadr cdr-elt))
(delete!
(if (singleton? elt)
(error 'make-ring
"can't delete singleton ring")
(begin
(set-cdr!! (cdar cdr-elt) (cdr cdr-elt))
(set-car!! (cddr cdr-elt) (car cdr-elt))
(set-cdr!! cdr-elt elt)
(set-car!! cdr-elt elt)
'*)))
(insert-left!
(lambda (ring)
(if (ring 'singleton?)
(let ((elt2 (ring key)))
(set-car!! (cdr elt2) (car cdr-elt))
(set-cdr!! (cdr elt2) elt)
(set-cdr!! (cdar cdr-elt) elt2)
(set-car!! cdr-elt elt2)
'*)
(error 'make-ring
"can't insert non-singleton"))))
(insert-right!
(lambda (ring)
(if (ring 'singleton?)
(let ((elt2 (ring key)))
(set-car!! (cdr elt2) elt)
(set-cdr!! (cdr elt2) (cdr cdr-elt))
(set-car!! (cddr cdr-elt) elt2)
(set-cdr!! cdr-elt elt2)
'*)
(error 'make-ring
"can't insert non-singleton"))))
(else (ferror 'make-ring
"bad message to ring: ~a" msg))))))
(car elt)))))
(define make-queue
(lambda ()
(let ((mark (make-ring '())))
(lambda (msg)
(case msg
(enq! (mark 'insert-left!))
(deq! (if (mark 'singleton?)
(error 'make-queue "can't dequeue from empty queue")
(let ((r (mark 'right)))
(r 'delete!)
r)))
(empty? (mark 'singleton?))
(else (ferror 'make-queue "bad message to queue: ~a" msg)))))))
(define running #f)
(define dispatch-count 0)
(define dispatch
(letrec ((k-pt car)
(args-pt cdr)
(fail (lambda (eng) eng))
(success (lambda (trap-val ticks-remaining)
(let* ((ans (apply trap-handler (args-pt trap-val)))
(new-engine (make-engine
(lambda ()
((k-pt trap-val) ans)))))
(if pause
(begin (set! pause #!false)
new-engine)
(new-engine ticks-remaining success fail))))))
(lambda ()
(set! dispatch-count (+ 1 dispatch-count))
(set! running (running 'right))
(let ((set-engine! (running 'set-value!)))
(set-engine! ((running 'value) (time-slice) success fail))
(dispatch)))))
(define pause #!false)
(define time-slice
(lambda ()
(+ 5 (random 10))))
(define os-read
(lambda ()
(let loop ()
(let ((value (read)))
(if (eof-object? value)
(begin (trap 'pause) (loop))
value)))))
(define read-eval-print
(lambda (prompt)
(let loop ()
(display prompt)
(display " ")
(write (eval (read)))
(newline)
(loop))))
(define boot-thunk
(lambda ()
(read-eval-print "os>")))
(define boot
(lambda ()
(set! dispatch-count 0)
(set! running (make-ring (make-engine boot-thunk)))
(dispatch)))
(define spin
(lambda (n)
(when (not (zero? n))
(spin (- n 1)))))
(define trap
(lambda args
(call/cc
(lambda (k)
(engine-return (cons k args))))))
(define trap-handler
(rec trap
(lambda args
(let ((trap-type (car args))
(arg1 (when (not (null? (cdr args))) (cadr args))))
(case trap-type
(unblock ((running 'insert-left!) arg1) '*)
(block (when (eq? running arg1)
(if (running 'singleton?)
(begin (error 'trap-handler "DEADLOCK")
(boot))
(begin (set! running (running 'left))
(set! pause #!true))))
(arg1 'delete!)
'*)
(fork (let ((pcb (make-ring
(make-engine
(lambda ()
(arg1)
(error 'trap-handler
"process tried to return"))))))
((running 'insert-left!) pcb)
pcb))
(pause (set! pause #!true))
(self running)
(wait (let ((^value arg1) (queue (caddr args)))
(set-box! ^value (- (unbox ^value) 1))
(when (negative? (unbox ^value))
(let ((self (trap 'self)))
(trap 'block self)
((queue 'enq!) self)))
'*))
(signal (let ((^value arg1) (queue (caddr args)))
(set-box! ^value (+ 1 (unbox ^value)))
(when (not (positive? (unbox ^value)))
(trap 'unblock (queue 'deq!)))))
(else (ferror 'trap-handler "bad trap arguments: ~a" args)
(reset)))))))
(define make-semaphore
(lambda (count)
(let ((^value (box count))
(queue (make-queue)))
(lambda (msg)
(case msg
(wait (trap 'wait ^value queue))
(signal (trap 'signal ^value queue))
(empty? (queue 'empty?)))))))
(define parbegin-thunks
(lambda (thunks)
(let ((n (length thunks))
(mutex (make-semaphore 1))
(done (make-semaphore 0)))
(for-each (lambda (thunk)
(trap 'fork
(lambda ()
(thunk)
(mutex 'wait)
(set!! n (- n 1))
(when (zero? n) (done 'signal))
(mutex 'signal)
(trap 'block (trap 'self)))))
thunks)
(done 'wait))))