From 687ef8dee11a1c272f3eeee4211df0dd0cf85262 Mon Sep 17 00:00:00 2001 From: moore <moore> Date: Wed, 20 Feb 2002 06:40:01 +0000 Subject: [PATCH] Add features to multiprocessing that make it more compatible with ACL. These include process run reasons, arrest reasons, and property lists. --- code/exports.lisp | 10 ++- code/multi-proc.lisp | 198 ++++++++++++++++++++++++++++++++----------- 2 files changed, 157 insertions(+), 51 deletions(-) diff --git a/code/exports.lisp b/code/exports.lisp index ee799e5d4..52a4afcf0 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.189 2002/01/23 19:01:04 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.190 2002/02/20 06:40:01 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1731,9 +1731,13 @@ "ALL-PROCESSES" "ATOMIC-DECF" "ATOMIC-INCF" "ATOMIC-POP" "ATOMIC-PUSH" "CURRENT-PROCESS" "DESTROY-PROCESS" "DISABLE-PROCESS" "ENABLE-PROCESS" "INIT-STACK-GROUPS" "LOCK" "MAKE-STACK-GROUP" - "MAKE-LOCK" "MAKE-PROCESS" "PROCESS-ACTIVE-P" "PROCESS-ALIVE-P" + "MAKE-LOCK" "MAKE-PROCESS" "PROCESS-ACTIVE-P" + "PROCESS-ADD-ARREST-REASON" "PROCESS-ADD-RUN-REASON" + "PROCESS-ALIVE-P" "PROCESS-ARREST-REASONS" "PROCESS-IDLE-TIME" "PROCESS-INTERRUPT" "PROCESS-NAME" - "PROCESS-PRESET" "PROCESS-REAL-TIME" "PROCESS-RUN-TIME" + "PROCESS-PRESET" "PROCESS-PROPERTY-LIST" + "PROCESS-REAL-TIME" "PROCESS-REVOKE-ARREST-REASON" + "PROCESS-REVOKE-RUN-REASON" "PROCESS-RUN-REASONS" "PROCESS-RUN-TIME" "PROCESS-STATE" "PROCESS-WAIT-UNTIL-FD-USABLE" "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT" "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS" diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp index d7195974f..28912f555 100644 --- a/code/multi-proc.lisp +++ b/code/multi-proc.lisp @@ -5,7 +5,7 @@ ;;; the Public domain, and is provided 'as is'. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.39 2000/08/19 17:48:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.40 2002/02/20 06:40:01 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -258,6 +258,46 @@ (declaim (type (or stack-group null) *initial-stack-group*)) (defvar *initial-stack-group* nil) +;;; Process defstruct is up here because stack group functions refer +;;; to process slots in assertions, but are also compiled at high +;;; optimization... so if the process structure changes, all hell +;;; could break loose. + +(defstruct (process + (:constructor %make-process) + (:predicate processp) + (:print-function + (lambda (process stream depth) + (declare (type process process) (stream stream) (ignore depth)) + (print-unreadable-object (process stream :identity t) + (format stream "Process ~a" (process-name process)))))) + (name "Anonymous" :type simple-base-string) + (state :killed :type (member :killed :active :inactive)) + (%whostate nil :type (or null simple-base-string)) + (initial-function nil :type (or null function)) + (initial-args nil :type list) + (wait-function nil :type (or null function)) + (wait-function-args nil :type list) + (%run-reasons nil :type list) + (%arrest-reasons nil :type list) + ;; The real time after which the wait will timeout. + (wait-timeout nil :type (or null double-float)) + (wait-return-value nil :type t) + (interrupts '() :type list) + (stack-group nil :type (or null stack-group)) + ;; + ;; The real and run times when the current process was last + ;; scheduled or yielded. + (scheduled-real-time (get-real-time) :type double-float) + (scheduled-run-time (get-run-time) :type double-float) + ;; + ;; Accrued real and run times in seconds. + (%real-time 0d0 :type double-float) + (%run-time 0d0 :type double-float) + (property-list nil :type list) + (initial-bindings nil :type list)) + + ;;; Init-Stack-Groups -- Interface ;;; ;;; Setup the initial stack group. @@ -364,7 +404,7 @@ ;; Other bindings may be added here. nil 'unix::*interrupts-enabled* t 'lisp::*gc-inhibit*)) - + ;;; Make-Stack-Group -- Interface ;;; ;;; Fork a new stack-group from the *current-stack-group*. Execution @@ -716,35 +756,6 @@ (defvar *multi-processing* t) -(defstruct (process - (:constructor %make-process) - (:predicate processp) - (:print-function - (lambda (process stream depth) - (declare (type process process) (stream stream) (ignore depth)) - (print-unreadable-object (process stream :identity t) - (format stream "Process ~a" (process-name process)))))) - (name "Anonymous" :type simple-base-string) - (state :killed :type (member :killed :active :inactive)) - (%whostate nil :type (or null simple-base-string)) - (initial-function nil :type (or null function)) - (initial-args nil :type list) - (wait-function nil :type (or null function)) - ;; The real time after which the wait will timeout. - (wait-timeout nil :type (or null double-float)) - (wait-return-value nil :type t) - (interrupts '() :type list) - (stack-group nil :type (or null stack-group)) - ;; - ;; The real and run times when the current process was last - ;; scheduled or yielded. - (scheduled-real-time (get-real-time) :type double-float) - (scheduled-run-time (get-run-time) :type double-float) - ;; - ;; Accrued real and run times in seconds. - (%real-time 0d0 :type double-float) - (%run-time 0d0 :type double-float)) - ;;; Process-Whostate -- Public ;;; (defun process-whostate (process) @@ -760,7 +771,9 @@ ;;; (declaim (inline process-active-p)) (defun process-active-p (process) - (eq (process-state process) :active)) + (and (eq (process-state process) :active) + (process-%run-reasons process) + (not (process-%arrest-reasons process)))) ;;; Process-Alive-P -- Public ;;; @@ -860,14 +873,52 @@ (setf (process-scheduled-run-time new-process) run-time)) (values)) +(defun apply-with-bindings (function args bindings) + (if bindings + (progv + (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cdr binding)))) + (apply function args)) + (apply function args))) + ;;; Make-Process -- Public ;;; -(defun make-process (function &key (name "Anonymous")) - "Make a process which will run function when it starts up. The process - may be given an optional name which defaults to Anonymous. The new - process has a fresh set of special bindings with a default binding - of *package* setup to the CL-USER package." +(defun make-process (function &key + (name "Anonymous") + (run-reasons (list :enable)) + (arrest-reasons nil) + (initial-bindings nil)) + "Make a process which will run FUNCTION when it starts up. By + default the process is created in a runnable (active) state. + If FUNCTION is NIL, the process is started in a killed state; it may + be restarted later with process-preset. + + :NAME + A name for the process displayed in process listings. + + :RUN-REASONS + Initial value for process-run-reasons; defaults to (:ENABLE). A + process needs a at least one run reason to be runnable. Together with + arrest reasons, run reasons provide an alternative to process-wait for + controling whether or not a process is runnable. To get the default + behavior of MAKE-PROCESS in Allegro Common Lisp, which is to create a + process which is active but not runnable, initialize RUN-REASONS to + NIL. + + :ARREST-REASONS + Initial value for process-arrest-reasons; defaults to NIL. A + process must have no arrest reasons in order to be runnable. + + :INITIAL-BINDINGS + An alist of initial special bindings for the process. At + startup the new process has a fresh set of special bindings + with a default binding of *package* setup to the CL-USER + package. INITIAL-BINDINGS specifies additional bindings for + the process. The cdr of each alist element is evaluated in + the fresh dynamic environment and then bound to the car of the + element." (declare (type (or null function) function)) (cond (*quitting-lisp* ;; No more processes if about to quit lisp. @@ -875,14 +926,20 @@ ((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)) + (%make-process :initial-function nil :name name :state :killed + :%run-reasons run-reasons + :%arrest-reasons arrest-reasons + :initial-bindings initial-bindings)) (t ;; Create a stack-group. (let ((process (%make-process :name name - :state :active + :state :active :initial-function function + :%run-reasons run-reasons + :%arrest-reasons arrest-reasons + :initial-bindings initial-bindings :stack-group (make-stack-group name @@ -895,7 +952,9 @@ (with-simple-restart (destroy "Destroy the process") (setf *inhibit-scheduling* nil) - (funcall function)) + (apply-with-bindings function + nil + initial-bindings)) ;; Normal exit. (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) @@ -906,6 +965,10 @@ (setf *all-processes* (delete *current-process* *all-processes*)) (setf (process-%whostate *current-process*) nil) + (setf (process-%run-reasons *current-process*) nil) + (setf (process-%arrest-reasons *current-process*) nil) + (setf (process-wait-function-args *current-process*) + nil) (setf (process-wait-function *current-process*) nil) (setf (process-wait-timeout *current-process*) nil) (setf (process-wait-return-value *current-process*) @@ -918,6 +981,32 @@ (atomic-push process *all-processes*) process)))) +(defun process-run-reasons (process) + (process-%run-reasons process)) + +(defun process-add-run-reason (process object) + (atomic-push object (process-%run-reasons process))) + +(defun process-revoke-run-reason (process object) + (let ((run-reasons (without-scheduling + (setf (process-%run-reasons process) + (delete object (process-%run-reasons process)))))) + (when (and (null run-reasons) (eq process mp::*current-process*)) + (process-yield)))) + + +(defun process-arrest-reasons (process) + (process-%arrest-reasons process)) + +(defun process-add-arrest-reason (process object) + (atomic-push object (process-%arrest-reasons process)) + (when (eq process mp::*current-process*) + (process-yield))) + +(defun process-revoke-arrest-reason (process object) + (without-scheduling + (setf (process-%arrest-reasons process) + (delete object (process-%arrest-reasons process))))) ;;; Process-Interrupt -- Public ;;; @@ -956,9 +1045,11 @@ "Restart process by unwinding it to its initial state and calling its initial function." (destroy-process process) - (process-wait "Waiting for process to die" + (if *inhibit-scheduling* ;Called inside without-scheduling? + (assert (eq (process-state process) :killed)) + (process-wait "Waiting for process to die" #'(lambda () - (eq (process-state process) :killed))) + (eq (process-state process) :killed)))) ;; No more processes if about to quit lisp. (when *quitting-lisp* (process-wait "Quitting Lisp" #'(lambda () nil))) @@ -976,8 +1067,10 @@ (with-simple-restart (destroy "Destroy the process") (setf *inhibit-scheduling* nil) - (apply (process-initial-function process) - (process-initial-args process))) + (apply-with-bindings + (process-initial-function process) + (process-initial-args process) + (process-initial-bindings process))) ;; Normal exit. (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) @@ -987,6 +1080,10 @@ (setf *all-processes* (delete *current-process* *all-processes*)) (setf (process-%whostate *current-process*) nil) + (setf (process-%run-reasons *current-process*) nil) + (setf (process-%arrest-reasons *current-process*) nil) + (setf (process-wait-function-args *current-process*) + nil) (setf (process-wait-function *current-process*) nil) (setf (process-wait-timeout *current-process*) nil) (setf (process-wait-return-value *current-process*) nil) @@ -995,6 +1092,7 @@ (setf *current-process* *initial-process*))) *initial-stack-group* nil)) (setf (process-%whostate process) nil) + (setf (process-wait-function-args process) nil) (setf (process-wait-function process) nil) (setf (process-wait-timeout process) nil) (setf (process-wait-return-value process) nil) @@ -1035,7 +1133,7 @@ ;;; Process-Wait -- Public. ;;; -(defun process-wait (whostate predicate) +(defun process-wait (whostate predicate &rest args) "Causes the process to wait until predicate returns True. Processes can only call process-wait when scheduling is enabled, and the predicate can not call process-wait. Since the predicate may be evaluated may @@ -1049,13 +1147,14 @@ ;; scheduler restores the state when execution resumers here. (setf (process-%whostate *current-process*) whostate) (setf (process-wait-timeout *current-process*) nil) + (setf (process-wait-function-args *current-process*) args) (setf (process-wait-function *current-process*) predicate) (process-yield) (process-wait-return-value *current-process*)) ;;; Process-Wait-With-Timeout -- Public ;;; -(defun process-wait-with-timeout (whostate timeout predicate) +(defun process-wait-with-timeout (whostate timeout predicate &rest args) (declare (type (or fixnum float) timeout)) "Causes the process to wait until predicate returns True, or the number of seconds specified by timeout has elapsed. The timeout may @@ -1078,6 +1177,7 @@ (declare (double-float timeout)) (setf (process-wait-timeout *current-process*) (+ timeout (get-real-time))) + (setf (process-wait-function-args *current-process*) args) (setf (process-wait-function *current-process*) predicate)) (process-yield) (process-wait-return-value *current-process*)) @@ -1229,7 +1329,8 @@ (stack-group-resume (process-stack-group next))) (t ;; If not waiting then return. - (let ((wait-fn (process-wait-function next))) + (let ((wait-fn (process-wait-function next)) + (wait-fn-args (process-wait-function-args next))) (cond ((null wait-fn) ;; Skip the idle process if there are other runnable @@ -1246,7 +1347,7 @@ (let ((current-process *current-process*)) (setf *current-process* next) ;; Predicate true? - (let ((wait-return-value (funcall wait-fn))) + (let ((wait-return-value (apply wait-fn wait-fn-args))) (cond (wait-return-value ;; Flush the wait. (setf (process-wait-return-value next) @@ -1417,6 +1518,7 @@ (%make-process :name "Initial" :state :active + :%run-reasons (list :enable) :stack-group *initial-stack-group*)) (setf *current-process* *initial-process*) (setf *all-processes* (list *initial-process*)) -- GitLab