From 3258c6c6f3bee3611facdef66a97ce5cdad68ed5 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Tue, 30 Dec 1997 06:03:17 +0000 Subject: [PATCH] Allow the quitting of lisp from any process (this had only been possible from the initial process). When a process throws to %end-of-the-world the exit value is noted in the *quitting-lisp* variable and further process creation is blocked. Have the idle loop try to gracefully destroy all the processes when *quitting-lisp* before exiting. --- code/multi-proc.lisp | 76 +++++++++++++++++++++++++++++--------------- 1 file changed, 51 insertions(+), 25 deletions(-) diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp index 16956c57e..2651920aa 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.10 1997/12/29 19:02:54 dtc Exp $ +;;; $Id: multi-proc.lisp,v 1.11 1997/12/30 06:03:17 dtc Exp $ ;;; ;;; ********************************************************************** ;;; @@ -163,15 +163,6 @@ (aref save-stack index))) (values)) -#+nil -(defun tst-alien () - (alien:with-alien ((buf (array char 256))) - (format t "~s~%" buf) - (multiple-value-bind (save-stack size alien-stack) - (save-alien-stack (make-array 0 :element-type '(unsigned-byte 32))) - (restore-alien-stack save-stack size alien-stack)) - (format t "~s~%" buf))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Interrupt contexts. @@ -209,7 +200,7 @@ ;;;; ;;; The control stacks need special handling on the x86 as they -;;; contain conservative root. When placed in the *control-stacks* +;;; contain conservative roots. When placed in the *control-stacks* ;;; vector they will be scavenged for conservative roots by the ;;; garbage collector. (declaim (type (simple-array (or null (simple-array (unsigned-byte 32) (*))) @@ -218,7 +209,7 @@ (make-array 0 :element-type '(or null (unsigned-byte 32)) :initial-element nil)) -;;; Stack-group stucture. +;;; Stack-group structure. (defstruct (stack-group (:constructor %make-stack-group) (:print-function @@ -574,7 +565,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Double-float timing functions for use by the scheduler. -;;; The timing functions use double-floats here for accuracy. In most +;;; These timer functions use double-floats for accuracy. In most ;;; cases consing is avoided. ;;; Get-Real-Time @@ -596,7 +587,7 @@ (declaim (inline get-run-time)) ;;; (defun get-run-time () - "Return the run time in secondes" + "Return the run time in seconds" (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) (unix:unix-fast-getrusage unix:rusage_self) @@ -708,6 +699,13 @@ `(without-scheduling (pop ,place))) +;;; If a process other than the initial process throws to the +;;; %end-of-the-world then *quitting-lisp* is set to the exit value, +;;; after which further process creation blocks. If the initial +;;; process is running the idle loop then it will perform the exit +;;; when it runs. +;;; +(defvar *quitting-lisp* nil) ;;; Update-Process-Timers -- Internal ;;; @@ -734,7 +732,10 @@ ;;; (defun make-process (function &key (name "Anonymous")) (declare (type (or null function) function)) - (cond ((null function) + (cond (*quitting-lisp* + ;; No more processes if about to quit lisp. + (process-wait "Quitting Lisp" #'(lambda () nil))) + ((null function) ;; If function is nil then create a dead process; can be ;; restarted with process-preset. (%make-process :initial-function nil :name name :state :killed)) @@ -750,9 +751,14 @@ name #'(lambda () (unwind-protect - (progn - (setf *inhibit-scheduling* nil) - (funcall function)) + (catch '%end-of-the-process + ;; Catch throws to the %end-of-the-world. + (setf *quitting-lisp* + (catch 'lisp::%end-of-the-world + (setf *inhibit-scheduling* nil) + (funcall function) + ;; Normal exit. + (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) ;; About to return to the resumer's ;; stack-group, which in this case is the @@ -791,7 +797,7 @@ ;; scheduled. (without-scheduling (push #'(lambda () - (throw 'lisp::%end-of-the-world 0)) + (throw '%end-of-the-process nil)) (process-interrupts process))) ;; Should we wait until it's dead? (process-yield))) @@ -803,16 +809,24 @@ (process-wait "Waiting for process to die" #'(lambda () (eq (process-state process) :killed))) + ;; No more processes if about to quit lisp. + (when *quitting-lisp* + (process-wait "Quitting Lisp" #'(lambda () nil))) ;; Create a new stack-group. (setf (process-stack-group process) (make-stack-group (process-name process) #'(lambda () (unwind-protect - (progn - (setf *inhibit-scheduling* nil) - (apply (process-initial-function process) - (process-initial-args process))) + (catch '%end-of-the-process + ;; Catch throws to the %end-of-the-world. + (setf *quitting-lisp* + (catch 'lisp::%end-of-the-world + (setf *inhibit-scheduling* nil) + (apply (process-initial-function process) + (process-initial-args process)) + ;; Normal exit. + (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) ;; About to return to the resumer's stack-group, which ;; in this case is the initial process's stack-group. @@ -901,8 +915,20 @@ ;;; process-yielding periodically. ;;; (defun idle-process-loop () - (loop - (sys:serve-all-events))) + (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)) + (throw 'lisp::%end-of-the-world *quitting-lisp*)) ;;; Process-Yield ;;; -- GitLab