Skip to content
Snippets Groups Projects
Commit 687ef8de authored by moore's avatar moore
Browse files

Add features to multiprocessing that make it more compatible with ACL.  These
include process run reasons, arrest reasons, and property lists.
parent 1971fde9
Branches
Tags
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -1731,9 +1731,13 @@
"ALL-PROCESSES" "ATOMIC-DECF" "ATOMIC-INCF" "ATOMIC-POP" "ALL-PROCESSES" "ATOMIC-DECF" "ATOMIC-INCF" "ATOMIC-POP"
"ATOMIC-PUSH" "CURRENT-PROCESS" "DESTROY-PROCESS" "DISABLE-PROCESS" "ATOMIC-PUSH" "CURRENT-PROCESS" "DESTROY-PROCESS" "DISABLE-PROCESS"
"ENABLE-PROCESS" "INIT-STACK-GROUPS" "LOCK" "MAKE-STACK-GROUP" "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-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-STATE" "PROCESS-WAIT-UNTIL-FD-USABLE"
"PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT" "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT"
"PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS" "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS"
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; the Public domain, and is provided 'as is'. ;;; the Public domain, and is provided 'as is'.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -258,6 +258,46 @@
(declaim (type (or stack-group null) *initial-stack-group*)) (declaim (type (or stack-group null) *initial-stack-group*))
(defvar *initial-stack-group* nil) (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 ;;; Init-Stack-Groups -- Interface
;;; ;;;
;;; Setup the initial stack group. ;;; Setup the initial stack group.
...@@ -364,7 +404,7 @@ ...@@ -364,7 +404,7 @@
;; Other bindings may be added here. ;; Other bindings may be added here.
nil 'unix::*interrupts-enabled* nil 'unix::*interrupts-enabled*
t 'lisp::*gc-inhibit*)) t 'lisp::*gc-inhibit*))
;;; Make-Stack-Group -- Interface ;;; Make-Stack-Group -- Interface
;;; ;;;
;;; Fork a new stack-group from the *current-stack-group*. Execution ;;; Fork a new stack-group from the *current-stack-group*. Execution
...@@ -716,35 +756,6 @@ ...@@ -716,35 +756,6 @@
(defvar *multi-processing* t) (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 ;;; Process-Whostate -- Public
;;; ;;;
(defun process-whostate (process) (defun process-whostate (process)
...@@ -760,7 +771,9 @@ ...@@ -760,7 +771,9 @@
;;; ;;;
(declaim (inline process-active-p)) (declaim (inline process-active-p))
(defun process-active-p (process) (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 ;;; Process-Alive-P -- Public
;;; ;;;
...@@ -860,14 +873,52 @@ ...@@ -860,14 +873,52 @@
(setf (process-scheduled-run-time new-process) run-time)) (setf (process-scheduled-run-time new-process) run-time))
(values)) (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 ;;; Make-Process -- Public
;;; ;;;
(defun make-process (function &key (name "Anonymous")) (defun make-process (function &key
"Make a process which will run function when it starts up. The process (name "Anonymous")
may be given an optional name which defaults to Anonymous. The new (run-reasons (list :enable))
process has a fresh set of special bindings with a default binding (arrest-reasons nil)
of *package* setup to the CL-USER package." (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)) (declare (type (or null function) function))
(cond (*quitting-lisp* (cond (*quitting-lisp*
;; No more processes if about to quit lisp. ;; No more processes if about to quit lisp.
...@@ -875,14 +926,20 @@ ...@@ -875,14 +926,20 @@
((null function) ((null function)
;; If function is nil then create a dead process; can be ;; If function is nil then create a dead process; can be
;; restarted with process-preset. ;; 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 (t
;; Create a stack-group. ;; Create a stack-group.
(let ((process (let ((process
(%make-process (%make-process
:name name :name name
:state :active :state :active
:initial-function function :initial-function function
:%run-reasons run-reasons
:%arrest-reasons arrest-reasons
:initial-bindings initial-bindings
:stack-group :stack-group
(make-stack-group (make-stack-group
name name
...@@ -895,7 +952,9 @@ ...@@ -895,7 +952,9 @@
(with-simple-restart (with-simple-restart
(destroy "Destroy the process") (destroy "Destroy the process")
(setf *inhibit-scheduling* nil) (setf *inhibit-scheduling* nil)
(funcall function)) (apply-with-bindings function
nil
initial-bindings))
;; Normal exit. ;; Normal exit.
(throw '%end-of-the-process nil)))) (throw '%end-of-the-process nil))))
(setf *inhibit-scheduling* t) (setf *inhibit-scheduling* t)
...@@ -906,6 +965,10 @@ ...@@ -906,6 +965,10 @@
(setf *all-processes* (setf *all-processes*
(delete *current-process* *all-processes*)) (delete *current-process* *all-processes*))
(setf (process-%whostate *current-process*) nil) (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-function *current-process*) nil)
(setf (process-wait-timeout *current-process*) nil) (setf (process-wait-timeout *current-process*) nil)
(setf (process-wait-return-value *current-process*) (setf (process-wait-return-value *current-process*)
...@@ -918,6 +981,32 @@ ...@@ -918,6 +981,32 @@
(atomic-push process *all-processes*) (atomic-push process *all-processes*)
process)))) 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 ;;; Process-Interrupt -- Public
;;; ;;;
...@@ -956,9 +1045,11 @@ ...@@ -956,9 +1045,11 @@
"Restart process by unwinding it to its initial state and calling its "Restart process by unwinding it to its initial state and calling its
initial function." initial function."
(destroy-process process) (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 () #'(lambda ()
(eq (process-state process) :killed))) (eq (process-state process) :killed))))
;; No more processes if about to quit lisp. ;; No more processes if about to quit lisp.
(when *quitting-lisp* (when *quitting-lisp*
(process-wait "Quitting Lisp" #'(lambda () nil))) (process-wait "Quitting Lisp" #'(lambda () nil)))
...@@ -976,8 +1067,10 @@ ...@@ -976,8 +1067,10 @@
(with-simple-restart (with-simple-restart
(destroy "Destroy the process") (destroy "Destroy the process")
(setf *inhibit-scheduling* nil) (setf *inhibit-scheduling* nil)
(apply (process-initial-function process) (apply-with-bindings
(process-initial-args process))) (process-initial-function process)
(process-initial-args process)
(process-initial-bindings process)))
;; Normal exit. ;; Normal exit.
(throw '%end-of-the-process nil)))) (throw '%end-of-the-process nil))))
(setf *inhibit-scheduling* t) (setf *inhibit-scheduling* t)
...@@ -987,6 +1080,10 @@ ...@@ -987,6 +1080,10 @@
(setf *all-processes* (setf *all-processes*
(delete *current-process* *all-processes*)) (delete *current-process* *all-processes*))
(setf (process-%whostate *current-process*) nil) (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-function *current-process*) nil)
(setf (process-wait-timeout *current-process*) nil) (setf (process-wait-timeout *current-process*) nil)
(setf (process-wait-return-value *current-process*) nil) (setf (process-wait-return-value *current-process*) nil)
...@@ -995,6 +1092,7 @@ ...@@ -995,6 +1092,7 @@
(setf *current-process* *initial-process*))) (setf *current-process* *initial-process*)))
*initial-stack-group* nil)) *initial-stack-group* nil))
(setf (process-%whostate process) nil) (setf (process-%whostate process) nil)
(setf (process-wait-function-args process) nil)
(setf (process-wait-function process) nil) (setf (process-wait-function process) nil)
(setf (process-wait-timeout process) nil) (setf (process-wait-timeout process) nil)
(setf (process-wait-return-value process) nil) (setf (process-wait-return-value process) nil)
...@@ -1035,7 +1133,7 @@ ...@@ -1035,7 +1133,7 @@
;;; Process-Wait -- Public. ;;; 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 "Causes the process to wait until predicate returns True. Processes
can only call process-wait when scheduling is enabled, and the predicate can only call process-wait when scheduling is enabled, and the predicate
can not call process-wait. Since the predicate may be evaluated may can not call process-wait. Since the predicate may be evaluated may
...@@ -1049,13 +1147,14 @@ ...@@ -1049,13 +1147,14 @@
;; scheduler restores the state when execution resumers here. ;; scheduler restores the state when execution resumers here.
(setf (process-%whostate *current-process*) whostate) (setf (process-%whostate *current-process*) whostate)
(setf (process-wait-timeout *current-process*) nil) (setf (process-wait-timeout *current-process*) nil)
(setf (process-wait-function-args *current-process*) args)
(setf (process-wait-function *current-process*) predicate) (setf (process-wait-function *current-process*) predicate)
(process-yield) (process-yield)
(process-wait-return-value *current-process*)) (process-wait-return-value *current-process*))
;;; Process-Wait-With-Timeout -- Public ;;; 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)) (declare (type (or fixnum float) timeout))
"Causes the process to wait until predicate returns True, or the "Causes the process to wait until predicate returns True, or the
number of seconds specified by timeout has elapsed. The timeout may number of seconds specified by timeout has elapsed. The timeout may
...@@ -1078,6 +1177,7 @@ ...@@ -1078,6 +1177,7 @@
(declare (double-float timeout)) (declare (double-float timeout))
(setf (process-wait-timeout *current-process*) (setf (process-wait-timeout *current-process*)
(+ timeout (get-real-time))) (+ timeout (get-real-time)))
(setf (process-wait-function-args *current-process*) args)
(setf (process-wait-function *current-process*) predicate)) (setf (process-wait-function *current-process*) predicate))
(process-yield) (process-yield)
(process-wait-return-value *current-process*)) (process-wait-return-value *current-process*))
...@@ -1229,7 +1329,8 @@ ...@@ -1229,7 +1329,8 @@
(stack-group-resume (process-stack-group next))) (stack-group-resume (process-stack-group next)))
(t (t
;; If not waiting then return. ;; 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 (cond
((null wait-fn) ((null wait-fn)
;; Skip the idle process if there are other runnable ;; Skip the idle process if there are other runnable
...@@ -1246,7 +1347,7 @@ ...@@ -1246,7 +1347,7 @@
(let ((current-process *current-process*)) (let ((current-process *current-process*))
(setf *current-process* next) (setf *current-process* next)
;; Predicate true? ;; Predicate true?
(let ((wait-return-value (funcall wait-fn))) (let ((wait-return-value (apply wait-fn wait-fn-args)))
(cond (wait-return-value (cond (wait-return-value
;; Flush the wait. ;; Flush the wait.
(setf (process-wait-return-value next) (setf (process-wait-return-value next)
...@@ -1417,6 +1518,7 @@ ...@@ -1417,6 +1518,7 @@
(%make-process (%make-process
:name "Initial" :name "Initial"
:state :active :state :active
:%run-reasons (list :enable)
:stack-group *initial-stack-group*)) :stack-group *initial-stack-group*))
(setf *current-process* *initial-process*) (setf *current-process* *initial-process*)
(setf *all-processes* (list *initial-process*)) (setf *all-processes* (list *initial-process*))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment