diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp index 2651920aac15d5beada155e89441cdff42edc3c2..a68cae66ee2eb5d9185038cb0dd4c7dd33aedbc2 100644 --- a/code/multi-proc.lisp +++ b/code/multi-proc.lisp @@ -3,7 +3,7 @@ ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the Public domain, and is provided 'as is'. ;;; -;;; $Id: multi-proc.lisp,v 1.11 1997/12/30 06:03:17 dtc Exp $ +;;; $Id: multi-proc.lisp,v 1.12 1997/12/30 16:36:27 dtc Exp $ ;;; ;;; ********************************************************************** ;;; @@ -792,13 +792,16 @@ (declare (type process process)) (assert (not (eq process *current-process*))) (unless (eq (process-state process) :killed) - ;; Place the a throw to end-of-the-world at the start of process's - ;; interrupts queue, to be called the next time the process is - ;; scheduled. (without-scheduling + ;; Place a throw to end-of-the-world at the start of process's + ;; interrupts queue, to be called the next time the process is + ;; scheduled. (push #'(lambda () (throw '%end-of-the-process nil)) - (process-interrupts process))) + (process-interrupts process)) + ;; Ensure that the process is active so that it can accept this + ;; interrupt. + (setf (process-state process) :active)) ;; Should we wait until it's dead? (process-yield))) @@ -910,24 +913,58 @@ (not (process-wait-function process))) (return nil)))) +;;; Shutdown-multi-processing. +;;; +;;; Try to gracefully destroy all the processes giving them some +;;; chance to unwinding, before shutting down multi-processing. Can be +;;; restarted by init-multi-processing. +;;; +(defun shutdown-multi-processing () + (assert (eq *current-process* *initial-process*) () + "Only the *initial-process* can shutdown multi-processing") + + (let ((destroyed-processes nil)) + (do ((cnt 0 (1+ cnt))) + ((> cnt 10)) + (declare (type lisp::index cnt)) + (dolist (process *all-processes*) + (when (and (not (eq process *current-process*)) + (process-active-p process) + (not (member process destroyed-processes))) + (destroy-process process) + (push process destroyed-processes))) + (unless (rest *all-processes*) + (return)) + (format t "Destroyed ~d process~:P; remaining ~d~%" + (length destroyed-processes) (length *all-processes*)) + (process-yield))) + + (start-sigalrm-yield 0 0) ; Off with the interrupts. + ;; Reset the multi-processing state. + (setf *inhibit-scheduling* t) + (setf *initial-process* nil) + (setf *idle-process* nil) + (setf *current-process* nil) + (setf *all-processes* nil) + (setf *remaining-processes* nil) + ;; Cleanup the stack groups. + (setf x86::*control-stacks* + (make-array 0 :element-type '(or null (unsigned-byte 32)) + :initial-element nil)) + (setf *current-stack-group* nil) + (setf *initial-stack-group* nil)) + ;;; A useful idle process loop, waiting on events using the select ;;; based event server, which is assumed to be setup to call ;;; process-yielding periodically. ;;; (defun idle-process-loop () + (assert (eq *current-process* *initial-process*) () + "Only the *initial-process* is intended to run this idle loop") (do () (*quitting-lisp*) (sys:serve-all-events)) - ;; Try to gracefully destroy all the processes. - (dolist (process *all-processes*) - (unless (eq process *current-process*) - (destroy-process process))) - (do ((cnt 0 (1+ cnt))) - ((or (null (rest *all-processes*)) - (> cnt 10))) - (declare (type lisp::index cnt)) - (format t " ~d" (length *all-processes*)) - (process-yield)) + (shutdown-multi-processing) (throw 'lisp::%end-of-the-world *quitting-lisp*)) ;;; Process-Yield @@ -1132,10 +1169,12 @@ (unix:unix-setitimer :real sec usec 0 1) (values)) -;;; Initialise the initial process, must be called before use of the -;;; other multi-process function. +;;; Init-Multi-Processing. ;;; -(defun init-processes () +;;; Startup multi-processing, initialising the initial process. This +;;; must be called before use of the other multi-process functions. +;;; +(defun init-multi-processing () (unless *initial-process* (init-stack-groups) (setf *initial-process* @@ -1148,11 +1187,9 @@ (setf *remaining-processes* *all-processes*) ;; #+nil (start-sigalrm-yield) - (setf *inhibit-scheduling* nil)) - ;; - (values)) + (setf *inhibit-scheduling* nil))) -(pushnew 'init-processes ext:*after-save-initializations*) +(pushnew 'init-multi-processing ext:*after-save-initializations*) ;;; Show-Processes ;;;