scheduler patch
"Shawn Betts" <[email protected]> Wed, 4 Apr 2007 17:41:01 -0700
| Newsgroups | gmane.lisp.movitz.devel |
|---|---|
| Message-ID | <[email protected]> |
Hi Frode, Here's my scheduler patch. Woven into it is a better keyboard interrupt handler. There are 2 things that I'm a bit iffy about: * the package it's in * that there's a seperate class, process, instead of wrapper get/set function around (%run-time-context-slot target-rtc <slot>). Maybe making a new class is the right way, but this seemed tempting, if I understand it properly. -Shawn
scheduler.patch
(application/octet-stream, 25 KB)
--- losp/los0.lisp 31 Oct 2005 09:18:08 -0000 1.50
+++ losp/los0.lisp 5 Apr 2007 00:26:52 -0000
@@ -30,6 +30,7 @@
(require :lib/repl)
(require :lib/threading)
+(require :lib/scheduler)
;; (require :lice-0.1/all)
@@ -868,13 +869,6 @@
(+ (ash (ldb (byte 16 0) hi) 13)
(ash lo -16)))))
(setf internal-time-units-per-second res))))))))
- (setf (symbol-function 'sleep)
- (lambda (seconds)
- ;; A stupid busy-waiting sleeper.
- (check-type seconds (real 0 *))
- (loop with start-time = (get-internal-run-time)
- with end-time = (+ start-time (* seconds internal-time-units-per-second))
- while (< (get-internal-run-time) end-time))))
(values))
@@ -1090,24 +1084,23 @@
(return (values)))))))
(defun los0-debugger (condition)
- (without-interrupts
- (let ((*debugger-dynamic-context* (muerte::current-dynamic-context))
- (*standard-output* *debug-io*)
- (*standard-input* *debug-io*)
- (*debugger-condition* condition)
- (*package* (or (and (packagep *package*) *package*)
- (find-package "INIT")
- (find-package "USER")
- (find-package "COMMON-LISP")
- (error "Unable to find any package!")))
- (*repl-prompt-context* #\d)
- #+ignore (*repl-readline-context* (or *repl-readline-context*
- (make-readline-context :history-size 16))))
- (let ((*print-safely* t))
- (invoke-toplevel-command :error))
- (loop
- (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*))
- (read-eval-print))))))
+ (let ((*debugger-dynamic-context* (muerte::current-dynamic-context))
+ (*standard-output* *debug-io*)
+ (*standard-input* *debug-io*)
+ (*debugger-condition* condition)
+ (*package* (or (and (packagep *package*) *package*)
+ (find-package "INIT")
+ (find-package "USER")
+ (find-package "COMMON-LISP")
+ (error "Unable to find any package!")))
+ (*repl-prompt-context* #\d)
+ #+ignore (*repl-readline-context* (or *repl-readline-context*
+ (make-readline-context :history-size 16))))
+ (let ((*print-safely* t))
+ (invoke-toplevel-command :error))
+ (loop
+ (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*))
+ (read-eval-print)))))
(defun xwrite (object)
(with-inline-assembly (:returns :nothing)
@@ -1335,6 +1328,11 @@
(+ (muerte::check-the fixnum a)
(muerte::check-the fixnum b)))
+(defun turn-on-irqs ()
+ ;; listen for timer and keyboard IRQ interrupts
+ (setf (pic8259-irq-mask) #xfffc)
+ (with-inline-assembly (:returns :nothing) (:sti)))
+
(defun genesis ()
;; (install-shallow-binding)
(setf *debugger-function* #'los0-debugger)
@@ -1344,7 +1342,7 @@
(setf extended-memsize (* 256 (io-port #x71 :unsigned-byte8)))
(setf (io-port #x70 :unsigned-byte8) #x17)
(incf extended-memsize (io-port #x71 :unsigned-byte8))
- (format t "Extended memory: ~D KB~%" extended-memsize)
+;; (format t "Extended memory: ~D KB~%" extended-memsize)
(idt-init)
@@ -1375,7 +1373,6 @@
(setf *package* (find-package "INIT"))
(when muerte::*multiboot-data*
(set-textmode +vga-state-90x30+))
-
(cond
((not (cpu-featurep :tsc))
(warn "This CPU has no time-stamp-counter. Timer-related functions will not work."))
@@ -1392,7 +1389,11 @@
(setf threading:*segment-descriptor-table-manager*
(make-instance 'threading:segment-descriptor-table-manager))
-
+
+ (muerte.x86-pc.keyboard:setup-kbd)
+ (muerte.lib::setup-scheduling)
+ (turn-on-irqs)
+
;;; (ignore-errors
;;; (setf (symbol-function 'write-char)
;;; (muerte.x86-pc.serial::make-serial-write-char :baudrate 38400))
--- losp/lib/package.lisp 24 Nov 2004 14:20:55 -0000 1.6
+++ losp/lib/package.lisp 5 Apr 2007 00:26:52 -0000
@@ -67,6 +67,26 @@
;;; #:*repl-print-format*
;;; #:*repl-readline-context*
;;; #:read-eval-print
+
+ ;; scheduling
+ *ticks-per-second*
+ *scheduler-function*
+ scheduler
+ process-run-function
+ process-wait
+ process-wait-with-timeout
+ process-enable
+ process-disable
+ process-enable-run-reason
+ process-disable-run-reason
+ process-enable-arrest-reason
+ process-disable-arrest-reason
+ clear-process-run-time
+ process-kill
+ process-block-with-timeout
+ process-block
+ process-unblock
+
))
(provide :lib/package)
--- losp/lib/threading.lisp 12 Mar 2007 22:50:34 -0000 1.9
+++ losp/lib/threading.lisp 5 Apr 2007 00:26:55 -0000
@@ -178,8 +178,9 @@
(assert (eq (muerte::stack-frame-funobj nil ebp)
(muerte::asm-register :esi)) ()
"Will not yield to a non-yield frame.")
- ;; Push eflags for later..
- (setf (memref (decf esp) 0 :type :unsigned-byte32) (eflags))
+ ;; Push eflags (with IF enabled) for later. Make sure interrupt
+ ;; interrupt flag in on.
+ (setf (memref (decf esp) 0 :type :unsigned-byte32) (logior 512 (eflags)))
;; Store EBP and ESP so we can get to them after the switch
(setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp
(%run-time-context-slot target-rtc 'muerte::scratch2) esp)
--- losp/x86-pc/keyboard.lisp 31 Mar 2007 21:08:13 -0000 1.8
+++ losp/x86-pc/keyboard.lisp 5 Apr 2007 00:26:56 -0000
@@ -14,6 +14,7 @@
;;;;
;;;;------------------------------------------------------------------
+(require :lib/package)
(require :lib/named-integers)
(provide :x86-pc/keyboard)
@@ -26,6 +27,7 @@
poll-key
set-leds
cpu-reset
+ setup-kbd
set-kbd-layout))
(in-package muerte.x86-pc.keyboard)
@@ -48,6 +50,7 @@
nil :kp-ins nil :kp-del nil nil nil :f11 ; #x50
:f12 nil nil nil nil nil nil nil ; #x58
+ ;; e0 scancodes are mapped into this area
nil nil nil nil nil nil nil nil ; #x60
nil nil nil nil nil nil nil nil ; #x68
nil nil nil nil nil nil nil nil ; #x70
@@ -184,9 +187,121 @@
(setf *scan-codes* normal
*scan-codes-shift* shifted)))
+(defvar *keyboard-state* nil)
+(defvar *keyboard-queue* nil)
+
+(defvar *keyboard-last-code* nil)
+
+;; map e0 codes into our scancode space
+(defconstant +e0-base+ #x60)
+(defconstant +e0-kpenter+ (+ +e0-base+ 0))
+(defconstant +e0-rctrl+ (+ +e0-base+ 1))
+(defconstant +e0-kpslash+ (+ +e0-base+ 2))
+(defconstant +e0-prscr+ (+ +e0-base+ 3))
+(defconstant +e0-ralt+ (+ +e0-base+ 4))
+(defconstant +e0-break+ (+ +e0-base+ 5))
+(defconstant +e0-home+ (+ +e0-base+ 6))
+(defconstant +e0-up+ (+ +e0-base+ 7))
+(defconstant +e0-pgup+ (+ +e0-base+ 8))
+(defconstant +e0-left+ (+ +e0-base+ 9))
+(defconstant +e0-right+ (+ +e0-base+ 10))
+(defconstant +e0-end+ (+ +e0-base+ 11))
+(defconstant +e0-down+ (+ +e0-base+ 12))
+(defconstant +e0-pgdn+ (+ +e0-base+ 13))
+(defconstant +e0-ins+ (+ +e0-base+ 14))
+(defconstant +e0-del+ (+ +e0-base+ 15))
+;; BTC
+(defconstant +e0-macro+ (+ +e0-base+ 16))
+;; LK450
+(defconstant +e0-f13+ (+ +e0-base+ 17))
+(defconstant +e0-f14+ (+ +e0-base+ 18))
+(defconstant +e0-help+ (+ +e0-base+ 19))
+(defconstant +e0-do+ (+ +e0-base+ 20))
+(defconstant +e0-f17+ (+ +e0-base+ 21))
+(defconstant +e0-kpminplus+ (+ +e0-base+ 22))
+
+(defconstant +e1-pause+ (+ +e0-base+ 23))
+
+;; This is initialized in setup-kbd
+(defvar *e0-keys* nil
+ "Lookup table that maps e0 codes into the scancode space.")
+
+(defun send-kbd-command (cmd-code)
+ (kbd-wait)
+ (setf (io-port #x64 :unsigned-byte8) cmd-code))
+
+(defun kbd-wait ()
+ (loop until (logbitp 1 (io-port #x64 :unsigned-byte8))))
+
(defun lowlevel-event-p ()
(logbitp 0 (io-port #x64 :unsigned-byte8)))
+(defun kbd-int-handler (vector exception-frame)
+ (declare (ignore vector exception-frame))
+ ;; (write-line "key event.")
+ ;; (send-kbd-command #xAD) ; disable keyboard
+ ;; (kbd-wait)
+ (when (lowlevel-event-p)
+ (let ((scancode (io-port #x60 :unsigned-byte8)))
+ ;; #xfa #xfe #xff
+ (if (find scancode '(#xe0 #xe1))
+ (setf *keyboard-last-code* scancode)
+ (let ((release-p (logbitp 7 scancode))
+ (scancode (ldb (byte 7 0) scancode)))
+ (when *keyboard-last-code*
+ ;; usually #xe0
+ (if (eql *keyboard-last-code* #xe0)
+ (progn
+ (setf *keyboard-last-code* nil)
+ ;; Apparently these codes should be ignored
+ (unless (find scancode '(#x2a #x36))
+ (let ((newcode (svref *e0-keys* scancode)))
+ (if newcode
+ (setf scancode newcode)
+ (warn "keyboard: unknown scancode #xe0 #x~x" scancode)))))
+ (cond ((and (eql *keyboard-last-code* #xe1)
+ (eql scancode #x1d))
+ (setf *keyboard-last-code* :pause-sequence))
+ ((and (eql *keyboard-last-code* :pause-sequence)
+ (eql scancode #x45))
+ (setf scancode +e1-pause+
+ *keyboard-last-code* nil))
+ (t
+ (warn "keyboard: unknown e1 escape sequence")
+ (setf *keyboard-last-code* nil)))))
+ ;; Now scancode contains the proper scan code. Keep track of
+ ;; it's pressed status and throw the (key . release) pair on
+ ;; the queue.
+ (setf (bit *keyboard-state* scancode) (if release-p 0 1)
+ *keyboard-queue* (append *keyboard-queue* (list (cons scancode release-p))))))))
+ ;; interrupt cleanup
+ ;; (send-kbd-command #xAE) ; enable the keyboard
+ (pic8259-end-of-interrupt 1)
+ ;; we need to call this for rescheduling
+ (muerte.lib:scheduler))
+
+(defun setup-kbd ()
+ (setf *e0-keys* (vector nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil +e0-kpenter+ +e0-rctrl+ nil nil
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil nil +e0-kpslash+ nil +e0-prscr+
+ +e0-ralt+ nil nil nil nil +e0-f13+ +e0-f14+ +e0-help+
+ +e0-do+ +e0-f17+ nil nil nil nil +e0-break+ +e0-home+
+ +e0-up+ +e0-pgup+ nil +e0-left+ nil +e0-right+ +e0-kpminplus+ +e0-end+
+ +e0-down+ +e0-pgdn+ +e0-ins+ +e0-del+ nil nil nil nil
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil +e0-macro+
+ nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil nil)
+ *keyboard-queue* nil
+ *keyboard-state* (make-array 256 :element-type 'bit :initial-element 0)
+ (exception-handler 33) #'kbd-int-handler)
+ (write-line "Keyboard Initialized."))
+
(defun keyboard-ack ()
(prog1 (io-port #x60 :unsigned-byte8)
(let ((x (io-port #x61 :unsigned-byte8)))
@@ -201,27 +316,6 @@
(io-port #x61 :unsigned-byte8) a))
(io-delay 500000))
-(defun lowlevel-read ()
- "Read a keyboard event. Return two values:
-The scan-code, with bit 7 set if it was an extended (#xe0) code.
-Secondly, whether this was a release event is returned."
- (let ((first-code (io-port #x60 :unsigned-byte8)))
- (case first-code
- (#xe0
- ;; (warn "e0")
- (let ((second-code (progn
- (loop until (logbitp 0 (io-port #x64 :unsigned-byte8)))
- (io-port #x60 :unsigned-byte8))))
- (values (logior #x80 second-code)
- (logbitp 7 second-code))))
- (#xe1 ; XXX
- (loop until (logbitp 0 (io-port #x64 :unsigned-byte8)))
- (io-port #x60 :unsigned-byte8)
- (loop until (logbitp 0 (io-port #x64 :unsigned-byte8)))
- (io-port #x60 :unsigned-byte8))
- (t (values (ldb (byte 7 0) first-code)
- (logbitp 7 first-code))))))
-
(defconstant +qualifier-shift+ 0)
(defconstant +qualifier-ctrl+ 1)
(defconstant +qualifier-alt+ 2)
@@ -263,22 +357,29 @@
;;; (< -1 key-code (length *scan-codes*)))
(defun get-key ()
- (when (lowlevel-event-p)
- (multiple-value-bind (key-code release-p)
- (lowlevel-read)
- (let ((key (or (decode-key-code key-code *qualifier-state*)
- key-code)))
- (case key
- ((:ctrl-left :ctrl-right)
- (setf (ldb (byte 1 +qualifier-ctrl+) *qualifier-state*)
- (if release-p 0 1)))
- ((:shift-left :shift-right)
- (setf (ldb (byte 1 +qualifier-shift+) *qualifier-state*)
- (if release-p 0 1)))
- ((:alt-left :alt-right)
- (setf (ldb (byte 1 +qualifier-alt+) *qualifier-state*)
- (if release-p 0 1))))
- (values key release-p)))))
+ (muerte.lib:process-wait "get-key" #'(lambda () (and *keyboard-queue* t)))
+ (when *keyboard-queue*
+ (let* ((key-pair (pop *keyboard-queue*))
+ (key-code (car key-pair))
+ (release-p (cdr key-pair))
+ (key (or (decode-key-code key-code *qualifier-state*)
+ key-code)))
+;; (when (lowlevel-event-p)
+;; (multiple-value-bind (key-code release-p)
+;; (lowlevel-read)
+;; (let ((key (or (decode-key-code key-code *qualifier-state*)
+;; key-code)))
+ (case key
+ ((:ctrl-left :ctrl-right)
+ (setf (ldb (byte 1 +qualifier-ctrl+) *qualifier-state*)
+ (if release-p 0 1)))
+ ((:shift-left :shift-right)
+ (setf (ldb (byte 1 +qualifier-shift+) *qualifier-state*)
+ (if release-p 0 1)))
+ ((:alt-left :alt-right)
+ (setf (ldb (byte 1 +qualifier-alt+) *qualifier-state*)
+ (if release-p 0 1))))
+ (values key release-p))))
(defun poll-keypress ()
(multiple-value-bind (key release-p)
--- losp/lib/scheduler.lisp 5 Apr 2007 00:26:56 -0000
+++ losp/lib/scheduler.lisp 5 Apr 2007 00:26:56 -0000
@@ -0,0 +0,288 @@
+(provide :lib/scheduler)
+
+(in-package muerte.lib)
+
+(defclass process ()
+ ((name :initform "Anonymous" :initarg :name :accessor process-name)
+ (whostate :initform "Running" :initarg :whostate :accessor process-whostate)
+ (rtc :initarg :rtc :reader process-rtc)
+ (run-reasons :initform (list :run) :initarg :run-reasons :accessor process-run-reasons)
+ (arrest-reasons :initform nil :initarg :arrest-reasons :accessor process-arrest-reasons)
+ (blocked-p :initform nil :accessor process-blocked-p)
+ (wait-function :initform nil :initarg :wait-function :accessor process-wait-function)
+ (wait-argument-list :initform nil :initarg :wait-function-args :accessor process-wait-argument-list)
+ (creation-time :initform 0 :reader process-creation-time)
+ (last-run-time :initform 0 :accessor process-last-run-time)
+ (total-run-time :initform 0 :accessor process-total-run-time)
+ (timer :initform nil :accessor process-timer)
+ (quantum-remaining :initform 100 :initarg :quantum-remaining :accessor process-quantum-remaining)
+ (quantum :initform 100 :initarg :quantum :accessor process-quantum)))
+
+(defvar *all-processes* nil)
+(defvar *idle-process* nil)
+(defvar *ticks* 0)
+(defvar *ticks-per-second* 0)
+
+(defvar *next-timer-event* 0
+ "The tick count that the next time event is scheduled to go off.")
+
+;; FIXME: can we call some powersaving no-op instead?
+(defun idle-process ()
+ (loop))
+
+(defun current-process ()
+ (let ((rtc (current-run-time-context)))
+ (or (find rtc *all-processes* :key 'process-rtc)
+ ;; don't forget the idle process..yuk.
+ (and (eq rtc (process-rtc *idle-process*)) *idle-process*))))
+
+(defun %process-wait-p (process &optional
+ (wf (process-wait-function process))
+ (args (process-wait-argument-list process)))
+ (or (not (process-wait-function process))
+ (apply wf args)))
+
+(defun process-runnable-p (process)
+ ;; no arrest reasons, 1 run reason and its wait function must return
+ ;; T, if it exists.
+ (and
+ (null (process-arrest-reasons process))
+ (not (null (process-run-reasons process)))
+ (not (process-blocked-p process))
+ (%process-wait-p process)))
+
+(defun setup-scheduling ()
+ (setf (exception-handler 32) #'timer-interrupt
+ *all-processes* nil)
+ ;; Set timer 0 frequency to 100Hz (ie. 10ms intervals).
+ (setf (muerte.x86-pc:pit8253-timer-count 0) #xffff ; 11932
+ *ticks-per-second* 100
+ (symbol-function 'sleep)
+ (lambda (seconds)
+ (check-type seconds (real 0 *))
+ (process-block-with-timeout (current-process)
+ (truncate (* *ticks-per-second* seconds))
+ "Sleep")))
+ (let ((idle (make-instance 'process
+ :name "Idle"
+ :rtc (make-instance 'threading:thread :function #'idle-process :args nil)))
+ (repl (make-instance 'process
+ :name "REPL"
+ :rtc (current-run-time-context))))
+ ;; the current rtc needs to be added too. it's the repl.
+ (push repl *all-processes*)
+ (setf *idle-process* idle)
+ (write-line "Scheduling Initialized.")))
+
+;; (defun boink (n)
+;; (let ((map (muerte.x86-pc:vga-memory-map)))
+;; (loop
+;; (loop for i from 0 to 255 do
+;; (setf (memref-int map
+;; :index (+ (* 80 3) 10)
+;; :type :unsigned-byte16)
+;; (logior (ash i 8) i))
+;; (sleep n)))))
+
+(defvar *in-scheduler* nil
+ "Set to T when the scheduler is running.")
+
+(defvar *scheduler-function* 'round-robin-scheduler
+ "What scheduler function should we use?")
+
+(defun %switch-to-process (process)
+ (let ((old (current-process)))
+ (if (eq process old)
+ (without-interrupts
+ (setf *in-scheduler* nil))
+ (progn
+ ;; FIXME: The cli may not actually be needed
+ (muerte::cli)
+ (setf (process-quantum-remaining process) (process-quantum process)
+ (process-wait-function process) nil
+ (process-wait-argument-list process) nil
+ (process-whostate process) "Running"
+ *in-scheduler* nil)
+ (threading:yield (process-rtc process))))))
+
+(defun %wakeup-timer-events ()
+ (dolist (i *all-processes*)
+ (when (and (process-timer i)
+ (<= (process-timer i) *ticks*))
+ (setf (process-timer i) nil
+ (process-blocked-p i) nil))))
+
+(defun %setup-next-timer-event ()
+ (setf *next-timer-event*
+ (loop for i in *all-processes*
+ when (process-timer i)
+ minimize (process-timer i))))
+
+;; TODO: spinning through the lists would be faster if there were
+;; lists of active, blocked, etc processes.
+(defun round-robin-scheduler ()
+ ;; timer events
+ (%wakeup-timer-events)
+ (%setup-next-timer-event)
+ ;; select a new process. The one with the most quantum
+ ;; remaining is picked.
+ (multiple-value-bind (newproc quantum)
+ (loop
+ for i in *all-processes*
+ with proc = nil
+ with max = -1 do
+ (when (and (process-runnable-p i)
+ (> (process-quantum-remaining i) max))
+ (setf proc i
+ max (process-quantum-remaining i)))
+ finally (return (values proc max)))
+ ;; is it time for a fresh a fresh quantum? The idea here is
+ ;; to give priority to io bound processes by giving them a
+ ;; bigger quantum they'll respond better when io comes in.
+ (when (= quantum 0)
+ (dolist (i *all-processes*)
+ (setf (process-quantum-remaining i)
+ (+ (/ (process-quantum-remaining i) 2)
+ (process-quantum i)))))
+ ;; Use the idle process if no other process is runnable
+ (%switch-to-process (or newproc *idle-process*))))
+
+(defun scheduler ()
+ (muerte::cli)
+ (unless *in-scheduler*
+ (setf *in-scheduler* t)
+ (muerte::sti)
+ (funcall (or *scheduler-function*
+ 'round-robin-scheduler))))
+
+(defun timer-interrupt (vector exception-frame)
+ "Some really simple scheduling."
+ (declare (ignore vector exception-frame))
+ (incf *ticks*)
+ (incf (process-total-run-time (current-process)))
+ (decf (process-quantum-remaining (current-process)))
+ (cond ((or (eq (current-process) *idle-process*)
+ (<= (process-quantum-remaining (current-process)) 0))
+ (setf (process-quantum-remaining (current-process)) 0)
+ (muerte.x86-pc:pic8259-end-of-interrupt 0)
+ (scheduler))
+ ((<= *next-timer-event* *ticks*)
+ (muerte.x86-pc:pic8259-end-of-interrupt 0)
+ (scheduler))
+ (t
+ (muerte.x86-pc:pic8259-end-of-interrupt 0))))
+
+(defun process-run-function (name-or-kwds fn &rest args)
+ (let ((newproc (if (listp name-or-kwds)
+ (apply 'make-instance 'process
+ :rtc (make-instance 'threading:thread :function fn :args args)
+ name-or-kwds)
+ (make-instance 'process
+ :rtc (make-instance 'threading:thread :function fn :args args)
+ :name name-or-kwds
+ :run-reasons (list :run)))))
+ (without-interrupts
+ (push newproc *all-processes*))
+ newproc))
+
+(defun process-wait (whostate wf &rest args)
+ (unless (apply wf args)
+ (without-interrupts
+ (setf (process-whostate (current-process)) whostate
+ (process-wait-function (current-process)) wf
+ (process-wait-argument-list (current-process)) args))
+ (scheduler)))
+
+(defun process-wait-with-timeout (whostate time function &rest args)
+ "TIME is in 10ms ticks."
+ (if (null time)
+ (apply 'process-wait whostate function args)
+ (let* ((f #'(lambda ()
+ (let ((val (apply function args)))
+ (when val
+ (process-unblock
+ val))))))
+ (process-wait whostate f))))
+
+(defun process-enable (p)
+ (check-type p process)
+ (without-interrupts
+ (setf (process-run-reasons p) (list :enable)
+ (process-arrest-reasons p) nil
+ (process-whostate p) "Enabled")))
+
+(defun process-disable (p)
+ (check-type p process)
+ (without-interrupts
+ (setf (process-run-reasons p) nil
+ (process-arrest-reasons p) nil
+ (process-whostate p) "Disabled")))
+
+(defun process-enable-run-reason (p &optional (reason :user))
+ (check-type p process)
+ (without-interrupts
+ (pushnew reason (process-run-reasons p)))
+ (when (eq p (current-process))
+ (scheduler)))
+
+(defun process-disable-run-reason (p &optional (reason :user))
+ (check-type p process)
+ (without-interrupts
+ (setf (process-run-reasons p) (remove reason (process-run-reasons p))))
+ (when (eq p (current-process))
+ (scheduler)))
+
+(defun process-enable-arrest-reason (p &optional (reason :user))
+ (check-type p process)
+ (without-interrupts
+ (pushnew reason (process-arrest-reasons p)))
+ (when (eq p (current-process))
+ (scheduler)))
+
+(defun process-disable-arrest-reason (p &optional (reason :user))
+ (check-type p process)
+ (without-interrupts
+ (setf (process-arrest-reasons p) (remove reason (process-arrest-reasons p))))
+ (when (eq p (current-process))
+ (scheduler)))
+
+(defun clear-process-run-time (p)
+ (check-type p process)
+ (setf (process-total-run-time p) 0))
+
+(defun process-kill (p)
+ (check-type p process)
+ (when (eq p *idle-process*)
+ (error "Can't kill idle process"))
+ (without-interrupts
+ (setf *all-processes* (remove p *all-processes*)))
+ (when (eq (current-process) p)
+ (scheduler)))
+
+(defun process-block-with-timeout (p time whostate)
+ (check-type p process)
+ (check-type time (real 0 *))
+ (without-interrupts
+ (let ((timer (and time (+ time *ticks*))))
+ (setf (process-blocked-p p) t
+ (process-timer p) timer
+ (process-whostate p) whostate)
+ ;; update the next timer event.
+ (when (and timer
+ (< timer *next-timer-event*))
+ (setf *next-timer-event* timer))
+ (%setup-next-timer-event)))
+ (when (eq (current-process) p)
+ (scheduler)))
+
+(defun process-block (p whostate)
+ (process-block-with-timeout p nil whostate))
+
+(defun process-unblock (p)
+ (check-type p process)
+ (without-interrupts
+ (setf (process-blocked-p p) nil
+ (process-timer p) nil
+ (process-whostate p) "Unblocked"))
+ (when (eq (current-process) p)
+ (scheduler)))