Multiprocessor computers are readily available. Most personal computers already have specialized multiprocessor systems with additional processors handling features such a as graphics or sound. To better use the power inherent in multiprocessor systems, languages with concurrent tasking must be developed.
The concept of concurrent programming also serves us well on single processor systems. Many programming projects are best thought of as multitasking jobs, perhaps with intertask communication. A familiar example of multitasking is the MS-DOS print facility, which copies a file to the line printer while the computer is being used for other tasks. In a single processor environment, the concurrent tasks are interleaved (time shared).
This article discusses the design and implementation of a concurrent LISP interpreter (CLI) based on a construct that allows simultaneous evaluation of a list of LISP forms; see Listing One. CLI also allows for intertask communication. The native language for CLI is Gold Hill Computers' Golden Common LISP; other full-featured LISPs should allow a parallel implementation.
;; initialization of parameters
(setf *time-slice* 10) ; quantum for switching
(setf *beep-switch* t) ; beep when switching
(setf *random-seed* 10013)
(setf *semaphore-list* nil)
;; The function which sets up the concurrent processes
(defun cobegin (&rest forms)
; initialize
(setf *pseudo-time* 0 ; used to count pseudo-time
*switching?* t ; inhibit switching if nil
*concur-length* (list-length forms))
; create a list of the correct length for storing results
(setf stack-results-list (make-list *concur-length*))
; create the stack groups
(make-stack-groups *concur-length*
(setf *stack-group-names*
(make-sym-list *concur-length*))
forms)
; initiate task execution
(switch-around)
; return the list of results
(mapcar 'eval stack-results-list)
)
;;; The evaluator which handles concurrency
(defun cli_eval (form)
; increment the pseudo-time
(setf *pseudo-time* (1+ *pseudo-time*))
(cond
; is it time to switch?
((and
; is switching enabled?
*switching?*
; don't switch if there's only 1 task
(> *concur-length* 1)
; is it the end of a time quantum?
(>= *pseudo-time* *time-slice*)
; don't want to leave the initial (gclisp) stack-group
(not (equal *current-stack-group*
*initial-stack-group*)))
; if so,
; beep if desired
(if *beep-switch* (beep))
; reset pseudo-time
(setf *pseudo-time* 0)
; suspend this task (and return to switch-around)
(stack-group-return nil)))
(let*
; evaluate this form
((value (evalhook form #'cli_eval nil))
S ; find the name of this stack-group
(name (assoc1 '*current-stack-group* *stack-group-names*)))
; save the value if appropriate
(cond (name
(set (nth (get name 'process-num) stack-results-list) value)))
; return the value of form
value)
)
;; The scheduler for concurrent execution
(defun switch-around ()
; disable switching during the switching
(setf *switching?* nil)
(let
; choose the next task
((next (next-stack *concur-length* *stack-group-names*)))
(cond
; if there are no more tasks, then we're done
((null next)
(setf *switching?* t))
; is the task finished?
((< 1 (stack-group-status (eval next)))
; if so,
; eliminate this task
(setf *stack-group-names*
(remove next *stack-group-names* ))
(setf *concur-length* (1- *concur-length*))
; make the memory reusable
(makunbound next)
; try another task
(switch-around))
; the task is ready to go
(t
(setf *switching?* t)
; initiate it
(funcall (eval next) nil)
; when its time-slice is done, we will return to here
; and switch again
(switch-around))))
)
;; HELP FUNCTIONS
;; this function returns the status of a stack group
;; (0: active, 1:resumable, 2:broken, 3:exhausted)
(defun stack-group-status (stack-group)
(multiple-value-setq
(offset segment) (%pointer stack-group))
(lsh (%contents segment (+ offset 41)) -1)
)
;; set up the stack-groups
(defun make-stack-groups (length name-list1 func-list)
(cond
; done
((null name-list1))
; otherwise
(t
; create a stack group of the desired name
S (set (car name-list1)
(stack-group-preset
; make the stack-group
(make-stack-group (car name-list1)
; change as appropriate
:regular-pdl-size 6000
:special-pdl-size 2000)
; initialize to evaluate the form
#'cli_eval (car func-list)))
; recursive call to handle the next form
(make-stack-groups (1- length) (cdr name-list1) (cdr func-list))))
)
;; create a list of names for stack-groups
(defun make-sym-list (length &optional l)
(cond
; are we done?
((= 0 length) l)
; nope
(t
(let
; create a name
((name (gensym)))
; give it a process identification number
(setf (get name 'process-num) (1- length))
; recursive call to finish the rest
(make-sym-list (1- length) (cons name l)))))
)
;; create a list of unique names with length n
(defun make-list (n &optional l)
(cond
((= 0 n) l)
(t
(make-list (1- n) (cons (gensym) l))))
)
;; selects next process to be executed
(defun next-stack (length name-list)
; choose the next process randomly
(nth
(rand 0 (1- length)) name-list)
)
;; a random number generator (since Golden doesn't have one built-in)
(defun rand (low-rand high-rand)
(setf
*random-seed*
(truncate (amod (* 25211.0 *random-seed*) 32768.0)))
(truncate
(+ low-rand (* (/ (float *random-seed*) 32768.0)
(1+ (- high-rand low-rand)))))
)
;; define the mod function (since Golden's is in the editor!)
(defun amod (real-num divisor)
(- real-num
(* (truncate (/ real-num divisor))
divisor))
)
S;; SEMAPHORE FUNCTIONS
;; handle the wait function
(defun wait (which)
; inhibit task switching
(setf *switching?* nil)
(cond
; if the semaphore is set at 1
((eq (eval which) 1)
; set it to 0 and retun
(set which 0)
(setf *switching?* t))
(t
; else put this process on hold
(let
; find its name
((process (assoc1 '*current-stack-group*
*stack-group-names*)))
; remove it from the ready processes
(setf *stack-group-names*
(remove process *stack-group-names*))
(setf *concur-length*
(1- *concur-length*))
; add it to the queue waiting upon this semaphore
(setf (get which 'queue)
(cons process (get which 'queue)))
; allow task switching
(setf *switching?* t)
; leave this process (and switch to another)
(stack-group-return nil))))
)
;; this function handles the SIGNAL operation.
(defun signal (which)
; inhibit task switching
(setf *switching?* nil)
(let
; get semaphore's queue
((process (get which 'queue)))
(cond
; are there are tasks waiting upon this semaphore?
((not (null process))
; if so,
; de-queue a task and add it to the ready tasks
(setf *stack-group-names*
(cons (car (last process)) *stack-group-names*))
(setf *concur-length*
(length *stack-group-names*))
; remove the task from this semaphore's queue
(setf (get which 'queue) (butlast process)))
; else set the semaphore to 1
(t (set which 1))))
; enable task switching
(setf *switching?* t)
)
;; initializes the semaphores
;; must be called before initiating concurrent tasking
S(defun initialize-semaphores (sl)
(setf *semaphore-list* (i-s-help sl nil))
)
(defun i-s-help (sl l)
(cond ((null sl) l)
(t
(let ((which (caar sl))
(value (cadar sl)))
(set which value)
(setf (get which 'queue) nil)
(i-s-help (cdr sl) (cons which l)))))
)
;; Find the name of a variable in the list given its unique value.
(defun assoc1 (name list)
(cond ((null list) nil)
(t (cond ((equal (eval (car list)) (eval name))
(car list))
(t (assoc1 name (cdr list))))))
)
;; EXAMPLES
; producer-consumer (pc)
;; The Producer-Consumer Problem (synchronized)
(defun pc ()
(setf buffer nil)
(setf information '(this is a test of semaphores))
; initializes the semaphores
(initialize-semaphores '(($ok-to-consume 0) ($ok-to-produce 1)))
; starts concurrent reading and writing.
(cobegin (list 'producer (length information))
(list 'consumer (length information)))
)
(defun producer (r)
(do ((i 0 (1+ i)))
((= i r) (print 'end-producer))
; start of critical region
(wait '$ok-to-produce)
(print 'read-by-producer<---)
(setf buffer (nth i information))
(princ buffer)
(signal '$ok-to-consume)
; end of critical region
)
)
(defun consumer (r)
(do ((i 0 (1+ i)))
((= i r) (print 'end-consumer))
; start of critical region
(wait '$ok-to-consume)
(print '----print-by-consumer--->)
(princ buffer)
(setf buffer nil)
(signal '$ok-to-produce)
; end of critical region
)
)
S;; The Producer-Consumer Problem (unsynchronized)
(defun un-pc ()
(setf buffer nil)
(setf information '(this is a test of semaphores))
;; starts concurrent reading and writing.
(cobegin (list 'un-producer (length information))
(list 'un-consumer (length information)))
)
(defun un-producer (r)
(do ((i 0 (1+ i)))
((= i r) (print 'end-producer))
(print 'read-by-producer<---)
(setf buffer (nth i information))
(princ buffer)
(terpri)
)
)
(defun un-consumer (r)
(do ((i 0 (1+ i)))
((= i r) (print 'end-consumer))
(print '----print-by-consumer--->)
(princ buffer)
(terpri)
(setf buffer nil)
)
)
;; A Note on Error Handling in CLI
; The most common error is stack-group-overflow, i.e., running out of
; memory space. Try reducing the size of each stack group (see function
make-stack-groups)r Whe' a' erro occur withi' concurren ?
; task tw problem result.
; First, the GCLisp error handling routines were not designed to work
; with stack groups. In particular, you cannot use Control-G to move up
; one listener level. This is because the listeners use the catch-throw
; construct, and the catch is in the original stack group (the one which
; initiated concurrent execution) not the one which contains the error.
; You can use cntrl-C to return to the top-level of the original stack
; group, but then you are confronted with problem two.
; When a stack group is exhausted, its name is unbound (in function
; switch-around) in order to reclaim the memory used. However, if there
; is an error, this unbinding will be skipped. Worse, GCLisp contains
; an apparent bug which does not allow reclamation of memory used by a
; stack group which terminates by being broken (i.e., with an error)
; instead of by exhaustion. Thus, any stack group which terminates in an
; error will continue to occupy (waste) memory. The only solution to this
; problem is to exit GCLisp and restart.
;; C. 1986 by Andrew P. Bernat.
;; Permission is granted for any noncommercial use with appropriate
;; credit to the author.
Listing One: Multitasking Golden Common LISP program.
I assume the reader has a background in LISP, including an understanding of the importance of eval and environments. A good introduction to LISP may be found in R.A. Brooks' Programming In Common LISP. The classic advanced source is Allen's Anatomy of LISP. Discussions of concurrent programming may be found in most survey of programming language texts (for example, E. Horowitz's Fundamentals of Programming Languages. A more complete discussion (including a concurrent Pascal interpreter written in Pascal) is given in M. Ben-Ari's Principles of Concurrent Programming. Several implementations of concurrent LISP have been presented at the biennial LISP conferences (1980, 1982, 1984), and the proceedings are available from the Association for Computing Machinery.
