;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Written 05/15/89 11:26:36 by FISH, ;;; Reason: Remove scheduler change introduced for EAS. It was a bad idea re performance. ;;; while running on DaVinci from band LOD9 ;;; With SYSTEM 6.0, VIRTUAL-MEMORY 6.0, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.0, TV 6.0, DATALINK 6.0, CHAOSNET 6.0, GC 6.0, MEMORY-AUX 6.0, NVRAM 6.0, ;;; SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0, ;;; DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.0, SERIAL 6.0, PRINTER 6.0, MAC-PRINTER-TYPES 6.0, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.0, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.0, VISIDOC 6.0, TI-CLOS 6.0, CLEH 6.0, IP 3.45, ;;; Experimental BUG 11.4, Experimental CLX 6.0, Experimental CLUE 21.0, Experimental X11M 4.0, ;;; microcode 12, Band Name: Rel 6.0 + SLE 5/12 #!C ; From file PROCESSES.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; PROCESSES.#" (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 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 ))) (EVAL-WHEN (LOAD) (SI:install-new-scheduler)) ))