1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.

;;; Process system and scheduler*

;;; Edit History
;;;
;;;                   Patch
;;;   Date    Author  Number   Description
;;;------------------------------------------------------------------------------
;;;  10-19-88  RJF/BC          Changes to Time-stats
;;;  02-27-89  JLM             Added support for process-ids
;;;  3/14/89   jlm             Added PROCESS-ID-INITIALIZE to SYSTEM-INITIALIZATION-LIST (:now) 
;;;                            to initialize process-ids during INITIALIZE-COLD-LOAD and changed 
;;;                            PROCESS-INTIALIZE to no longer do it
;;;  04/25/89  RJF/HRC         Changed the scheduler to select scavenging over process execution
;;;                            if cons driven scavenging is near and the selected process is a
;;;                            low priority hog. Also corrected the percent-utilization-discount
;;;                            -factor         

1; A process is an instance which embodies one or several stack groups as well as
; appropriate variables to determine the stack-group's status and runnability.
; See PRODEF

;;; ACTIVE-PROCESSES*	1An alist of all processes that are runnable.
;;;*			1A process is runnable if it has at least one run
;;;*			1reason, and no arrest reasons.  This list is maintained
;;;*			1because it is considered too expensive to have the
;;;*			1scheduler inspect each process' run and arrest reasons.
;;; Each element on ACTIVE-PROCESSES looks like:
;;;*	1(process wait-function wait-arglist priority <slots for wait args>)
;;;*	1wait-arglist is usually a tail of this list
;;; CURRENT-PROCESS*	1The process that is currently running.  NIL inside the
;;;*			1scheduler.*

(defvar active-processes-element-size 9.)
(defvar active-processes-prefix-size 4.) ;Process, wait-function, wait-arglist, priority
		       
