;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Private patches made by RG
;;; Reason:
;;;  foo
;;; Reason:
;;;  New scheduler data structures!
;;; Written 2-Feb-87 13:49:50 by RG at site LMI Cambridge
;;; while running on Alex from band 3
;;; with Experimental System 121.17, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, microcode 1730, SDU Boot Tape 3.12, SDU ROM 102.



; From modified file DJ: L.SYS2; PRODEF.LISP#60 at 2-Feb-87 13:50:00
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PRODEF  "

(DEFFLAVOR PROCESS
 (NAME				;Print name
  STACK-GROUP			;Stack group currently executing on behalf of this process
  (WAIT-FUNCTION 'FLUSHED-PROCESS) ;Predicate to determine if process is runnable
  (WAIT-ARGUMENT-LIST NIL)	;Arguments passed to above (use an arg to avoid a closure)
				; This will often be a rest argument in somebody's stack,
				; but it will always be used in a safe manner.
  (WAIT-WHOSTATE "Just Created");The "whostate" string for the who line for use when the
				; process is waiting to run. Set to NIL by the scheduler
				; whenever the process runs.
				; See run-whostate below.
  INITIAL-STACK-GROUP		;The stack group which PROCESS-RESET (q.v.) will reset to.
  INITIAL-FORM			;Form to preset the initial stack group to when proc is reset.
				; Really cons of function and evaluated args.
  (RUN-REASONS NIL)		;List of run reasons for this process.
  (ARREST-REASONS NIL)		;List of arrest reasons for this process.
  (QUANTUM DEFAULT-QUANTUM)	;Number of ticks process should run at most before
				; running another process.
  (QUANTUM-REMAINING 0)		;Amount of time remaining for this process to run.
  (PRIORITY 0)			;Absolute priority of this process.  The larger the number,
				; the more this process wants to run.  It will never be
				; run for more than its quantum, though.
  (WARM-BOOT-ACTION		;Thing to do to this process if it is active when the
   'PROCESS-WARM-BOOT-DELAYED-RESTART)	; machine is warm-booted.
				;  NIL means the default action
				; (flush it).  If non-NIL, gets funcalled with the process
				; as its argument.
	;The default is to reset it after initializations have been completed
	;[I'm not sure why it's this rather than to leave it alone.]
  (SIMPLE-P NIL)		;T if the process is simple (has no stack group)
  (LAST-TIME-RUN NIL)		;(TIME) process last woke up, NIL if never
  (TOTAL-RUN-TIME-LOW 0)	;Low bits of total run time in microseconds
  (TOTAL-RUN-TIME-HIGH 0)	;High bits of same
  (DISK-WAIT-TIME-LOW 0)	;Low bits of disk wait time in microseconds
  (DISK-WAIT-TIME-HIGH 0)	;High bits of same
  (PAGE-FAULT-COUNT 0)		;Number of disk page waits
  (PERCENT-UTILIZATION 0)	;Exponential average of total run time
  CLOSURE
; this ivar not patched in 99
  (RUN-WHOSTATE "Run")		;The whostate string to be used when the process is running.
  (AENTRY-WITH-CONS nil)	;Structure for entry into ACTIVE-PROCESSES.  Or NIL.
 ;SPARE-SLOT-1			;Allow experimentation without making new cold load
  SPARE-SLOT-2			;..
  )
  ()
  :ORDERED-INSTANCE-VARIABLES
  :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES
  (:GETTABLE-INSTANCE-VARIABLES NAME STACK-GROUP WAIT-FUNCTION WAIT-ARGUMENT-LIST
				INITIAL-STACK-GROUP INITIAL-FORM
				RUN-REASONS ARREST-REASONS QUANTUM QUANTUM-REMAINING
				PRIORITY WARM-BOOT-ACTION SIMPLE-P
				LAST-TIME-RUN PAGE-FAULT-COUNT)
  (:SETTABLE-INSTANCE-VARIABLES WARM-BOOT-ACTION WAIT-WHOSTATE RUN-WHOSTATE)
  (:INITABLE-INSTANCE-VARIABLES NAME STACK-GROUP WAIT-FUNCTION WAIT-ARGUMENT-LIST
				INITIAL-STACK-GROUP INITIAL-FORM
				RUN-REASONS ARREST-REASONS QUANTUM
				PRIORITY WARM-BOOT-ACTION SIMPLE-P)
  (:INIT-KEYWORDS :FLAVOR
		  ;; Keywords for stack group
		  :SG-AREA :REGULAR-PDL-AREA :SPECIAL-PDL-AREA :REGULAR-PDL-SIZE
		  :SPECIAL-PDL-SIZE :CAR-SYM-MODE :CAR-NUM-MODE :CDR-SYM-MODE :CDR-NUM-MODE
		  :SWAP-SV-ON-CALL-OUT :SWAP-SV-OF-SG-THAT-CALLS-ME :TRAP-ENABLE :SAFE
		  :CLOSURE-VARIABLES
		  :WHOSTATE)			;for compatibility
  (:DEFAULT-INIT-PLIST :CLOSURE-VARIABLES *DEFAULT-PROCESS-CLOSURE-VARIABLES*))
;; methods are in SYS2; PROCES


))

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:06
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(DEFUN MAKE-ACTIVE-PROCESSES (LEN &AUX AP)
  (WITHOUT-INTERRUPTS
    (SETQ AP (MAKE-LIST LEN :AREA PERMANENT-STORAGE-AREA :CDR-CODED NIL))
    (DO ((L AP (CDR L)))
	((NULL L) AP)
      (SETF (CAR L) (MAKE-LIST ACTIVE-PROCESSES-ELEMENT-SIZE :AREA PERMANENT-STORAGE-AREA)))
    ))

