ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/AIFIRST.ZIP/CLI.LSP

Lisp/Scheme | 1986-10-30 | 10.3 KB | 324 lines

Multitasking Golden Common LISP program


;; 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))
         ; 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
       (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))
)
;; 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
(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
    )
)
;; 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). When an error occurs within a concurrent
; task, two problems 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.