(defvar *NEXT-PROCESS-ID* nil
  "The next Process ID Number to be assigned to a newly spawned process.  
   The processor slot number is found at (byte 4. 16.).")

(defvar *PROCESS-IDS-IN-USE* nil)

(defmacro assign-process-id ()
  `(without-interrupts
     (push (setf process-id *NEXT-PROCESS-ID*)
	   *PROCESS-IDS-IN-USE*)
     (if (= (ldb (byte 16. 0) *Next-PROCESS-ID*) #xFFFF)
	 (roll-over-process-id)
	 (incf *Next-Process-Id*))))

(defun roll-over-process-id () 
  (do ((count (dpb (ldb (byte 4. 0) sys:processor-slot-number) (byte 4. 16.) 0) (1+ count)))
      ((not (member count *PROCESS-IDS-IN-USE*))
       (setf *NEXT-PROCESS-ID* count))))

(defun process-lock-id (locative-pointer &optional lock-value (whostate "Lock")
		     timeout)
  "Lock the cell which LOCATIVE-POINTER points to, waiting if it is already locked.
The lock cell contains NIL when not locked;
when locked, it contains the process that locked it.
If TIMEOUT is non-NIL, it is in 60'ths of a second,
and if that much time elapses we signal the SYS:LOCK-TIMEOUT error condition."
  (or lock-value (setq lock-value (process-process-id current-process)))
  (do ((locker (car locative-pointer) (car locative-pointer)))
      ((%store-conditional locative-pointer nil lock-value))
    (and (eq locker lock-value)
	 (ferror nil "Lock ~S already locked by this process" locative-pointer))
    (if timeout
	(unless
	  (process-wait-with-timeout whostate timeout
				     #'(lambda (bad-contents pointer)
					 (neq (car pointer) bad-contents))
				     locker
				     locative-pointer)
	  (cerror :no-action nil 'sys:lock-timeout
		  "The ~A ~S remained unavailable for ~D/60 seconds."
		  whostate locative-pointer timeout))
      (process-wait whostate
		    #'(lambda (bad-contents pointer)
			(neq (car pointer) bad-contents))
		    locker
		    locative-pointer))
    (setq timeout nil)))

(defun atomic-process-lock-id (locative-pointer &optional lock-value (whostate "Lock")
			       timeout)
  "Lock the cell which LOCATIVE-POINTER points to, waiting if it is already locked.
The lock cell contains NIL when not locked;
when locked, it contains the process that locked it.
If TIMEOUT is non-NIL, it is in 60'ths of a second,
and if that much time elapses we signal the SYS:LOCK-TIMEOUT error condition.
This is just like process-lock-id except it works for multiple processors. We
assume that the lock, specified by LOCATIVE-POINTER is in a shared region."
  (let ((slot   (ldb (byte 8. 24.) (si:%physical-address locative-pointer)))
	(offset (ldb (byte 24 0) (si:%physical-address locative-pointer))))
    (or lock-value (setq lock-value (process-process-id current-process)))
    (do ((locker (car locative-pointer) (car locative-pointer)))
	((si:%test&store-68k slot offset nil lock-value))
      (and (eq locker lock-value)
	   (ferror nil "Lock ~S already locked by this process" locative-pointer))
      (when locker
	(if timeout
	    (unless
	      (process-wait-with-timeout whostate timeout
					 #'(lambda (bad-contents pointer)
					     (neq (car pointer) bad-contents))
					 locker
					 locative-pointer)
	      (cerror :no-action nil 'sys:lock-timeout
		      "The ~A ~S remained unavailable for ~D/60 seconds."
		      whostate locative-pointer timeout))
	    (process-wait whostate
			  #'(lambda (bad-contents pointer)
			      (neq (car pointer) bad-contents))
			  locker
			  locative-pointer))
	(setq timeout nil)))))

(defun process-unlock-id (locative-pointer &optional lock-value (error-p t))
  "Unlock a lock locked with PROCESS-LOCK.
LOCATIVE-POINTER points to the cell which is the lock."
  (or lock-value (setq lock-value (process-process-id current-process)))
  (or (%store-conditional locative-pointer lock-value nil)
      (and error-p
	   (ferror nil "Attempt to unlock ~S, which you don't have locked"
		   locative-pointer))))

(defun make-active-processes (len)
;1; make a list of length <len> each element of which is a list of length *ACTIVE-PROCESSES-ELEMENT-SIZE 1 *
  (without-interrupts
    (let ((ap (make-list len :area permanent-storage-area)))1     ;; Make sure that list gets allocated contiguously *
      (do ((l ap (cdr l)))
	  ((endp l) ap)
	(rplaca l (make-list active-processes-element-size :area permanent-storage-area))))))

(defvar active-processes (make-active-processes process-active-length)
  1"List of processes considered for running.  They have run-reasons and are not arrested."*)

;;PHD 4/21/87 Conditionalize caching of those processes.
;;PHD 5/14/87 Changed default to NIL.
(defvar  *dont-cache-spare-processes* nil
   "If non null process-run-function processes are not pushed on PROCESS-RUN-FUNCTION-SPARE-PROCESSES 
when they get killed")

;;PHD 1/16/86 Fixed it, use copy-list to insure that the list will be cdr-coded.
1;Make an entry for this process in ACTIVE-PROCESSES, with its current wait condition,
;when it first becomes runnable.  Try not to cons.*
(defun process-active-entry (proc &aux aentry)
  (without-interrupts
    (process-all-processes proc t)
    (or (setq aentry (assoc proc active-processes :test #'eq))
	(setq aentry (assoc nil active-processes :test #'eq))
	1;; No free entries => make the list as long, still contiguous.*
	(let* ((default-cons-area working-storage-area)
	       (tem
		 (mapcar #'(lambda (ignore)
			     (make-list active-processes-element-size :area permanent-storage-area))
			 active-processes)))
	  (setq default-cons-area permanent-storage-area)
	  (setq active-processes
		(copy-list (append active-processes tem )))
	  (setq aentry (assoc nil active-processes :test #'eq))))
    (setf (first aentry) proc)
    (setf (fourth aentry) (process-priority proc))
    (process-reinsert-aentry aentry)
    (set-process-wait proc (process-wait-function proc) (process-wait-argument-list proc))))

(defun process-all-processes (proc add-p)
  1"Add or remove PROC in ALL-PROCESSES.
Must be called with interrupts inhibited."*
  (if add-p
      (or (member proc all-processes :test #'eq) (push proc all-processes))
      (progn
	(setq all-processes (delete proc (the list all-processes) :test #'eq
				    :count 1))
	(when *dont-cache-spare-processes*
	  (setf *PROCESS-IDS-IN-USE* (delete (process-process-id proc) *PROCESS-IDS-IN-USE*)))
	)))

;;PHD 4/6/87.  Inhibit stack list copy for process-wait rest arg.
;;AB  7/17/87. For PHD. Took out the binding of sys:%INHIBIT-STACK-LIST-COPY-FLAG.
;;             We stop the REST-ARG copy in another manner.
(defun set-process-wait (proc fun args &aux idx ape)
  "Set the wait condition of process PROC to function FUN applied to ARGS.
PROC will run when (APPLY FUN ARGS) returns non-NIL."
  (without-interrupts
    (setf (process-wait-function proc) fun)
    (setf (process-wait-argument-list proc) args)
    (cond ((null (setq ape (assoc proc active-processes :test #'eq))))
	  (t
	   (setf (second ape) fun)
	   (cond ((>= (setq idx (- active-processes-element-size (length args)))
		      active-processes-prefix-size)
		  (let ((l (nthcdr idx ape)))
		    (setf (third ape) l)
		    (do ((l l (cdr l))
			 (args args (cdr args)))
			((null args))
		      (rplaca l (car args)))))
		 (t (setf (third ape) args)))))))

(defun make-process (name &rest init-args)
  1"Create a process, with name NAME.
:FLAVOR specifies the flavor of process to make.
:SIMPLE-P if non-NIL specifies flavor SI:SIMPLE-PROCESS.
If :FLAVOR and :SIMPLE-P are NIL, the flavor SI:PROCESS is used.
:WARM-BOOT-ACTION is a function to call on warm booting,
 or :FLUSH meaning flush the process.  The default is to restart it.
 SI:PROCESS-WARM-BOOT-RESET kills the process.
 SI:PROCESS-WARM-BOOT-RESTART restarts at an earlier stage of booting.
:QUANTUM is in 60'ths and defaults to one second.
:PRIORITY defaults to 0; larger numbers run more often.
:STACK-GROUP specifies the stack group for this process to run in.
If that is omitted, the keyword arguments :SG-AREA,
:REGULAR-PDL-AREA, :SPECIAL-PDL-AREA, :REGULAR-PDL-SIZE,
and :SPECIAL-PDL-SIZE are passed on to MAKE-STACK-GROUP."*
  (declare (arglist name &key simple-p flavor stack-group warm-boot-action quantum priority
		    	      sg-area regular-pdl-area special-pdl-area
			      regular-pdl-size special-pdl-size
			      &allow-other-keys))
  (or (car init-args) (setq init-args (cdr init-args)))	;For backward compatibility
  (setq init-args (list* :name name init-args))
  (instantiate-flavor (or (getf init-args :flavor)
			  (and (getf init-args :simple-p) 'simple-process)
			  'process)
		      (locf init-args)
		      t))

(deff zlc:process-create 'make-process)

(defmethod (process :init) (init-plist)
  (or (variable-boundp stack-group)
      (setq stack-group (apply #'make-stack-group name
  				       :allow-unknown-keywords t :safe 0
				       (car init-plist))))
  (setq initial-stack-group stack-group)
  (assign-process-id))

(defmethod (simple-process :init) (ignore)
  (setq initial-form nil
	stack-group nil
	initial-stack-group nil)
  (assign-process-id))

(defmethod (process :after :init) (ignore)
  (without-interrupts
    (process-all-processes self t)))

(defmethod (process :print-self) (stream &rest ignore)
  (si:printing-random-object (self stream :typep)
    (princ name stream)))

(defun process-preset (process function &rest args)
  1"Preset PROCESS to apply FUNCTION to ARGS when next run."*
  (apply process :preset function args))

(defmethod (process :preset) (function &rest args)
  (setq initial-form (cons function (copy-list args)))
  (funcall self :reset))

1;This is the real initial function of all processes' initial stack groups.
;Its purpose is to make sure that the error handler Abort command works.
;It also prevents anything bad from happening if the specified top-level returns
;and arranges for typing out to do "background" stuff.*
(defun process-top-level (&optional ignore)
  (let ((*terminal-io* tv:default-background-stream))
    ;1; Bind these per process, and arrange that their values*
    1;; stay around even if the process is reset!*
    (unless (location-boundp (locf (process-closure current-process)))
      (setf (process-closure current-process)
	    (let-closed (+ ++ +++ * ** *** / // /// - *values*)
	      'funcall)))
    (%using-binding-instances (closure-bindings (process-closure current-process)))
    (do-forever
      (catch-error-restart (condition "Reset and arrest process ~A."
				      (send current-process :name))
	(unwind-protect
	    (error-restart ((sys:abort condition) "Restart process ~A."
			    (send current-process :name))
	      (apply (car (process-initial-form current-process))
		     (cdr (process-initial-form current-process)))
	      (process-flush-background-stream)
	      (process-wait-forever))
	  (process-flush-background-stream)))
      (send current-process :arrest-reason :user)
      (process-allow-schedule))))

(defun process-kill-top-level (&optional arg)
  1"Get here after unwinding the stack due to a kill type :RESET.  Makes the 
process unrunnable, and removes it from the ALL-PROCESSES list.  The process may be
enabled later.  If so, it will do the right thing by calling PROCESS-TOP-LEVEL."*
  (without-interrupts
    (process-disable current-process)
    (process-all-processes current-process nil)
    1;; This will never return unless the process is reenabled*
    (process-allow-schedule))
  1;; In case we are enabled again, act like we were just reset*
  (process-top-level arg))

(defun process-is-in-error-p (process &aux sg)
  1"Non-NIL if PROCESS is waiting for its window to be exposed, to handle an error.
The value is the window PROCESS is waiting for exposure of."*
  (typep (setq sg (process-stack-group process)) 'stack-group)
  (symeval-in-stack-group 'tv:process-is-in-error sg))

(defun process-flush-background-stream ()
  1"If **1TERMINAL-IO**1 is a background typeout window, release it for re-use."*
  (cond ((and (neq *terminal-io* tv:default-background-stream)
	      (typep *terminal-io* 'tv:background-lisp-interactor))
	 (and (get-handler-for *terminal-io* :wait-until-seen)
	      (funcall *terminal-io* :wait-until-seen))
	 (funcall *terminal-io* :deactivate)
	 (deallocate-resource 'tv:background-lisp-interactors *terminal-io*)
	 (setq *terminal-io* tv:default-background-stream))))


(defun process-reset (process)
  1"Unwind PROCESS and make it start over."*
  (funcall process :reset))

1;;; system patch 2-46, 4/22/86, RJF
;;;  Added check for %current-stack-group been equal to initial-stack-group to
;;;  prevent eh:unwind-sg from been ran in the initial sg which can cause a
;;;  "m-tem not a stack group" crash since there may not be a previous stack
;;;  group for that stack-group. See bug 1330*

(defmethod (process :reset) (&optional unwind-option kill &aux restart-fun)
  1"UNWIND-OPTION: T, never unwind; :UNLESS-CURRENT or NIL, unwinds the stack unless
the stack group is either in the current process or is the current stack group;
:ALWAYS, always unwinds the stack.  KILL is T to kill the process after optionally
unwinding it."*
  (without-interrupts
    (setq restart-fun (cond (kill #'process-kill-top-level)
			    ((eq stack-group initial-stack-group) #'process-top-level)
                            ((eq %current-stack-group initial-stack-group) #'process-top-level)  1;;RJF*
			    (t #'(lambda (&rest ignore)	1;Unwind and switch SG's*
				   (eh:unwind-sg (process-initial-stack-group current-process)
						 #'process-top-level nil nil)))))
    1;; Wake up*
    (setq whostate "Run")
    (set-process-wait self #'true nil)
    (cond ((eq self current-process)
	   (if (eq unwind-option :always) (*unwind-stack t nil nil restart-fun)
	       (when kill
		 (process-disable current-process)
		 (process-all-processes current-process nil))))
	  (t
	   1;; Note -- the following code is not logically necessary.  However,*
	   1;; it is here to make the cold-load come up when EH:UNWIND-SG*
	   1;; is not loaded yet.  We avoid unwinding the stack-group if it*
	   1;; has just been created.*
	   (and (sg-never-run-p stack-group)
		(setq unwind-option t))
	   1;; Cause the process, when next scheduled, to unwind itself and*
	   1;; call its initial function in the right stack group.*
	   (cond ((eq %current-stack-group stack-group)
		  1;; Not current process, but our stack group is the one running.*
		  1;; Respect NOUNWIND*
		  (if (eq unwind-option :always) (*unwind-stack t nil nil restart-fun)
		      (when kill
			(process-disable current-process)
			(process-all-processes current-process nil))))
		 ((neq unwind-option 't)
		  (let ((eh:*allow-pdl-grow-message* nil))
		    (DECLARE (SPECIAL EH:*ALLOW-PDL-GROW-MESSAGE*))   ;; DRH
		    (eh:unwind-sg stack-group restart-fun nil t)))
		 (t
		  (stack-group-preset stack-group restart-fun)))))))

(defmethod (simple-process :reset) (&optional unwind-option kill)
  unwind-option	1;ignored -- there is no stack group*
  (without-interrupts
    (setq stack-group (car initial-form))	1;Reset to initial function*
    (setq whostate "Run")			1;and un-block*
    (set-process-wait self #'true nil)
    (when kill
      (process-disable self)			1;Killing: remove from scheduler lists*
      (process-all-processes self nil))))

1; Process Interrupt Mechanism*

(defmethod (simple-process :interrupt) (function &rest args)
  function args 1;ignored*
  (ferror nil "Cannot interrupt a simple process"))


(defconstant chaparral-pdl-buffer-length 1024.)

(defvar pdl-buffer-length chaparral-pdl-buffer-length "2LENGTH OF PDL BUFFER*")


(defmethod (process :interrupt) (function &rest args)
  (if (eq self current-process)
      (progn (apply function args) t)		2;Note destination must be D-IGNORE*
      (do (state) (nil)				2;Loop until in interruptible state*
	(without-interrupts
	  (setq state (sg-current-state stack-group))
	  (when (= state sg-state-awaiting-call)	2;Called scheduler*
		(let ((rp (sg-regular-pdl stack-group))
		      (sp (sg-special-pdl stack-group))
		      (spp (sg-special-pdl-pointer stack-group))
		      (fp (sg-top-frame stack-group)))
		  (unless (eq (rp-function-word rp fp) #'call-stack-group)
			  (ferror nil "Call to ~S where scheduler stack group expected"
				  (rp-function-word rp fp)))

		  ;; Fixed problem with framing in getting 0th argument.  RJF 2/6/87
		  (unless (eq scheduler-stack-group (aref rp (rp-argument-offset stack-group rp fp)))
			  (ferror nil "Call to ~S where scheduler stack group expected"
				  (aref rp (rp-argument-offset stack-group rp fp))))
	      
		  2;; Remove frame of call to scheduler.  (call to CALL-STACK-GROUP)*
		2  ;;   remove UPCS (should be one word) followed by one binding of*
		2  ;;   inhibit-scheduling-flag (2 words)*
                  (or (eq (%data-type (aref sp spp))
                           dtp-fix)
		      (ferror nil "No UPCS saved on top of stack for CALL-STACK-GROUP"))
		  (or (eq (aref sp (- spp 1))
			  (%p-contents-as-locative (%make-pointer-offset dtp-locative 'inhibit-scheduling-flag 1)))
			     (ferror nil "No binding of INHIBIT-SCHEDULING-FLAG for CALL-STACK-GROUP"))

		  (setf (sg-special-pdl-pointer stack-group) (decf spp 3)) 2; top 3 for CALL-STACK-GROUP.*
		  (setf (sg-restore-microstack stack-group) 0)             2;otherwise will attempt to load bad stuff.*

		  (setf (sg-top-frame stack-group) (setq fp (eh:sg-next-frame stack-group fp)))

		  (setq state sg-state-resumable)
		  (set-process-wait self #'true nil)	2;Allow to wake up*

		  2;; If this function is PROCESS-WAIT, restart it at its start PC*
		2  ;; so that when returned to, it will test the wait condition again.*
		2  ;; Its stack level is sort of random, but that shouldn't hurt anything.*
		2  ;; Also it has a binding of INHIBIT-SCHEDULING-FLAG which needs attention*
		2 * (cond ((eq (rp-function-word rp fp) #'process-wait)
			 (setf (rp-exit-pc rp fp) (fef-initial-pc #'process-wait))
			 2;;Should be one binding for inhibit-scheduling-flag.*
			2 ;;Change the saved value of INHIBIT-SCHEDULING-FLAG to NIL.*
			2 ;;This one was bound by PROCESS-WAIT. It is assumed to be the MOST RECENT*
			2 ;;binding done by PROCESS-WAIT.*
			2 *(or (eq (aref sp spp)
				 (%p-contents-as-locative (%make-pointer-offset dtp-locative 'inhibit-scheduling-flag 1)))
			     (ferror nil "Where's my binding of INHIBIT-SCHEDULING-FLAG in Process-wait?"))
			 (%p-store-contents		2;Leave bound to NIL, not T*
			   (aloc sp (1- spp))	        2;Without clobbering the flag bit*
			   nil)))))
	  (when (= state sg-state-resumable)		2;Safe state to interrupt*
		(eh:sg-maybe-grow-pdls stack-group nil 128. 64.)	;Make space with no typeout
		(eh:sg-save-state stack-group t)	2;Save M-T, microcode state*
		(eh:push-new-frame stack-group (sg-top-frame stack-group) function args)
		(setf (sg-current-state stack-group) sg-state-invoke-call-on-return)
		(return)))				2;Interrupt will go off when process next scheduled*
	(process-wait "Interruptible" #'(lambda (p s)
					  (/= (sg-current-state (process-stack-group p)) s))
		      self state))))



(defmethod (process :flush) ()
  1"Put a process into 'flushed' state.  The process will remain flushed until it
is reset."*
  (cond ((eq self current-process))
	(t
	 (setq whostate "Flushed")
	 (set-process-wait self 'flushed-process nil))))


(defun process-blast (&optional (proc current-process))
  1"Blasting a process resets its wait function and argument list.  It is useful
when one of these generates an error."*
  (set-process-wait proc 'flushed-process nil))

(deff flushed-process #'false)

(defun process-disable (process)
  1"Stop PROCESS from running.  Removes all run reasons (and arrest reasons)."*
  (without-interrupts
    (setf (process-run-reasons process) nil)
    (setf (process-arrest-reasons process) nil)
    (process-consider-runnability process)))

(defun process-enable (process)
  1"Start PROCSS running.  Gives it :ENABLE as a run reason, and removes all arrest reasons."*
  (without-interrupts
    (setf (process-run-reasons process) nil)
    (setf (process-arrest-reasons process) nil)
    (funcall process :run-reason :enable)))

(defun process-reset-and-enable (process)
  1"Unwind PROCESS, restart it, and start it running."*
  (without-interrupts
   (funcall process :reset)
   (process-enable process)))

(defmethod (process :active-p) ()
  (assoc self active-processes :test #'eq))

(defmethod (process :runnable-p) ()
  (assoc self active-processes :test #'eq))

(defun process-consider-runnability (&optional (process self))
  1"Add PROCESS to ACTIVE-PROCESSES if it should be there; remove it if not."*
  (without-interrupts
   (cond ((or (process-arrest-reasons process) (null (process-run-reasons process)))
	  1;; Process is arrested, better not be active*
	  (let ((ape (assoc process active-processes :test #'eq)))
	    (when ape
	      (DO ((APE-REST APE (CDR APE-REST)))
		  ((null ape-rest))
		(setf (car ape-rest) nil))
	      (process-reinsert-aentry ape))
	    (tv:who-line-run-state-update)))
	 ((assoc process active-processes :test #'eq))
	 (t
	  (process-active-entry process)
	  1;; If process's stack group is in a bad state,*
	  1;; make it wait instead of actually running (unless it's current!).*
	  1;; ACTIVE is a bad state for a process which isn't running!*
	  (and (not (process-simple-p process))
	       (not (sg-resumable-p (process-stack-group process)))
	       current-process			 1;Prevents lossage in PROCESS-INITIALIZE*
	       (funcall process :flush))
	  (tv:who-line-run-state-update)))))

(defmethod (process :run-reason) (&optional (reason :user))
  (without-interrupts
    (unless (member reason run-reasons :test #'eq)
      (push reason run-reasons)
      (process-consider-runnability))))

(defmethod (process :revoke-run-reason) (&optional (reason :user))
  (without-interrupts
    (setq run-reasons (delete reason (the list run-reasons) :test #'eq
			      :count 1))
    (process-consider-runnability)))

(defmethod (process :arrest-reason) (&optional (reason :user))
  (without-interrupts
    (unless (member reason  arrest-reasons :test #'eq)
      (push reason arrest-reasons)
      (process-consider-runnability))))

(defmethod (process :revoke-arrest-reason) (&optional (reason :user))
  (without-interrupts
    (setq arrest-reasons (delete reason (the list arrest-reasons)
				 :test #'eq
				 :count 1))
    (process-consider-runnability)))

;;;PHD 2/26/87 add optional wait-p.
(defmethod (process :kill) (&optional wait-p)
  (if (or (not wait-p)
	  (eq self current-process))
      (funcall self :reset :always t)  
      (without-interrupts			;Kill the process, waiting for it unwind itself.
	(let ((eh:allow-pdl-grow-message nil)
	      (sg stack-group ))
	  (DECLARE (SPECIAL EH:ALLOW-PDL-GROW-MESSAGE))
	  (unless (sg-never-run-p sg)
	    (eh:unwind-sg sg %current-stack-group nil nil ))
	  (process-disable self)
	  (process-all-processes self nil)
	  (process-allow-schedule)))))

1;;; Priority and quantum stuff*
(defmethod (process :set-quantum) (new-quantum)
  (check-arg new-quantum numberp "a number")
  (setq quantum new-quantum))

(defmethod (process :set-priority) (new-priority)
  (check-arg new-priority numberp "a number")
  (without-interrupts
    (setq priority new-priority)
    (and (assoc self active-processes :test #'eq)
	 (process-active-entry self))))

1;; Put AENTRY into its proper position in ACTIVE-PROCESSES,
;; assuming that that is a cdr-coded list,
;; and that nothing else is out of order.*
(defun process-reinsert-aentry (aentry)
  (let ((old-pos (position  aentry (the list active-processes) :test #'eq))
	(new-pos
	  (do ((i 0 (1+ i))
	       (tail active-processes (cdr tail)))
	      ((or (null tail)
		   (and (neq (car tail) aentry)
			(or (null (caar tail))
			    (and (car aentry)
				 (< (fourth (car tail)) (fourth aentry))))))
	       i))))
    ;; NEW-POS is the position to insert before.
    (cond ((= new-pos old-pos) (ferror nil "Should not get here."))
	  ((= new-pos (1+ old-pos))
	   ;; In right place already.
	   )
	  ((> new-pos old-pos)
	   1(%blt-typed (%make-pointer-offset dtp-list active-processes (1+ old-pos))*
		1       (%make-pointer-offset dtp-list active-processes old-pos)*
		1       (- new-pos old-pos 1)*
		1       1)*
	   1(%p-store-cdr-code-offset cdr-next active-processes (- new-pos 2))*
;; TGC	   (%blt (%make-pointer-offset dtp-list active-processes (1+ old-pos))
;;		 (%make-pointer-offset dtp-list active-processes old-pos)
;;		 (- new-pos old-pos 1)
;;		 1)
;;	   (%p-dpb-offset cdr-next %%q-cdr-code active-processes (- new-pos 2))
	   (setf (car (%make-pointer-offset dtp-list active-processes (1- new-pos)))
		 aentry))
	  (t
	   (let ((cdrcode 1(%p-cdr-code-offset active-processes old-pos)*))
	     1(%blt-typed (%make-pointer-offset dtp-list active-processes (1- old-pos))*
			1 (%make-pointer-offset dtp-list active-processes old-pos)*
			1 (- old-pos new-pos)*
			1 -1)*
	     1(%p-store-cdr-code-offset cdrcode active-processes old-pos)*)
;; TGC	   (let ((cdrcode (%p-ldb-offset %%q-cdr-code active-processes old-pos)))
;;	     (%blt (%make-pointer-offset dtp-list active-processes (1- old-pos))
;;		   (%make-pointer-offset dtp-list active-processes old-pos)
;;		   (- old-pos new-pos)
;;		   -1)
;;	     (%p-dpb-offset cdrcode %%q-cdr-code active-processes old-pos))
	   (setf (car (%make-pointer-offset dtp-list active-processes new-pos))
		 aentry)))))

(defun process-order-active-processes ()
  1"Imposes an ordering on active processes for the priority mechanism.  Order is
from highest to lowest priority.  Priorities are simply compared numerically.  This
function MUST be called with interrupts inhibited."*
  (and (fboundp 'sort-short-list) 1;Cold-load!*
       (setq active-processes (sort-short-list active-processes
					       #'(lambda (p1 p2)
						   (cond ((null (first p1)) (null (first p2)))
							 ((null (first p2)) t)
							 (t (> (fourth p1)
							       (fourth p2)))))
					       nil))))

1;;; This is for the error handler*
(defmethod (process :coroutine-stack-groups) () nil)

(defmethod (coroutining-process :add-coroutine-stack-group) (-stack-group-)
  (unless (member -stack-group- coroutine-stack-groups :test #'eq)
    (push -stack-group- coroutine-stack-groups)))

1;;; Metering stuff*

(defmethod (process :reset-meters) ()
  (reset-process-time-meter total-run-time)
  (reset-process-time-meter disk-wait-time)
  (setq last-time-run nil
	page-fault-count 0
	percent-utilization 0))

1;Idle time in seconds, or NIL if forever*
(defmethod (process :idle-time) ()
  (cond ((eq self current-process) 0)
	((null last-time-run) nil)
	(t (truncate (time-difference (time) last-time-run) 60.))))

(defmethod (process :total-run-time) ()
  (fixnum-process-time-meter total-run-time))

(defmethod (process :disk-wait-time) ()
  (fixnum-process-time-meter disk-wait-time))

(defmethod (process :cpu-time) ()
  (- (fixnum-process-time-meter total-run-time)
     (fixnum-process-time-meter disk-wait-time)))

1;This is the 600th root of 1/2, thus the halflife is 10 seconds*
(defparameter percent-utilization-discount-factor 0.9992s0)
;;;(defparameter percent-utilization-discount-factor 0.99885s0)

(defmethod (process :percent-utilization) ()
  (let ((zunderflow t))
    (if (null last-time-run) 0
	(truncate (* percent-utilization (expt percent-utilization-discount-factor
				      (time-difference (time) last-time-run)))
	    200.))))	;100% shows up as 20 seconds (20000. milliseconds)

1;;; Miscellaneous process synchronization functions*

(defun process-allow-schedule ()
  1"Allow other processes to run, if they can, before continuing."*
  (setf (process-quantum-remaining current-process) -1)
  (funcall scheduler-stack-group)
  (tv:who-line-run-state-update))

;;;PHD 11/4/86 make so process-sleep will return t
;;;Somebody wanted to be reassured that it would return t.
(defun process-sleep (interval-in-60ths &optional (whostate "Sleep"))
  1"Wait for INTERVAL 60'ths of a second."*
  (process-wait whostate #'(lambda (start-time interval)
			     (declare (inline time-difference))
			     (>= (time-difference (time) start-time)
			        interval))
		(time) interval-in-60ths)
  t)


;;;PAD 2/6/87 Return nil as specified in Silver book.
(defun sleep (interval-in-seconds &optional (whostate "Sleep"))
  "Wait for about INTERVAL seconds.  INTERVAL need not be an integer."
  (process-wait whostate #'(lambda (start-time interval)
			     (declare (inline time-difference))
			     (>= (time-difference (time) start-time)
			        interval))
		(time) (round (* 60. interval-in-seconds)))
  nil)


1;;; Returns T if condition is true, NIL if you time out.*
(defun process-wait-with-timeout (whostate interval-in-60ths function &rest args )
  1"Wait until INTERVAL 60'ths of a second elapse, or (APPLY FUNCTION ARGS) is non-NIL.
WHOSTATE appears in the who line and in Peek while waiting.
The value is whatever FUNCTION returned, which will be NIL
if wake-up is due to using up INTERVAL.
If INTERVAL is NIL, we wait forever (same effect as (PROCESS-WAIT WHOSTATE FUNCTION ARGS))"*
  (let ((process-wait-value nil))
    (if (null interval-in-60ths)
	(apply 'process-wait whostate #'(lambda (value function &rest fn-args)
					  (setf (cdr value)
						(apply function fn-args)))
	       (locf process-wait-value) function args)
	(process-wait whostate #'(lambda (start-time interval value function args)
				   (declare (inline time-difference))
				   (or (setf (cdr value) (apply function args))
				       (>= (time-difference (time) start-time) interval)))
		      (time) interval-in-60ths (locf process-wait-value) function args))
    process-wait-value))

(defun process-wait-forever ()
  1"Wait forever.  Does not return.  However, the process may be restarted."*
  (process-wait "Wait forever" #'false))

1;; A lock may be any cell.  When a lock is in the unlocked state, the cell
;; contains NIL; otherwise the cell contains the process which locked the lock.
;; A lock is referred to by a locative pointer to the cell.*

(defun process-lock (locative-pointer &optional lock-value (whostate "Lock")
		     timeout)
  1"Lock the cell which LOCATIVE-POINTER points to, waiting if it is already locked.
The lock cell contains NIL when not locked;
when locked, it contains the process that locked it.
If TIMEOUT is non-NIL, it is in 60'ths of a second,
and if that much time elapses we signal the SYS:LOCK-TIMEOUT error condition."*
  (or lock-value (setq lock-value current-process))
  (do ((locker (car locative-pointer) (car locative-pointer)))
      ((%store-conditional locative-pointer nil lock-value))
    (and (eq locker lock-value)
	 (ferror nil "Lock ~S already locked by this process" locative-pointer))
    (if timeout
	(unless
	  (process-wait-with-timeout whostate timeout
				     #'(lambda (bad-contents pointer)
					 (neq (car pointer) bad-contents))
				     locker
				     locative-pointer)
	  (cerror :no-action nil 'sys:lock-timeout
		  "The ~A ~S remained unavailable for ~D/60 seconds."
		  whostate locative-pointer timeout))
      (process-wait whostate
		    #'(lambda (bad-contents pointer)
			(neq (car pointer) bad-contents))
		    locker
		    locative-pointer))
    (setq timeout nil)))

1;; Unlock the given lock.  The unlocker must be the same as the locker.*
(defun process-unlock (locative-pointer &optional lock-value (error-p t))
  1"Unlock a lock locked with PROCESS-LOCK.
LOCATIVE-POINTER points to the cell which is the lock."*
  (or lock-value (setq lock-value current-process))
  (or (%store-conditional locative-pointer lock-value nil)
      (and error-p
	   (ferror nil "Attempt to unlock ~S, which you don't have locked"
		   locative-pointer))))

;; RJF  9/22/87  Uncommented out this fucntion which is needed.
(defun make-process-queue (name size)
    1"Makes a process queue whose name is NAME and which can hold SIZE elements.
SIZE matters only in that if more than that many objects are put on the queue
then strict queueing behavior is not guaranteed for objects past the SIZE'th one."*
    (make-process-queue-internal :name name
  			       :make-array (:dimensions (1+ size))))


(defun process-queue-locker (queue)
  1"The process (or other object) which now \"possesses\" QUEUE, a PROCESS-QUEUE."*
  (aref queue 0))

(defun reset-process-queue (queue)
  1"Removes all processes enqueued on QUEUE, so that it is empty."*
  (without-interrupts
    (fill queue nil)))

(defun process-enqueue (queue &optional (lock-value current-process) (whostate "Lock"))
  1"Waits to possess QUEUE in the name of LOCK-VALUE (default is the current process).
Puts LOCK-VALUE at the end of the queue, then waits for it to
reach the front of the queue (to \"possess\" the queue).
Then returns with LOCK-VALUE still in possession of the queue.
WHOSTATE appears in the who line if it is necessary to wait."*
  (unless (%store-conditional (locf (aref queue 0)) nil (or lock-value current-process))
    (without-interrupts
      1;; If the queue is full, wait for there to be room.*
      (when (aref queue (- (length queue) 2))
	(process-wait whostate #'(lambda (loc) (null (contents loc)))
		      (locf (aref queue (1- (length queue))))))
      1;; There is room, so put us in the queue.*
      (dotimes (i (1- (length queue)))
	(let ((tem (locf (aref queue i))))
	  (cond ((%store-conditional tem nil (or lock-value current-process))
		 1;; Now wait until we reach the front before returning.*
		 (unless (zerop i)
		   (process-wait whostate #'(lambda (slot value)
					      (eq (contents slot) value))
				 (locf (aref queue 0))
				 (or lock-value current-process)))
		 (return))
		((eq (contents tem) (or lock-value current-process))
		 (ferror nil "~S is already enqueued on ~S."
			 (or lock-value current-process) queue))))))))

(defun process-dequeue (queue &optional (lock-value current-process) (error-p t))
  1"Assuming that LOCK-VALUE possesses QUEUE, releases possession.
The next thing on the queue will come to the front, or the queue may become empty.
An error occurs if ERROR-P is non-NIL and LOCK-VALUE is not currently
the object at the front of the queue.
LOCK-VALUE defaults to the current process."*
  (if (eq (or lock-value current-process) (process-queue-locker queue))
      (%blt-typed (aloc queue 1) (aloc queue 0)
		  (1- (length queue)) 1)
    (if error-p
	(ferror nil "~S is not currently locked by ~S."
		queue (or lock-value current-process)))))

1;;; The scheduler

;;; The processes on ACTIVE-PROCESSES are sorted according to priority.
;;; A process is runnable if its flush instruction returns non-NIL.

;;; This function runs in the scheduler stack group.  Its job is to decide which
;;; process is to be run next.  It does this in the following way:

;;; If the current process is runnable, it has not exceeded its quantum, and
;;; no higher priority task is runnable, then it is run.  If not, the queue
;;; is searched from left to right for the highest
;;; priority process that is runnable and has not been run in a while.  This
;;; process is then run for its quantum.

;;; The scheduler also knows about a clock queue.  Every time the clock ticks,
;;; the queue is inspected for entries which should be run.  If any are found,
;;; they are run and the entry is deactivated.*

;;PHD 4/8/87 moved set-process-wait into the scheduler to avoid consing.
;;AB 8/12/87.  Added code to support global process run/disk-time counters.  [SPR 5903]
;;JJP 9/14/87 fix/add color run bar support
;;ab 1/12/87.  Made SET-RUN-STATE a macro used here; defined in PROCESS-DEFINITIONS.
;;JHO 2/23/88.  Renamed *run-bar-off* to %run-bar-off and *run-bar-on* to %run-bar-on,
;;		which are a-memory locations.
;(defvar *run-bar-off* 8  "1Color map value of run bar in off state*")
;(defvar *run-bar-on* 1 "1Color map value of run bar in on state*")
(defun process-scheduler-for-chaparral ()
  (declare (inline time-difference))
   (without-interrupts ;No seq breaks in the scheduler
     (do ((remaining-quantum 0 0)
	  (next-process nil nil)
	  (old-current-process)
	  (this-time (time) (time))
	  (last-time (time) this-time)
	  (delta-time)
	  (next-who-time 0))
	 (())
       
       (setq delta-time (time-difference this-time last-time)
	     old-current-process current-process)
       
       (and current-process
	    (setf (process-quantum-remaining current-process)
		  (setq remaining-quantum
			(- (process-quantum-remaining current-process) delta-time))))
       
       (cond ((> delta-time 0)
	      ;; Run clock queue no more often than every 1/60 second.
	      (dolist (e clock-function-list)
		(catch-error (funcall e delta-time) nil))
	      (cond ((minusp (setq next-who-time (- next-who-time delta-time)))
		     (and (fboundp 'tv:who-line-update)
			  (catch-error (tv:who-line-update) nil))
		     (setq next-who-time 60.)))))
       (block found-process
	 (do ((procs active-processes)
	      (this-process-wants-to-run-buts-its-quantum-has-expired)
	      (first-of-this-priority)
	      (current-priority))
	     ((null (first (car procs))))
	   ;; Loop over all process of the current priority
	   (setq current-priority (fourth (car procs))
		 first-of-this-priority procs)
	   ;; If we find a process to run return from FOUND-PROCESS.
	   ;; If we have looked at all processes of this priority, return from RAN-OUT.
	   ;; This hair is equivalent to one loop with a catch around just the APPLY,
	   ;; but it avoids entering and exiting the catch so often.
	   (block ran-out (do (ape pri proc) (())
			    (catch 'process-wait-in-scheduler
			      (do-forever
				(setq ape (car procs))
				(and (or (null (setq proc (first ape)))
					 (not (= (setq pri (fourth ape)) current-priority)))
				     ;; Hit next priority level, or ran out of processes
				     (return-from ran-out))
				(and (cond ((let ((current-process proc))
					      (apply (second ape) (third ape)))
					    (setq this-process-wants-to-run-buts-its-quantum-has-expired proc)
					    t))
				     (plusp (process-quantum-remaining proc))
				     ;; It is runnable, and it has time remaining
				     (return-from found-process (setq next-process proc)))
				(pop procs)))
			    ;; Get here only on throw.
			    (pop procs)))
	   ;; Ran out of all processes at current priority level.  Reset their quantums.
	   (do ((ps first-of-this-priority (cdr ps)))
	       ((eq ps procs))
	     (setf (process-quantum-remaining (first (car ps)))
		   (process-quantum (first (car ps)))))
	   ;; If a process would have run at this priority level, but couldn't becase
	   (and this-process-wants-to-run-buts-its-quantum-has-expired
		(return-from found-process
		  (setq next-process this-process-wants-to-run-buts-its-quantum-has-expired)))))


       (SETF CURRENT-PROCESS NEXT-PROCESS)              
       (cond ((null next-process)
	      ;; No process to run, do idle time stuff
	      (WHEN (FBOUNDP 'gc-maybe-scavenge)
		(FUNCALL 'gc-maybe-scavenge)))
	     ;; THIS SECOND LEG SELECTS SCAVENGING OVER PROCESS EXECUTION IF CONS DRIVEN SCAVENGING IS NEAR
	     ;; AND THE SELECTED PROCESS IS A LOW PRIORITY HOG.
	     ((AND (NOT %scavenger-ws-enable)
		   (NOT %gc-flip-ready)
		   (NOT inhibit-scavenging-flag)
		   (NOT inhibit-idle-scavenging-flag)
		   (< (- (READ-METER '%COUNT-SCAVENGER-WORK)
			 (READ-METER '%COUNT-CONS-WORK))
		      4000000.)
		   (< (process-priority NEXT-PROCESS) 0.)
		   (> (process-percent-utilization NEXT-PROCESS) 33.))
	      ;; HERE WE ARE GOING TO LET THE SCAVENGER DO SOME WORK RATHER THAN THIS HOG PROCESS.
	      (LET ((start-time (fixnum-microsecond-time-for-scheduler-for-chaparral))
		    TIME-USED)
		(%gc-scavenge gc-idle-scavenge-quantum)
		(SETF TIME-USED (TIME-DIFFERENCE (fixnum-microsecond-time-for-scheduler-for-chaparral)
						 START-TIME))
		;; 1. POST THE SCAVENGE TIME SLICE TO THE PERCENT UTILIZATION OF THE HOG PROCESS
		;;    SO THAT IT DOES NOT DECAY AND LOOK LIKE A LOW UTILIZATION PROCESS.
		(setf (process-percent-utilization NEXT-PROCESS)
		      (let ((zunderflow t) 
			    TEM)
			(+ (if (setq tem (process-last-time-run NEXT-PROCESS))
			       (floor (* (process-percent-utilization NEXT-PROCESS)
					 (expt percent-utilization-discount-factor
					       (time-difference this-time tem))))
			       0)
			   ;; Don't use ROUND -- loses before RAT is loaded.
			   (truncate (+  TIME-USED 500.) 1000.))))
		;; 2. MAKE IT LOOK LIKE THE PROCESS RAN IN THIS TIME SLICE.
		(setf (process-last-time-run NEXT-PROCESS) this-time)))
	     ;; THIS THIRD LEG REALLY DISPATCHES TO A SELECTED PROCESS.
	     (next-process
	      (setf (process-whostate next-process) "Run")
	      (set-process-wait next-process #'true nil)
	      (set-run-state t)			;ab
	      (let ((sg (process-stack-group (setq current-process next-process)))
		    (start-time (fixnum-microsecond-time-for-scheduler-for-chaparral))
		    (start-disk-time (fixnum-read-meter-for-scheduler %disk-wait-time))
		    (start-page-faults
		      (fixnum-read-meter-for-scheduler   %COUNT-DISK-PAGE-READS)))
		(if (typep sg 'stack-group)
		    (let ((ret-val (stack-group-resume sg nil)))
		      (when (eq 'process-wait (car-safe ret-val))
			(apply #'set-process-wait (cdr ret-val))))
		    (CATCH 'PROCESS-WAIT-IN-SCHEDULER
		      (APPLY SG (CDR (PROCESS-INITIAL-FORm CURRENT-PROCESS)))))
		(set-run-state nil)		;ab
		(let ((p current-process)
		      (end-time (fixnum-microsecond-time-for-scheduler-for-chaparral))
		      (end-disk-time (fixnum-read-meter-for-scheduler %disk-wait-time))
		      (end-page-faults
			(fixnum-read-meter-for-scheduler   %COUNT-DISK-PAGE-READS))
		      tem time-used disk-time-used)
		  (increment-process-time-meter
		    (process-total-run-time p)
		    (setq time-used (time-difference end-time start-time)))
		  (increment-global-time-meter
		    global-process-total-time time-used)
		  (increment-process-time-meter
		    (process-disk-wait-time p)
		    (SETQ disk-time-used (time-difference end-disk-time start-disk-time)))
		  (increment-global-time-meter
		    global-process-disk-wait-time disk-time-used)
		  (incf (process-page-fault-count p) (- end-page-faults start-page-faults))
		  (setf (process-percent-utilization p)
			(let ((zunderflow t))
			  (+ (if (setq tem (process-last-time-run p))
				 (floor (* (process-percent-utilization p)
					   (expt percent-utilization-discount-factor
						 (time-difference this-time tem))))
				 0)
			     ;; Don't use ROUND -- loses before RAT is loaded.
			     (truncate (+ time-used 500.) 1000.))))
						;Above ^ typically takes a bit under a millisecond which is not bad
						;compared to calling TIME a few times, so it's probably not worth
						;putting in a big table of pre-computed values.
		  (setf (process-last-time-run p) this-time)
		  ;; Remember stack group of process last run
		  (or (process-simple-p p)
		      (setf (process-stack-group p)
			    %current-stack-group-previous-stack-group))))))
       
       ;; In case we took a page fault, the microcode will turn the run light on.
       ;; So turn it back off...this is a kind of kludge, but...
       (set-run-state nil)			;ab
       )))

;;AB 8/12/87.  New, for [SPR 5903].
(DEFUN install-new-scheduler (&optional (fn #'process-scheduler-for-chaparral))
  "Call this to install a new version of the scheduler."
  (WITHOUT-INTERRUPTS
    (STACK-GROUP-PRESET %scheduler-stack-group fn)
    (call-stack-group %scheduler-stack-group)))

;;AB 8/12/87.  New, for [SPR 5903].
(DEFVAR last-time-global-stats-reset 0)

;;AB 8/12/87.  New, for [SPR 5903].
(DEFUN reset-time-stats ()
  (SETF GLOBAL-PROCESS-DISK-WAIT-TIME-LOW 0.
	GLOBAL-PROCESS-DISK-WAIT-TIME-HIGH 0.
	GLOBAL-PROCESS-TOTAL-TIME-LOW 0.
	GLOBAL-PROCESS-TOTAL-TIME-HIGH 0.)
  (WHEN (FBOUNDP 'GET-UNIVERSAL-TIME)
    (SETF last-time-global-stats-reset (GET-UNIVERSAL-TIME))))

;;AB 8/12/87.  New, for [SPR 5903].
(ADD-INITIALIZATION "Reset Global Process stats" '(reset-time-stats) '(:before-cold))

;;AB 8/12/87.  New, for [SPR 5903].
(DEFUN TIME-STATS (&KEY (stream *standard-output*) (reset nil))
  "Display runtime statistics for all processes (not including scheduling overhead)."
  (LET* ((current-time (GET-UNIVERSAL-TIME))
	 (real-time (- current-time last-time-global-stats-reset))
	 (TOTAL-TIME (read-global-time-meter global-process-total-time))
	 (idle-time (- real-time (/ TOTAL-TIME 1000000.)))
	 (DISK-TIME (read-global-time-meter global-process-disk-wait-time))
	 (CPU-TIME (- TOTAL-TIME DISK-TIME)))
    (FORMAT stream "~%GLOBAL PROCESS STATISTICS for time period ~\\time\\ to ~\\time\\."
	    last-time-global-stats-reset current-time)
    (FORMAT stream "~%  Total real time:       ~12,3f seconds" real-time)
    (format stream "~%  Total idle time:       ~12,3f seconds ~5,1F% of total real time." idle-time
	    (* 100. (/ idle-time real-time)))
    (FORMAT stream "~%  Total busy time:       ~12,3F seconds ~5,1F% of total real time." (/ TOTAL-TIME 1000000.)
	    (* 100. (/ (/ total-time 1000000.) real-time)))
    (FORMAT stream "~%          Total CPU time:        ~12,3F seconds ~5,1F% of total busy time."
	    (/ CPU-TIME 1000000.) (* 100. (IF (ZEROP total-time) 0. (/ CPU-TIME TOTAL-TIME))))
    (FORMAT stream "~%          Total disk wait time:  ~12,3F seconds ~5,1F% of total busy time."
	    (/ DISK-TIME 1000000.) (* 100. (IF (ZEROP total-time) 0. (/ DISK-TIME TOTAL-TIME))))
    (WHEN RESET (reset-time-stats))))



1;;; PROCESS-RUN-FUNCTION and associated hair

;This is a list of processes which may be recycled by PROCESS-RUN-FUNCTION
;It exists to avoid excess consing of stacks and reclaiming of them via
;the ordinary garbage collector.*
(defvar process-run-function-spare-processes nil)

1;; Run a function in its own process*
(defun process-run-function (name-or-kwds function &rest args)
  1"Apply FUNCTION to ARGS in a separate process.
NAME-OR-KWDS is either a name for the process or a list of
alternating keywords and values.  The keywords allowed are:
:NAME - specifies the name for the process.
:RESTART-AFTER-RESET - T means restart the process if it is reset
 (instead of killing it, which is the default).
:RESTART-AFTER-BOOT - T means restart the process after warm booting.
:PRIORITY, :QUANTUM, :WARM-BOOT-ACTION - set those variables in the process."*
  (process-run-function-1 name-or-kwds function args nil))

(defun process-run-restartable-function (name function &rest args)
  1"Like PROCESS-RUN-FUNCTION but default is to restart process after booting or reset."*
  (process-run-function-1 name function args '(:restart-after-boot t :restart-after-reset t)))

(defun process-run-function-1 (name-or-keys function args local-keys)
  (let ((name (if (stringp name-or-keys) name-or-keys nil))
	(priority 0)
	(quantum 60.)
	restart-after-reset restart-after-boot process warm-boot-action)
    (keyword-extract (if (stringp name-or-keys) local-keys (append local-keys name-or-keys))
		     keywords
		     (name priority quantum restart-after-reset restart-after-boot
			   warm-boot-action)
      nil nil)
    (setq process (without-interrupts (or (pop process-run-function-spare-processes)
					  (make-process name
							:special-pdl-size 2048.
							:regular-pdl-size 6656.))))
    (setf (process-name process) (or name (setq name "Anonymous")))
    (setf (process-warm-boot-action process) (if (eq warm-boot-action :flush)
						 nil
					       (or warm-boot-action
						   (and restart-after-boot
							'process-warm-boot-delayed-restart)
						   'process-run-function-warm-boot-reset)))
    (setf (sg-name (process-initial-stack-group process)) name)
    (funcall process :set-quantum quantum)
    (funcall process :set-priority priority)
    (funcall process :reset-meters)
    (apply #'process-preset process
		   'process-run-function-internal restart-after-reset function args)
    (process-enable process)
    process))

(defun process-run-function-internal (restart-on-reset function &rest args)
  (or restart-on-reset (process-preset current-process
				       'process-run-function-internal-flush-process))
  (catch-error-restart ((sys:abort error) "Terminate and free process ~A."
			(send current-process :name))
    (apply function args))
  1;; When the function returns, disable this process and make it available*
  1;; for re-use.*
  (process-run-function-internal-flush-process))

;;PHD 4/21/87 Conditionalize caching of those processes.
(defun process-run-function-internal-flush-process ()
  (process-flush-background-stream)
  (without-interrupts
    (unless (or *dont-cache-spare-processes*
		(member current-process process-run-function-spare-processes :test #'eq))
      (push current-process process-run-function-spare-processes))
    (funcall current-process :kill)))

(defun process-run-function-warm-boot-reset (process)
  (process-warm-boot-reset process)
  (unless (member process process-run-function-spare-processes)
    (push process process-run-function-spare-processes)))

(defun process-warm-boot-reset (process)
  (without-interrupts
    (funcall process :preset #'(lambda ()
				  (funcall current-process :kill)
				  (process-wait-forever)))
    (funcall process :reset)
    (process-enable process)))

(defun process-warm-boot-restart (process)
  (process-reset process))

1;Like PROCESS-WARM-BOOT-RESTART but doesn't allow it to run until after
;initialization is complete.*
(defun process-warm-boot-delayed-restart (process)
  (push (cons process (process-run-reasons process)) delayed-restart-processes)
  (setf (process-run-reasons process) nil)
  (process-consider-runnability process)
  (process-reset process))			;Won't actually unwind until given run reason

(defun sb-on (&optional (when 'just-show-current-state)
	      &aux mask tem
	      (alist '( (:call . 1) (:unibus . 2) (:keyboard . 2) ;old name still supported.
		        (:chaos . 4) (:clock . 8.) )))
  1"Sets the sequence break enable flags:
The argument can be a keyword, a list of keywords, or a numeric mask.
Keywords are: :CALL, :UNIBUS, :CHAOS, :CLOCK
With no argument, just returns a list of keywords for what is enabled.
Argument of NIL means turn off sequence breaks."*
  (cond ((numberp when) (setq mask when))
	((null when) (setq mask 0))
	((eq when 'just-show-current-state) (setq mask %sequence-break-source-enable))
	((atom when)
	 (or (setq mask (cdr (assoc when alist :test #'eq)))
	     (ferror nil "~S invalid keyword.  Use :CALL, :UNIBUS, :CHAOS, or :CLOCK"
		         when)))
	(t (setq mask 0)
	   (dolist (kwd when)
	     (if (setq tem (cdr (assoc kwd alist :test #'eq)))
		 (setq mask (logior mask tem))
		 (ferror nil "~S invalid keyword.  Use :CALL, :UNIBUS, :CHAOS, or :CLOCK"
			     kwd)))))
  (setq %sequence-break-source-enable mask)
  (do ((l nil)
       (b 1 (lsh b 1)))
      ((zerop mask) l)
    (and (logtest b mask)
	 (push (if (setq tem (car (rassoc b alist))) tem b) l))
    (setq mask (boole 2 b mask))))

;;; Initialization

;;;JLM 3/14/89  Added this new function to initialize process-ids during INITIALIZE-COLD-LOAD
(defun process-id-initialize ()
  (if *NEXT-PROCESS-ID* 
      (setf *NEXT-PROCESS-ID* (dpb (ldb (byte 4. 0) sys:processor-slot-number) (byte 4. 16.) *NEXT-PROCESS-ID*))
      (setf *NEXT-PROCESS-ID* (dpb (ldb (byte 4. 0) sys:processor-slot-number) (byte 4. 16.) 0))))

;;;PHD 11/4/86 Changed the way we test if the scheduler stack-group exists.
(defun process-initialize ()
  (cond ((and (null SCHEDULER-EXISTS)
	      (null (and (boundp 'SCHEDULER-STACK-GROUP )
			 (typep SCHEDULER-STACK-GROUP 'stack-group))))
	 (unless (fboundp 'mouse-wakeup)
	   (fset 'mouse-wakeup #'true))
	 (setq scheduler-stack-group (make-stack-group "Scheduler" :safe 0))
	 (setq initial-process
	       (make-process "Initial Process"
			     :stack-group %current-stack-group
			     :initial-stack-group %current-stack-group
			     :initial-form '(lisp-top-level2)
			     :warm-boot-action 'process-warm-boot-restart))))
  1;; Below is done every time the machine starts up (warm or cold).  Unfortunately,*
  1;; the state of the current process has been lost, so it must be reset without*
  1;; unwinding it.  This is a total loss, but the only way to prevent this*
  1;; is to prevent warm booting.  WARM BOOTING IS STRONGLY DISCOURAGED.*
  (cond ((and (variable-boundp current-process)
	      current-process)
	 (setq warm-booted-process current-process)
	 (if (or (eq (process-warm-boot-action warm-booted-process)
		     'process-warm-boot-restart)
		 (eq warm-booted-process initial-process)
		 (typep warm-booted-process 'simple-process))
	     1;; Vital system process.  Make sure it can run.*
	     1;; The initial process => we are running in it now.*
	     (funcall (prog1 
			current-process 
			(setq current-process nil))
		      :reset t)			1;T means NOUNWIND*
	     1;; Some non-essential process.  Leave its state around.*
	     1;; Later we will ask whether to reset it.*
	     (send warm-booted-process :arrest-reason :warm-boot))
	 )
	(t (setq warm-booted-process nil)))
;;; (setq temporarily-no-idle-scavenging t)   removed, -ab 3/9/87
  (setf (process-stack-group initial-process) %current-stack-group)
  (process-enable initial-process)		1;enable even if warm-booted out of*
  (setq current-process initial-process)	1;see kludge in PROCESS-CONSIDER-RUNNABILITY*
  1;; Do to all active processes what they want done to them.*
  1;; The warm-boot-actions can sometimes cause ACTIVE-PROCESSES to get*
  1;; re-sorted, so make a copy.*
  (dolist (p (loop for (p) in active-processes until (null p)
		   collect p))
    (setf (process-last-time-run p) nil)
    (setf (process-percent-utilization p) 0)
    (or (and (process-warm-boot-action p)
	     (neq (process-warm-boot-action p) :flush)
	     (errset (funcall (process-warm-boot-action p) p) nil))
	(funcall p :flush)))
  
  (setq %scheduler-stack-group scheduler-stack-group)
  (stack-group-preset scheduler-stack-group (appropriate-process-scheduler))
  (setq scheduler-exists t)
  (funcall scheduler-stack-group nil)  ;; drh change --
  (setq inhibit-scheduling-flag nil)
  (sb-on :clock))

(defun reset-warm-booted-process ()
  1"Reset the process warm-booted out of and let it run again."*
  (when warm-booted-process
    (send warm-booted-process :reset t)
    (send warm-booted-process :revoke-arrest-reason :warm-boot)
    (setq warm-booted-process nil)))

(defun debug-warm-booted-process ()
  1"Enter the debugger examining the process that was running at the time of the warm boot."*
  (if warm-booted-process
      (eh warm-booted-process)
    1"The warm-booted process has already been reset, or there never was one."*))

(defun appropriate-process-scheduler nil #'process-scheduler-for-chaparral)

(ADD-INITIALIZATION "Process ID Init" '(PROCESS-ID-INITIALIZE) '(:SYSTEM :NOW))
1;;; Don't run this the first time, only when the system initializations normally get run*
(ADD-INITIALIZATION "Process" '(PROCESS-INITIALIZE) '(SYSTEM NORMAL))

(compile-flavor-methods process simple-process coroutining-process)