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.*

;;	9/15/88 JLM - added process-id variable to process flavor definition
;;		      added property-list mixin to process flavor definition

(DEFVAR CURRENT-PROCESS NIL 1"The process which is currently executing."*)
(DEFVAR INITIAL-PROCESS)		1;The first process made*

(DEFVAR ALL-PROCESSES NIL 1"A list of all processes that have not been \"killed\"."*)
(DEFVAR PROCESS-ACTIVE-LENGTH 30.)	1;Initial length of ACTIVE-PROCESSES*
(DEFVAR WARM-BOOTED-PROCESS NIL)	1;When you warm boot*
(DEFVAR DELAYED-RESTART-PROCESSES NIL)	1;Processes to be restarted after initialization

;;; Scheduling*

(DEFVAR INHIBIT-SCHEDULING-FLAG)	1;Inhibits clock and process-switching*
(DEFVAR CLOCK-FUNCTION-LIST NIL)	1;At clock time, each element is funcalled on the*
					1; number of 60ths that have elapsed recently.*
(DEFVAR SCHEDULER-STACK-GROUP)		1;The stack group in which the scheduler runs.*
(DEFVAR SCHEDULER-EXISTS NIL)		1;T if the scheduler and processes are set up.*
(DEFVAR SYSTEM-BEING-INITIALIZED-FLAG T)1 ;T while coming up, mainly for error-handler*
(DEFVAR DEFAULT-QUANTUM 60.)		1;by default, run each process for at least one second*

;;AB 8/12/87.  New global counters for [SPR 5903]
(DEFVAR GLOBAL-PROCESS-TOTAL-TIME-LOW 0)
(DEFVAR GLOBAL-PROCESS-TOTAL-TIME-HIGH 0)
(DEFVAR GLOBAL-PROCESS-DISK-WAIT-TIME-LOW 0)
(DEFVAR GLOBAL-PROCESS-DISK-WAIT-TIME-HIGH 0)