(defun make-aentry-with-cons ()
  (cons-in-area
    (MAKE-LIST ACTIVE-PROCESSES-ELEMENT-SIZE :AREA PERMANENT-STORAGE-AREA)
    nil
    permanent-storage-area))

))


; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:13
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "

(defvar idle-aentries-for-active-processes (MAKE-ACTIVE-PROCESSES PROCESS-ACTIVE-LENGTH))
(defvar active-processes-args-length (- active-processes-element-size  ;# args which can be
					active-processes-prefix-size)) ; accomodated.

))

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:17
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(DEFUN new-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
    (catch 'process-wait-in-scheduler (apply fun args))
    (SETF (PROCESS-WAIT-FUNCTION PROC) FUN)
  ;Following IF is temporary.  Remove after system 121.  ***
    (if (= (%p-data-type (locf (process-aentry-with-cons proc)))
	   dtp-null)
	(setf (process-aentry-with-cons proc) nil))
    (cond ((SETQ APE (car (process-aentry-with-cons proc)))  ;(ASSQ PROC ACTIVE-PROCESSES)
	   (SETF (SECOND APE) FUN)
	   (COND (( (SETQ IDX (- ACTIVE-PROCESSES-args-length (LENGTH ARGS)))
		     0)
		  (LET ((L (NTHCDR active-processes-prefix-size APE)))
		    (dotimes (c idx)	;wipe unused slots.
		      (setf (car l) nil)
		      (setq l (cdr l)))
		    (SETF (THIRD APE) L)
		    (SETF (PROCESS-WAIT-ARGUMENT-LIST PROC) L)
		    (DO ((L L (CDR L))
			 (ARGS ARGS (CDR ARGS)))
			((NULL ARGS))
		      (SETF (CAR L) (CAR ARGS)))))
		 (T			;get here if too many args for pre-allocated list (>5).
					; Formerly, lost completely, case may not arise.
		  (let ((a (copy-list args)))
		    (SETF (THIRD APE) A)
		    (SETF (PROCESS-WAIT-ARGUMENT-LIST PROC) A)))))
	  (t (setf (process-wait-argument-list proc) (copylist args))))))

))

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:19
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(DEFUN new-PROCESS-ENABLE (PROCESS)
  "Start PROCSS running.  Gives it :ENABLE as a run reason, and removes all arrest reasons."
  (WITHOUT-INTERRUPTS
    (process-all-processes process t)
    (if (= (%p-data-type (locf (process-aentry-with-cons process)))		;*temporary*
	   dtp-null)
	(setf (process-aentry-with-cons process) nil))
    (SETF (PROCESS-RUN-REASONS PROCESS) NIL)
    (SETF (PROCESS-ARREST-REASONS PROCESS) NIL)
    (SEND PROCESS :RUN-REASON :ENABLE)))

))

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:22
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(DEFUN new-PROCESS-CONSIDER-RUNNABILITY (&OPTIONAL (PROCESS SELF))
  "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)))
     	   ;; Process is arrested, better not be active
	   (let ((cons (process-aentry-with-cons process)))
	     (when cons
		;This might be "unsafe", so copy it.  See SET-PROCESS-WAIT.
	       (setf (process-wait-argument-list process)
		     (copylist (process-wait-argument-list process)))
	       (do ((p (value-cell-location 'active-processes) (cdr p)))
		   ((null p))
		 (cond ((eq (cdr p) cons)
			(return (rplacd p (cddr p))))))
	       (rplacd cons idle-aentries-for-active-processes)
	       (setq idle-aentries-for-active-processes cons)
	       (setf (process-aentry-with-cons process) nil)))	       
      ;	   (LET ((APE (ASSQ PROCESS ACTIVE-PROCESSES)))
      ;	     (WHEN APE
      ;	       (SETF (CAR APE) NIL)
      ;	       (PROCESS-REINSERT-AENTRY APE)))
	     (TV::WHO-LINE-RUN-STATE-UPDATE))
      ;	  ((ASSQ PROCESS ACTIVE-PROCESSES))
	  ((process-aentry-with-cons process))
	  (T
  ;	   (PROCESS-ALL-PROCESSES PROCESS T)     ;assure on ALL-PROCESSES.  ** flush this**
	   (let* ((cons (cond (idle-aentries-for-active-processes
			       (prog1 idle-aentries-for-active-processes
				      (setq idle-aentries-for-active-processes
					    (cdr idle-aentries-for-active-processes))))
			      (t (make-aentry-with-cons))))
		  (aentry (car cons)))
	     (RPLACD CONS ACTIVE-PROCESSES)
	     (SETQ ACTIVE-PROCESSES CONS)
	     (SETF (PROCESS-AENTRY-WITH-CONS PROCESS) CONS)
	     (SETF (FIRST AENTRY) PROCESS)
	     (SETF (FOURTH AENTRY) (PROCESS-PRIORITY PROCESS))
	     (PROCESS-REINSERT-AENTRY AENTRY)
	     (SET-PROCESS-WAIT PROCESS
			       (PROCESS-WAIT-FUNCTION PROCESS)
			       (PROCESS-WAIT-ARGUMENT-LIST PROCESS)))

	   ;; If process's stack group is in a bad state,
	   ;; make it wait instead of actually running (unless it's current!).
	   ;; 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			;Prevents lossage in PROCESS-INITIALIZE
		(SEND PROCESS :FLUSH))
	   (TV::WHO-LINE-RUN-STATE-UPDATE)))))

))

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:24
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(DEFMETHOD (process :new-set-priority) (NEW-PRIORITY)	;(PROCESS :SET-PRIORITY)
  (CHECK-TYPE NEW-PRIORITY NON-COMPLEX-NUMBER)
  (WITHOUT-INTERRUPTS
    (SETQ PRIORITY NEW-PRIORITY)
    (AND (ASSQ SELF ACTIVE-PROCESSES)
	 (process-aentry-with-cons self)		;was (PROCESS-ACTIVE-ENTRY self).
	 (process-reinsert-aentry (car (process-aentry-with-cons self))))))

))

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:26
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(defun new-process-reinsert-aentry (aentry)
  "Make sure AENTRY, which must currently be on ACTIVE-PROCESSES, is in
the right place with regards to priority."
  (prog (p cons)
	(setq p (value-cell-location 'active-processes))
  l1    (cond ((null p)
	       (ferror "Should not get here"))
	      ((eq (cadr p) aentry)
	       (setq cons (cdr p))
	       (rplacd p (cddr p))
	       (go reinsert)))
	(setq p (cdr p))
	(go l1)
 reinsert
  ; in new scheme, should not be on at all it PROC is NULL.
  ;	(cond ((null (first aentry))
  ;	       (rplacd cons idle-aentry-for-active-processes)
  ;	       (setq idle-aentry-for-active-processes cons)
  ;	       (return nil)))
	(setq p (value-cell-location 'active-processes))
  l2	(cond ((null p)
	       (ferror "Should not get here"))
	      ((or (null (cdr p))
		   (< (fourth (cadr p)) (fourth aentry)))
	       (rplacd cons (cdr p))
	       (rplacd p cons)
	       (return cons)))
	(setq p (cdr p))
	(go l2)))

))


;** special installer

; From modified file DJ: L.SYS2; PROCES.LISP#193 at 2-Feb-87 13:50:11
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; PROCES  "


(defun install-new-sched nil
  (let ((old-active-processes nil))
    (without-interrupts
      (setq old-active-processes active-processes
	    ACTIVE-PROCESSES nil)
      (dolist (p all-processes)
	(setf (process-aentry-with-cons p) nil))
      (setf (process-aentry-with-cons tv:kbd-process) nil)
      (dolist (p process-run-function-spare-processes)
	(setf (process-aentry-with-cons p) nil))
      (fset 'set-process-wait 'new-set-process-wait)
      (fset 'process-enable 'new-process-enable)
      (fset 'process-consider-runnability 'new-process-consider-runnability)
      (fset 'process-reinsert-aentry 'new-process-reinsert-aentry)
      (SETF (FDEFINITION '(:method process :set-priority))
	    (fdefinition '(:method process :new-set-priority)))
      (dolist (p old-active-processes)
	(COND ((EQ (CAR P) CURRENT-PROCESS)
	       (let* ((cons (cond (idle-aentries-for-active-processes
				   (prog1 idle-aentries-for-active-processes
					  (setq idle-aentries-for-active-processes
						(cdr idle-aentries-for-active-processes))))
				  (t (make-aentry-with-cons))))
		      (aentry (car cons)))
		 (RPLACD CONS ACTIVE-PROCESSES)
		 (SETQ ACTIVE-PROCESSES CONS)
		 (SETF (PROCESS-AENTRY-WITH-CONS (CAR P)) CONS)
		 (SETF (FIRST AENTRY) (CAR P))
		 (SETF (FOURTH AENTRY) (PROCESS-PRIORITY (CAR P)))
		 (PROCESS-REINSERT-AENTRY AENTRY)))
	      ((CAR P)
	       (process-consider-runnability (CAR P)))))
      )))



))