1;;; Processes*
(DEFFLAVOR PROCESS
	   (NAME				1;Print name*
	    STACK-GROUP				1;Stack group currently executing on behalf of this process*
	    (WAIT-FUNCTION 'FLUSHED-PROCESS)	1;Predicate to determine if process is runnable*
	    (WAIT-ARGUMENT-LIST NIL)		1;Arguments passed to above (use an arg to avoid a closure)*
						1; This will often be a rest argument in somebody's stack,*
						1; but it will always be used in a safe manner.*
	    (WHOSTATE "Just Created")		1;The "WHOSTATE" string for the who line, etc.*
	    INITIAL-STACK-GROUP			1;The stack group which PROCESS-RESET (q.v.) will reset to.*
	    INITIAL-FORM			1;Form to preset the initial stack group to when proc is reset.*
						1; Really cons of function and evaluated args.*
	    (RUN-REASONS NIL)			1;List of run reasons for this process.*
	    (ARREST-REASONS NIL)		1;List of arrest reasons for this process.*
	    (QUANTUM DEFAULT-QUANTUM)		1;Number of ticks process should run at most before*
						1; running another process.*
	    (QUANTUM-REMAINING 0)		1;Amount of time remaining for this process to run.*
	    (PRIORITY 0)			1;Absolute priority of this process.  The larger the number,*
						1; the more this process wants to run.  It will never be*
						1; run for more than its quantum, though.*
	    (WARM-BOOT-ACTION			1;Thing to do to this process if it is active when the*
	      'PROCESS-WARM-BOOT-DELAYED-RESTART)	1; machine is warm-booted.*
						1;  NIL means the default action*
						1; (flush it).  If non-NIL, gets funcalled with the process*
						1; as its argument.*
						1;The default is to reset it after initializations have been completed*
						1;[I'm not sure why it's this rather than to leave it alone.]*
	    (SIMPLE-P NIL)			1;T if the process is simple (has no stack group)*
	    (LAST-TIME-RUN NIL)			1;(TIME) process last woke up, NIL if never*
	    (TOTAL-RUN-TIME-LOW 0)		1;Low bits of total run time in microseconds*
	    (TOTAL-RUN-TIME-HIGH 0)		1;High bits of same*
	    (DISK-WAIT-TIME-LOW 0)		1;Low bits of disk wait time in microseconds*
	    (DISK-WAIT-TIME-HIGH 0)		1;High bits of same*
	    (PAGE-FAULT-COUNT 0)		1;Number of disk page waits*
	    (PERCENT-UTILIZATION 0)		1;Exponential average of total run time*
	    PROCESS-ID				1;Sequentially assigned unique id*
						1;* 1(includes processor slot number* 1in byte 4. 16)*
	    SPARE-SLOT-1			1;Allow experimentation without making new cold load*
	    SPARE-SLOT-2			;..
	    
	    (SELECTION NIL)			;1Selection structure during SELECTIVE-WAIT and process calls.*
	    (RESULT-VALUES NIL)			;1Values returned via. RESPOND.*
	    (OWN-CONSES NIL)			;1Process's own available conses which are reclaimed after each use.*
	    (SUSPENSION-EXPLANATION NIL)	;1String explaining why process is suspended. (similar to WHOLINE).*
	    (QUEUE NIL)				;1Ready queue for this process.*
	    (QUEUE-NEXT NIL)			;1Next process in this ready queue.*
	    (QUEUE-PREVIOUS NIL)		;1Previous process in this ready queue.*
	    (EXTENSION NIL)			;1Extension for other stuff ...*
	    )
	   (property-list-mixin)
  :ordered-instance-variables
  :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES
  (:GETTABLE-INSTANCE-VARIABLES NAME STACK-GROUP WAIT-FUNCTION WAIT-ARGUMENT-LIST
				WHOSTATE INITIAL-STACK-GROUP INITIAL-FORM
				RUN-REASONS ARREST-REASONS QUANTUM QUANTUM-REMAINING
				PRIORITY WARM-BOOT-ACTION SIMPLE-P PROCESS-ID
				LAST-TIME-RUN PAGE-FAULT-COUNT)
  (:SETTABLE-INSTANCE-VARIABLES WARM-BOOT-ACTION)
  (:INITABLE-INSTANCE-VARIABLES NAME STACK-GROUP WAIT-FUNCTION WAIT-ARGUMENT-LIST
				WHOSTATE INITIAL-STACK-GROUP INITIAL-FORM
				RUN-REASONS ARREST-REASONS QUANTUM
				PRIORITY WARM-BOOT-ACTION SIMPLE-P PROCESS-ID)
  (:INIT-KEYWORDS :FLAVOR
		  1;; 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))

(DEFSUBST PROCESS-CLOSURE (PROC)
  (PROCESS-SPARE-SLOT-1 PROC))

(DEFFLAVOR SIMPLE-PROCESS () (PROCESS)
  (:DEFAULT-INIT-PLIST :SIMPLE-P T
    		       :WAIT-FUNCTION #'TRUE)
  (:DOCUMENTATION 1"A process that has no stack group of its own.
It runs in the scheduler stack group and keeps no stack state between runs."*))

(DEFFLAVOR COROUTINING-PROCESS ((COROUTINE-STACK-GROUPS NIL)) (PROCESS)
  :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES
  :GETTABLE-INSTANCE-VARIABLES
  (:DOCUMENTATION "A process that has several stack groups that call each other."))

1;;; Two word meters*
(DEFMACRO RESET-PROCESS-TIME-METER (SLOT-NAME)
  (LET ((LOW (INTERN (STRING-APPEND SLOT-NAME "-LOW")))
	(HIGH (INTERN (STRING-APPEND SLOT-NAME "-HIGH"))))
    `(SETQ ,LOW 0 ,HIGH 0)))

;;AB 8/12/87.  Fix for 25-bit FIXNUMs.  [SPR 5902]
(DEFMACRO FIXNUM-PROCESS-TIME-METER (SLOT-NAME)
  (LET ((LOW (INTERN (STRING-APPEND SLOT-NAME "-LOW")))
	(HIGH (INTERN (STRING-APPEND SLOT-NAME "-HIGH"))))
    `(DPB ,HIGH (BYTE (1- (BYTE-SIZE %%Q-Pointer))
		      (1- (BYTE-SIZE %%Q-Pointer))) ,LOW)))

;;AB 8/12/87.  Fix for 25-bit FIXNUMs.  [SPR 5902]
(DEFMACRO INCREMENT-PROCESS-TIME-METER ((SLOT-NAME PROCESS) INCREMENT)
  (LET ((LOW (INTERN (STRING-APPEND SLOT-NAME "-LOW")))
	(HIGH (INTERN (STRING-APPEND SLOT-NAME "-HIGH"))))
    `(LET ((TEM (%pointer-plus ,INCREMENT (,LOW ,PROCESS))))
       (IF (NOT (MINUSP TEM))
	   (SETF (,LOW ,PROCESS) TEM)
	   (PROGN
	     (SETF (,LOW ,PROCESS)
		   (LDB (BYTE (1- (BYTE-SIZE %%Q-Pointer)) 0) TEM))
	     (SETF (,HIGH ,PROCESS) (%pointer-plus (,high ,process) 1)))))))


;;AB 8/12/87.  New, for [SPR 5903].
(DEFMACRO READ-global-TIME-METER (name)
  (LET ((LOW (INTERN (STRING-APPEND name "-LOW")))
	(HIGH (INTERN (STRING-APPEND name "-HIGH"))))
    `(DPB ,HIGH (BYTE (1- (BYTE-SIZE %%Q-Pointer))
		      (1- (BYTE-SIZE %%Q-Pointer))) ,LOW)))

;;AB 8/12/87.  New, for [SPR 5903].
(DEFMACRO INCREMENT-global-TIME-METER (name INCREMENT)
  (LET ((LOW (INTERN (STRING-APPEND name "-LOW")))
	(HIGH (INTERN (STRING-APPEND name "-HIGH"))))
    `(LET ((TEM (%pointer-plus ,INCREMENT ,LOW)))
       (IF (NOT (MINUSP TEM))
	   (SETF ,LOW TEM)
	   (PROGN
	     (SETF ,LOW 
		   (LDB (BYTE (1- (BYTE-SIZE %%Q-Pointer)) 0) TEM))
	     (SETF ,HIGH (%pointer-plus ,high 1)))))))

1;A version of TIME:FIXNUM-MICROSECOND-TIME which is open-coded and loaded earlier
;so that the scheduler can call it*
(DEFSUBST FIXNUM-MICROSECOND-TIME-FOR-SCHEDULER-FOR-CHAPARRAL ()
  (COMPILER:%FIXNUM-MICROSECOND-TIME))

1;An open-coded, positive-fixnum-returning version of READ-METER*
(DEFMACRO FIXNUM-READ-METER-FOR-SCHEDULER (NAME)
   (LET ((A-OFF (OR (POSITION NAME (THE LIST A-MEMORY-COUNTER-BLOCK-NAMES) :TEST #'EQ)
		    (FERROR NIL "~S is not a valid counter name" NAME))))
     `(%P-LDB (1- %%Q-POINTER)
	      (+ %COUNTER-BLOCK-A-MEM-ADDRESS A-MEMORY-VIRTUAL-ADDRESS ,A-OFF))))

(DEFSUBST RUN-LIGHT-FOR-CHAPARRAL ()
  (NOT (ZEROP (%P-LDB #o0020 REALLY-RUN-LIGHT))))

(DEFSETF RUN-LIGHT-FOR-CHAPARRAL () (VALUE)
  `(LET ((VAL (IF ,VALUE
		  (lognot (si:%p-ldb (byte 25. 0) (- REALLY-RUN-LIGHT 8)))
		  (si:%p-ldb (byte 25. 0) (- REALLY-RUN-LIGHT 8)))))
     (%P-DPB VAL #o0020 REALLY-RUN-LIGHT)
     (%P-DPB VAL #o2020 REALLY-RUN-LIGHT)))

;; RJF  9/22/87  Make constructor callable as macro so can use :make-array feature
(DEFSTRUCT (PROCESS-QUEUE :NAMED-ARRAY-LEADER (:CONSTRUCTOR MAKE-PROCESS-QUEUE-INTERNAL)
			  (:callable-constructors nil ))
  
  NAME)

;; support for run bar percentages
(DEFSUBST scavenge-time ()
  (%nubus-read *addin-memory-slot* (+ %Driver-Data-Start %DD-scavenge-time)))

(DEFSETF scavenge-time () (VALUE)
  `(%nubus-write *addin-memory-slot* (+ %Driver-Data-Start %DD-scavenge-time) ,value))

(DEFSUBST page-time ()
  (%nubus-read *addin-memory-slot* (+ %Driver-Data-Start %DD-page-time)))

(DEFSETF page-time () (VALUE)
  `(%nubus-write *addin-memory-slot* (+ %Driver-Data-Start %DD-page-time) ,value))

(DEFSUBST run-bar-interval ()
  (%nubus-read *addin-memory-slot* (+ %Driver-Data-Start %DD-cpu-interval)))

(DEFSETF run-bar-interval () (VALUE)
  `(%nubus-write *addin-memory-slot* (+ %Driver-Data-Start %DD-cpu-interval) ,value))

(DEFSUBST run-bar-total-time ()
  (%nubus-read *addin-memory-slot* (+ %Driver-Data-Start %DD-cpu-time)))

(DEFSETF run-bar-total-time () (VALUE)
  `(%nubus-write *addin-memory-slot* (+ %Driver-Data-Start %DD-cpu-time) ,value))

(DEFSUBST total-elapsed-time ()
  (%nubus-read *addin-memory-slot* (+ %Driver-Data-Start %DD-total-elapsed-time)))

(DEFSETF total-elapsed-time () (VALUE)
  `(%nubus-write *addin-memory-slot*
		    (+ %Driver-Data-Start %DD-total-elapsed-time) ,value))

(DEFSUBST total-interval ()
  (%nubus-read *addin-memory-slot* (+ %Driver-Data-Start %DD-total-interval)))

(DEFSETF total-interval () (VALUE)
  `(%nubus-write *addin-memory-slot*
		    (+ %Driver-Data-Start %DD-total-interval) ,value))

(DEFPARAMETER *reset-mx-timers* 3000000.)

(DEFUN reset-mx-timers (&optional (zero-timers nil))
  (if zero-timers
      (SETF (total-elapsed-time) 0 
	(run-bar-total-time) 0
	(page-time) 0
	(scavenge-time) 0)
      (SETF (total-elapsed-time) (ASH (total-elapsed-time) -6) 
	(run-bar-total-time) (ASH (run-bar-total-time) -6)
	(page-time) (ASH (page-time) -6)
	(scavenge-time) (ASH (scavenge-time) -6))))

;;ab 1/12/88 new.
(DEFVAR *addin-run-indicator* nil)

;; new 7/88 GRH
;; consolidate all csib run bar code in one place, and add plane mask support
;; for multiple monitors.
(defun csib-set-run-state (state &optional (address REALLY-RUN-LIGHT))
  "Set run state to STATE on csib.  State must be T meaning ON, NIL for OFF, or an integer value to write."
  (let ((fg-save (%nubus-read tv:tv-slot-number %CSIB-FOREGROUND-COLOR-OFFSET))
	(bg-save (%nubus-read tv:tv-slot-number %CSIB-BACKGROUND-COLOR-OFFSET))
	(pm-save (%nubus-read tv:tv-slot-number %CSIB-PLANE-MASK-OFFSET)))
    (unwind-protect
	(progn
	  (%nubus-write tv:tv-slot-number %CSIB-FOREGROUND-COLOR-OFFSET %run-bar-on)
	  (%nubus-write tv:tv-slot-number %CSIB-BACKGROUND-COLOR-OFFSET %run-bar-off)
	  ;; run bar plane masking for dual monitors - GRH
	  (%nubus-write tv:tv-slot-number %CSIB-PLANE-MASK-OFFSET
			(logxor (ldb #o1010 %run-bar-on) #xFF))   ; logxor for compatibility with old mcr
	  (cond ((integerp state)
		 (%P-DPB (LDB #o0020 state) #o0020 address)
		 (%P-DPB (LDB #o2010 state) #o2020 address))
		((null state)
		 (%P-DPB 0 #o0020 address)
		 (%P-DPB 0 #o2020 address))
		(t
		 (%P-DPB -1 #o0020 address)
		 (%P-DPB -1 #o2020 address))))
      (%nubus-write tv:tv-slot-number %CSIB-FOREGROUND-COLOR-OFFSET fg-save)
      (%nubus-write tv:tv-slot-number %CSIB-BACKGROUND-COLOR-OFFSET bg-save)
      (%nubus-write tv:tv-slot-number %CSIB-PLANE-MASK-OFFSET pm-save)
      )))

(DEFMACRO set-run-state (state)
  "Set run state to STATE (must be T meaning ON, or NIL for OFF)."
  `(LET ()
     (DECLARE (SPECIAL *sib-present*))
     (COND ((NOT *sib-present*)
	    (SETF *addin-run-indicator* ,state)
	    (let ((time-now (%microsecond-time)))
	      (WHEN (> (total-elapsed-time) *reset-mx-timers*)
		(reset-mx-timers))
	      (UNLESS (ZEROP (total-interval))
		(SETF (total-elapsed-time) (+ (total-elapsed-time) (- time-now (total-interval)))))
	      (SETF (total-interval) time-now)
		  (if ,state
		      (when (zerop (run-bar-interval))  ;only if was off before
			(setf (run-bar-interval) time-now))
		      (unless (zerop (run-bar-interval))  ; shut off, ignore if already off
			(setf (run-bar-total-time) (+ (run-bar-total-time) (- time-now (run-bar-interval))))
			(setf (run-bar-interval) 0)))))
	   ((AND tv:sib-is-csib (boundp 'si:%run-bar-on))
	    (csib-set-run-state ,state))
	   (t (setf (run-light-for-chaparral) ,state))))
  )