diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..cba54299a2a20446d5e750ad13668ddd5f19575d --- /dev/null +++ b/code/multi-proc.lisp @@ -0,0 +1,929 @@ +;;; +;;; ********************************************************************** +;;; This code was written by Douglas T. Crosher and has been placed in +;;; the Public domain, and is provided 'as is'. +;;; +;;; $Id: multi-proc.lisp,v 1.1 1997/09/24 06:08:14 dtc Exp $ +;;; +;;; ********************************************************************** +;;; +;;; Stack-group and multi-process support for CMUCL x86. +;;; + +(in-package "MULTIPROCESSING") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Handle the binding stack. + +;;; Undo all the bindings in the bind stack, restoring the global +;;; values. +(defun unbind-binding-stack () + (declare (optimize (speed 3) (safety 0))) + (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap)) + (binding-stack + (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned))) + (size (sys:sap- binding-stack-pointer binding-stack))) + (declare (type (unsigned-byte 29) size)) + (do ((binding size)) + ((zerop binding)) + (declare (type (unsigned-byte 29) binding)) + (decf binding 8) + (let* ((value + (kernel:make-lisp-obj + (sys:sap-int (sys:sap-ref-sap binding-stack binding)))) + (symbol + (kernel:make-lisp-obj + (sys:sap-int (sys:sap-ref-sap binding-stack (+ binding 4))))) + (symbol-value (c::%primitive c:fast-symbol-value symbol))) + #+nil + (format t "Undoing: ~s ~s <-> ~s~%" symbol value symbol-value) + (kernel:%set-symbol-value symbol value) + (setf (sys:sap-ref-sap binding-stack binding) + (sys:int-sap (kernel:get-lisp-obj-address symbol-value))))))) + +;;; Re-apply the bindings in a binding stack after an +;;; unbind-binding-stack. +(defun rebind-binding-stack () + (declare (optimize (speed 3) (safety 0))) + (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap)) + (binding-stack + (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned))) + (size (sys:sap- binding-stack-pointer binding-stack))) + (declare (type (unsigned-byte 29) size)) + (do ((binding 0 (+ 8 binding))) + ((= binding size)) + (declare (type (unsigned-byte 29) binding)) + (let* ((value + (kernel:make-lisp-obj + (sys:sap-int (sys:sap-ref-sap binding-stack binding)))) + (symbol + (kernel:make-lisp-obj + (sys:sap-int (sys:sap-ref-sap binding-stack (+ binding 4))))) + (symbol-value (c::%primitive c:fast-symbol-value symbol))) + #+nil + (format t "Rebinding: ~s ~s <-> ~s~%" symbol value symbol-value) + (kernel:%set-symbol-value symbol value) + (setf (sys:sap-ref-sap binding-stack binding) + (sys:int-sap (kernel:get-lisp-obj-address symbol-value))))))) + +(defun save-binding-stack (binding-save-stack) + (declare (type (simple-array t (*)) binding-save-stack) + (optimize (speed 3) (safety 0))) + (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap)) + (binding-stack + (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned))) + (size (sys:sap- binding-stack-pointer binding-stack)) + (vector-size (truncate size 4))) + (declare (type (unsigned-byte 29) size)) + ;; Grow binding-save-stack if necessary. + (when (< (length binding-save-stack) vector-size) + (setq binding-save-stack + (adjust-array binding-save-stack vector-size :element-type t))) + ;; Save the stack. + (do ((binding 0 (+ 4 binding)) + (index 0 (1+ index))) + ((= binding size)) + (declare (type (unsigned-byte 29) binding index)) + (setf (aref binding-save-stack index) + (kernel:make-lisp-obj + (sys:sap-int (sys:sap-ref-sap binding-stack binding))))) + (values binding-save-stack vector-size))) + +(defun restore-binding-stack (new-binding-stack size) + (declare (type (simple-array t (*)) new-binding-stack) + (type (unsigned-byte 29) size) + (optimize (speed 3) (safety 0))) + (let* ((binding-stack-size (* size 4)) + (binding-stack (alien:extern-alien "binding_stack" alien:unsigned))) + (declare (type (unsigned-byte 32) binding-stack-size binding-stack)) + (setf (kernel:binding-stack-pointer-sap) + (sys:int-sap (+ binding-stack binding-stack-size))) + (do ((binding 0 (+ 4 binding)) + (index 0 (1+ index))) + ((= binding binding-stack-size)) + (declare (type (unsigned-byte 29) binding index)) + (setf (sys:sap-ref-sap (sys:int-sap binding-stack) binding) + (sys:int-sap (kernel:get-lisp-obj-address + (aref new-binding-stack index)))))) + (values)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Alien-stack + +;;; The Top of the Alien-stack. +(declaim (type (unsigned-byte 32) *alien-stack-top*)) +(defvar *alien-stack-top* 0) + +;;; Save the alien-stack. +(defun save-alien-stack (save-stack) + (declare (type (simple-array (unsigned-byte 32) (*)) save-stack) + (optimize (speed 3) (safety 0))) + (let* ((alien-stack (kernel:get-lisp-obj-address x86::*alien-stack*)) + (size (- *alien-stack-top* alien-stack)) + (vector-size (ceiling size 4))) + (declare (type (unsigned-byte 32) alien-stack) + (type (unsigned-byte 29) size)) + #+nil + (format t "alien-stack ~x; size ~x~%" alien-stack size) + ;; Grow save-stack if necessary. + (when (< (length save-stack) vector-size) + (setq save-stack + (adjust-array save-stack vector-size + :element-type '(unsigned-byte 32)))) + ;; Save the stack. + (do ((index 0 (1+ index))) + ((>= index vector-size)) + (declare (type (unsigned-byte 29) index)) + (setf (aref save-stack index) + (sys:sap-ref-32 (sys:int-sap *alien-stack-top*) + (* 4 (- (1+ index)))))) + (values save-stack vector-size alien-stack))) + +(defun restore-alien-stack (save-stack size alien-stack) + (declare (type (simple-array (unsigned-byte 32) (*)) save-stack) + (type (unsigned-byte 29) size) + (type (unsigned-byte 32) alien-stack) + (optimize (speed 3) (safety 0))) + (setf x86::*alien-stack* (kernel:make-lisp-obj alien-stack)) + (do ((index 0 (1+ index))) + ((>= index size)) + (declare (type (unsigned-byte 29) index)) + (setf (sys:sap-ref-32 (sys:int-sap *alien-stack-top*) (* 4 (- (1+ index)))) + (aref save-stack index))) + (values)) + +#+nil +(defun tst-alien () + (alien:with-alien ((buf (array char 256))) + (format t "~s~%" buf) + (multiple-value-bind (save-stack size alien-stack) + (save-alien-stack (make-array 0 :element-type '(unsigned-byte 32))) + (restore-alien-stack save-stack size alien-stack)) + (format t "~s~%" buf))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; + +;;; The control stacks need special handling on the x86 as they +;;; contain conservative root. When placed in the *control-stacks* +;;; vector they will be scavenged for conservative roots by the +;;; garbage collector. +(declaim (type (simple-array (or null (simple-array (unsigned-byte 32) (*))) + (*)) x86::*control-stacks*)) +(defvar x86::*control-stacks* + (make-array 0 :element-type '(or null (unsigned-byte 32)) + :initial-element nil)) + +;;; Stack-group stucture. +(defstruct (stack-group + (:constructor %make-stack-group) + (:print-function + (lambda (stack-group stream depth) + (declare (type stack-group stack-group) + (stream stream) + (ignore depth)) + (format stream "#<Stack-group ~a, ~a>" + (stack-group-name stack-group) + (stack-group-state stack-group))))) + ;; Must have a name. + (name "Anonymous" :type simple-base-string) + ;; State: :active or :inactive. + (state :inactive :type (member :active :inactive)) + ;; The control stack; an index into *control-stacks*. + (control-stack-id nil :type (or lisp::index null)) + ;; Binding stack. + (binding-stack nil :type (or (simple-array t (*)) null)) + ;; Twice the number of bindings. + (binding-stack-size 0 :type (unsigned-byte 29)) + ;; Current catch block, on the control stack. + (current-catch-block 0 :type fixnum) + ;; Unwind protect block, on the control stack. + (current-unwind-protect-block 0 :type fixnum) + ;; Alien stack + (alien-stack nil :type (or (simple-array (unsigned-byte 32) (*)) null)) + (alien-stack-size 0 :type (unsigned-byte 29)) + (alien-stack-pointer 0 :type (unsigned-byte 32)) + ;; Eval-stack + (eval-stack nil :type (or (simple-array t (*)) null)) + (eval-stack-top 0 :type fixnum) + ;; Resumer + (resumer nil :type (or stack-group null))) + +;;; The current stack group. +(declaim (type (or stack-group null) *current-stack-group*)) +(defvar *current-stack-group* nil) + +(declaim (type (or stack-group null) *initial-stack-group*)) +(defvar *initial-stack-group* nil) + +;;; Init-Stack-Groups -- Interface +;;; +;;; Setup the initial stack group. +;;; +(defun init-stack-groups () + ;; Grab the top of the alien-stack; it's currently stored at the top + ;; of the control stack. + (setf *alien-stack-top* + (sys:sap-ref-32 + (sys:int-sap (alien:extern-alien "control_stack_end" alien:unsigned)) + -4)) + ;; Initialise the *control-stacks* vector. + (setq x86::*control-stacks* + (make-array 10 :element-type '(or null (unsigned-byte 32)) + :initial-element nil)) + ;; Setup a control-stack for the initial stack-group. + (setf (aref x86::*control-stacks* 0) + (make-array 0 :element-type '(unsigned-byte 32) + :initial-element 0)) + ;; Make and return the initial stack group. + (setf *current-stack-group* + (%make-stack-group + :name "Initial" + :state :active + :control-stack-id 0 + :binding-stack #() + :alien-stack (make-array 0 :element-type '(unsigned-byte 32)) + :eval-stack #())) + (setf *initial-stack-group* *current-stack-group*)) + +;;; Inactivate-Stack-Group -- Internal +;;; +;;; Inactivate the stack group, cleaning its slot and freeing the +;;; control stack. +;;; +(defun inactivate-stack-group (stack-group) + (declare (type stack-group stack-group)) + (setf (stack-group-state stack-group) :inactive) + (let ((cs-id (stack-group-control-stack-id stack-group))) + (when (and cs-id (aref x86::*control-stacks* cs-id)) + (setf (aref x86::*control-stacks* cs-id) nil))) + (setf (stack-group-control-stack-id stack-group) nil) + (setf (stack-group-binding-stack stack-group) nil) + (setf (stack-group-binding-stack-size stack-group) 0) + (setf (stack-group-current-catch-block stack-group) 0) + (setf (stack-group-current-unwind-protect-block stack-group) 0) + (setf (stack-group-alien-stack stack-group) nil) + (setf (stack-group-alien-stack-size stack-group) 0) + (setf (stack-group-alien-stack-pointer stack-group) 0) + (setf (stack-group-eval-stack stack-group) nil) + (setf (stack-group-eval-stack-top stack-group) 0) + (setf (stack-group-resumer stack-group) nil)) + + +;;; Make-Stack-Group -- Interface +;;; +;;; Fork a new stack-group from the *current-stack-group*. Execution +;;; continues with the *current-stack-group* returning the new stack +;;; group. Control may be transfer to the child by resume and it +;;; executes the initial-function. +;;; +(defun make-stack-group (name initial-function &optional + (resumer *current-stack-group*)) + (declare (type simple-base-string name) + (type function initial-function) + (type stack-group resumer)) + (flet ((allocate-control-stack () + (let* (;; Allocate a new control-stack ID. + (control-stack-id (position nil x86::*control-stacks*)) + ;; Find the required stack size. + (control-stack-end + (alien:extern-alien "control_stack_end" alien:unsigned)) + (control-stack-pointer (kernel:control-stack-pointer-sap)) + (control-stack-size + (- control-stack-end (sys:sap-int control-stack-pointer))) + ;; Saved control stack needs three extra words. The + ;; stack pointer will be stored in the first + ;; element, and the frame pointer and return address + ;; push onto the bottom of the stack. + (control-stack + (make-array (+ (ceiling control-stack-size 4) 3) + :element-type '(unsigned-byte 32) + :initial-element 0))) + (declare (type (unsigned-byte 29) control-stack-size)) + (unless control-stack-id + ;; Need to extend the *control-stacks* vector. + (setq control-stack-id (length x86::*control-stacks*)) + (setq x86::*control-stacks* + (adjust-array x86::*control-stacks* + (* 2 (length x86::*control-stacks*)) + :element-type '(or null (unsigned-byte 32)) + :initial-element nil))) + (setf (aref x86::*control-stacks* control-stack-id) control-stack) + (values control-stack control-stack-id))) + (allocate-child-stack-group (control-stack-id) + (sys:without-gcing + ;; Save the binding stack. + (unbind-binding-stack) + (multiple-value-bind (binding-stack binding-stack-size) + (save-binding-stack #()) + (rebind-binding-stack) + ;; Save the Alien stack + (multiple-value-bind (alien-stack alien-stack-size + alien-stack-pointer) + (save-alien-stack + (make-array 0 :element-type '(unsigned-byte 32))) + ;; Allocate a stack-group structure. + (%make-stack-group + :name name + :state :active + :control-stack-id control-stack-id + ;; Save the Eval stack. + :eval-stack (copy-seq (the (simple-array t (*)) + kernel:*eval-stack*)) + :eval-stack-top kernel:*eval-stack-top* + ;; Misc stacks. + :current-catch-block lisp::*current-catch-block* + :current-unwind-protect-block + lisp::*current-unwind-protect-block* + ;; Alien stack. + :alien-stack alien-stack + :alien-stack-size alien-stack-size + :alien-stack-pointer alien-stack-pointer + ;; Binding stack. + :binding-stack binding-stack + :binding-stack-size binding-stack-size + ;; Resumer + :resumer resumer)))))) + (sys:without-interrupts + (multiple-value-bind (control-stack control-stack-id) + (allocate-control-stack) + (let ((child-stack-group + (allocate-child-stack-group control-stack-id))) + ;; Fork the control-stack + (if (x86:control-stack-fork control-stack) + ;; Current-stack-group returns the child-stack-group. + child-stack-group + ;; Child starts. + (unwind-protect + (progn + (setq *current-stack-group* child-stack-group) + (sys:with-interrupts + (funcall initial-function))) + (let ((resumer (stack-group-resumer child-stack-group))) + (inactivate-stack-group child-stack-group) + ;; Verify the resumer. + (unless (and resumer + (eq (stack-group-state resumer) :active)) + (setq resumer *initial-stack-group*)) + ;; Restore the resumer state. + (setq *current-stack-group* resumer) + ;; Eval-stack + (setf kernel:*eval-stack* (stack-group-eval-stack resumer)) + (setf kernel:*eval-stack-top* + (stack-group-eval-stack-top resumer)) + ;; The binding stack. + (sys:without-gcing + (unbind-binding-stack) + (restore-binding-stack + (stack-group-binding-stack resumer) + (stack-group-binding-stack-size resumer)) + (rebind-binding-stack)) + ;; Misc stacks. + (setf lisp::*current-catch-block* + (stack-group-current-catch-block resumer)) + (setf lisp::*current-unwind-protect-block* + (stack-group-current-unwind-protect-block resumer)) + ;; The Alien stack + (restore-alien-stack + (stack-group-alien-stack resumer) + (stack-group-alien-stack-size resumer) + (stack-group-alien-stack-pointer resumer)) + ;; + (let ((new-control-stack + (aref x86::*control-stacks* + (stack-group-control-stack-id resumer)))) + (declare (type (simple-array (unsigned-byte 32) (*)) + new-control-stack)) + (x86:control-stack-return new-control-stack)))))))))) + + +;;; Stack-Group-Resume -- Interface +;;; +;;; Transfer control to the given stack-group, resuming its execution, +;;; and saving the *current-stack-group*. +;;; +(defun stack-group-resume (new-stack-group) + (declare (type stack-group new-stack-group)) + (assert (and (eq (stack-group-state new-stack-group) :active) + (not (eq new-stack-group *current-stack-group*)))) + (sys:without-interrupts + (let* (;; Save the current stack-group on its stack. + (stack-group *current-stack-group*) + ;; Find the required stack size. + (control-stack-end + (alien:extern-alien "control_stack_end" alien:unsigned)) + (control-stack-pointer (kernel:control-stack-pointer-sap)) + (control-stack-size (- control-stack-end + (sys:sap-int control-stack-pointer))) + ;; Stack-save array needs three extra elements. The stack + ;; pointer will be stored in the first, and the frame + ;; pointer and return address push onto the bottom of the + ;; stack. + (save-stack-size (+ (ceiling control-stack-size 4) 3)) + ;; The save-stack vector. + (control-stack (aref x86::*control-stacks* + (stack-group-control-stack-id stack-group)))) + (declare (type (unsigned-byte 29) control-stack-size save-stack-size) + (type (simple-array (unsigned-byte 32) (*)) control-stack)) + ;; Increase the save-stack size if necessary. + (when (> save-stack-size (length control-stack)) + (setf control-stack (adjust-array control-stack save-stack-size + :element-type '(unsigned-byte 32) + :initial-element 0)) + (setf (aref x86::*control-stacks* + (stack-group-control-stack-id stack-group)) + control-stack)) + + ;; Eval-stack + (setf (stack-group-eval-stack stack-group) kernel:*eval-stack*) + (setf (stack-group-eval-stack-top stack-group) kernel:*eval-stack-top*) + (setf kernel:*eval-stack* (stack-group-eval-stack new-stack-group)) + (setf kernel:*eval-stack-top* + (stack-group-eval-stack-top new-stack-group)) + + ;; Misc stacks. + (setf (stack-group-current-catch-block stack-group) + lisp::*current-catch-block*) + (setf (stack-group-current-unwind-protect-block stack-group) + lisp::*current-unwind-protect-block*) + (setf lisp::*current-catch-block* + (stack-group-current-catch-block new-stack-group)) + (setf lisp::*current-unwind-protect-block* + (stack-group-current-unwind-protect-block new-stack-group)) + + (sys:without-gcing + ;; The binding stack. + (unbind-binding-stack) + (multiple-value-bind (stack size) + (save-binding-stack (stack-group-binding-stack stack-group)) + (setf (stack-group-binding-stack stack-group) stack) + (setf (stack-group-binding-stack-size stack-group) size)) + (restore-binding-stack (stack-group-binding-stack new-stack-group) + (stack-group-binding-stack-size new-stack-group)) + (rebind-binding-stack)) + + ;; The Alien stack + (multiple-value-bind (save-stack size alien-stack) + (save-alien-stack (stack-group-alien-stack stack-group)) + (setf (stack-group-alien-stack stack-group) save-stack) + (setf (stack-group-alien-stack-size stack-group) size) + (setf (stack-group-alien-stack-pointer stack-group) alien-stack)) + (restore-alien-stack (stack-group-alien-stack new-stack-group) + (stack-group-alien-stack-size new-stack-group) + (stack-group-alien-stack-pointer new-stack-group)) + ;; + (let ((new-control-stack + (aref x86::*control-stacks* + (stack-group-control-stack-id new-stack-group)))) + (declare (type (simple-array (unsigned-byte 32) (*)) + new-control-stack)) + (x86:control-stack-resume control-stack new-control-stack)) + ;; Thread returns. + (setq *current-stack-group* stack-group)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Multi-process support. The interface is based roughly on the +;;;; CLIM-SYS spec. and support needed for cl-http. + +(defvar *multi-processing* t) + +(defstruct (process + (:constructor %make-process) + (:print-function + (lambda (process stream depth) + (declare (type process process) + (stream stream) + (ignore depth)) + (format stream "#<Process ~a>" (process-name process))))) + (name "Anonymous" :type simple-base-string) + (state :killed :type (member :killed :active :inactive)) + (%whostate nil :type (or null simple-base-string)) + (initial-function nil :type (or null function)) + (initial-args nil :type list) + (wait-function nil :type (or null function)) + (wait-timeout nil :type (or null fixnum)) + (wait-return-value nil :type t) + (interrupts '() :type list) + (stack-group nil :type (or null stack-group))) + +(defun process-whostate (process) + (cond ((eq (process-state process) :killed) + "Killed") + ((process-wait-function process) + (or (process-%whostate process) "Run")) + (t + "Run"))) + +(declaim (inline process-active-p)) +(defun process-active-p (process) + (eq (process-state process) :active)) + +(declaim (inline process-alive-p)) +(defun process-alive-p (process) + (let ((state (process-state process))) + (or (eq state :active) (eq state :inactive)))) + +(declaim (type (or null process) *current-process*)) +(defvar *current-process* nil) + +(declaim (inline current-process)) +(defun current-process () + "Returns the current process." + *current-process*) + +(declaim (list *all-processes*)) +(defvar *all-processes* nil + "A list of all alive processes.") + +(declaim (inline all-processes)) +(defun all-processes () + "Return a list of all the live processes." + *all-processes*) + +(defun show-processes () + (dolist (process *all-processes*) + (format t "~s ~s ~a~%" process (process-whostate process) + (process-state process)))) + +(declaim (type (or null process) *intial-process*)) +(defvar *initial-process* nil) + +(defvar *inhibit-scheduling* t) + +(defmacro without-scheduling (&body body) + `(let ((inhibit *inhibit-scheduling*)) + (unwind-protect + (progn + (setf *inhibit-scheduling* t) + ,@body) + (setf *inhibit-scheduling* inhibit)))) + +(defmacro atomic-incf (reference &optional (delta 1)) + "Increaments the reference by delta in a single atomic operation" + `(without-scheduling + (incf ,reference ,delta))) + +(defmacro atomic-decf (reference &optional (delta 1)) + "Decrements the reference by delta in a single atomic operation" + `(without-scheduling + (decf ,reference ,delta))) + +(defmacro atomic-push (obj place) + `(without-scheduling + (push ,obj ,place))) + +(defmacro atomic-pop (place) + `(without-scheduling + (pop ,place))) + + +;;; Make-process +;;; +(defun make-process (function &key (name "Anonymous")) + (declare (type (or null function) function)) + (cond ((null function) + ;; If function is nil then create a dead process; can be + ;; restarted with process-preset. + (%make-process :initial-function nil :name name :state :killed)) + (t + ;; Create a stack-group. + (let ((process + (%make-process + :name name + :state :active + :initial-function function + :stack-group + (make-stack-group + name + #'(lambda () + (unwind-protect + (progn + (setf *inhibit-scheduling* nil) + (funcall function)) + (setf *inhibit-scheduling* t) + ;; About to return to the resumer's + ;; stack-group, which in this case is the + ;; initial process's stack-group. + (setf (process-state *current-process*) :killed) + (setf *all-processes* + (delete *current-process* *all-processes*)) + (setf (process-%whostate *current-process*) nil) + (setf (process-wait-function *current-process*) nil) + (setf (process-wait-timeout *current-process*) nil) + (setf (process-wait-return-value *current-process*) + nil) + (setf (process-interrupts *current-process*) nil) + (setf *current-process* *initial-process*))) + *initial-stack-group*)))) + (push process *all-processes*) + process)))) + +(defun process-interrupt (process function) + "Interrupt process ard cause it to evaluate function." + ;; Place the interrupt function at the end of process's interrupts + ;; queue, to be called the next time the process is scheduled. + (without-scheduling + (setf (process-interrupts process) + (append (list function) (process-interrupts process)))) + (process-yield)) + +(defun destroy-process (process) + (declare (type process process)) + (assert (not (eq process *current-process*))) + (unless (eq (process-state process) :killed) + ;; Place the a throw to end-of-the-world at the start of process's + ;; interrupts queue, to be called the next time the process is + ;; scheduled. + (without-scheduling + (push #'(lambda () + (throw 'lisp::%end-of-the-world 0)) + (process-interrupts process))) + ;; Should we wait until it's dead? + (process-yield))) + +(defun restart-process (process) + "Restart process by unwinding it to its initial state and calling its + initial function." + (destroy-process process) + (process-wait "Waiting for process to die" + #'(lambda () + (eq (process-state process) :killed))) + ;; Create a new stack-group. + (setf (process-stack-group process) + (make-stack-group + (process-name process) + #'(lambda () + (unwind-protect + (progn + (setf *inhibit-scheduling* nil) + (apply (process-initial-function process) + (process-initial-args process))) + (setf *inhibit-scheduling* t) + ;; About to return to the resumer's stack-group, which + ;; in this case is the initial process's stack-group. + (setf (process-state *current-process*) :killed) + (setf *all-processes* + (delete *current-process* *all-processes*)) + (setf (process-%whostate *current-process*) nil) + (setf (process-wait-function *current-process*) nil) + (setf (process-wait-timeout *current-process*) nil) + (setf (process-wait-return-value *current-process*) nil) + (setf (process-interrupts *current-process*) nil) + (setf *current-process* *initial-process*))) + *initial-stack-group*)) + (setf (process-%whostate process) nil) + (setf (process-wait-function process) nil) + (setf (process-wait-timeout process) nil) + (setf (process-wait-return-value process) nil) + (setf (process-interrupts process) nil) + (setf (process-state process) :active) + (push process *all-processes*) + process) + +(defun process-preset (process function &rest args) + "Restart process, unwinding it to its initial state and call + function with args." + (setf (process-initial-function process) function) + (setf (process-initial-args process) args) + (restart-process process)) + +(declaim (inline disable-processes)) +(defun disable-process (process) + "Disable process from being runnable until enabled." + (setf (process-state process) :inactive)) + +(declaim (inline enable-processes)) +(defun enable-process (process) + "Allow process to become runnable again after it has been disabled." + (setf (process-state process) :active)) + +(defun process-wait (whostate predicate) + "Causes the process to wait until predicate returns True." + (assert (not *inhibit-scheduling*)) + (assert (not (process-wait-function *current-process*))) + (setf (process-%whostate *current-process*) whostate) + (setf (process-wait-timeout *current-process*) nil) + (setf (process-wait-function *current-process*) predicate) + (process-yield) + (process-wait-return-value *current-process*)) + +(defun process-wait-with-timeout (whostate timeout predicate) + (declare (type (unsigned-byte 29) timeout)) + "Causes the process to wait until predicate returns True, or the + number of seconds specified by timeout has elapsed." + (assert (not *inhibit-scheduling*)) + (assert (not (process-wait-function *current-process*))) + (let ((timeout (+ (get-internal-real-time) + (* timeout internal-time-units-per-second)))) + (declare (fixnum timeout)) + (setf (process-%whostate *current-process*) whostate) + (setf (process-wait-timeout *current-process*) timeout) + (setf (process-wait-function *current-process*) predicate) + (process-yield) + (process-wait-return-value *current-process*))) + +;;; The remaining processes in the scheduling queue for this cycle, +;;; the remainder of *all-processes*. The *current-process* is the +;;; first element of this list. +(defvar *remaining-processes* nil) + +;;; Scheduler. +(defun process-yield () + "Allow other processes to run." + (unless *inhibit-scheduling* + ;; Catch any FP exceptions before entering the scheduler. + (kernel:float-wait) + ;; Inhibit recursive entry of the scheduler. + (setf *inhibit-scheduling* t) + (assert (eq (first *remaining-processes*) *current-process*)) + (loop + ;; Rotate the queue. + (setf *remaining-processes* + (or (rest *remaining-processes*) *all-processes*)) + + (let ((next (first *remaining-processes*))) + ;; Shouldn't see any :killed porcesses here. + (assert (process-alive-p next)) + + ;; New process at the head of the queue? + (unless (eq next *current-process*) + (cond + ;; If the next process has pending interrupts then return + ;; to it to execute these. + ((process-interrupts next) + (setf *current-process* next) + (stack-group-resume (process-stack-group next))) + (t + ;; If not waiting then return. + (let ((wait-fn (process-wait-function next))) + (cond + ((null wait-fn) + (setf *current-process* next) + (stack-group-resume (process-stack-group next))) + (t + ;; Check the wait function in the current context + ;; saving a stack-group switch; although + ;; *current-process* is setup. + (let ((current-process *current-process*)) + (setf *current-process* next) + ;; Predicate true? + (let ((wait-return-value (funcall wait-fn))) + (cond (wait-return-value + ;; Flush the wait. + (setf (process-wait-return-value next) + wait-return-value) + (setf (process-wait-timeout next) nil) + (setf (process-wait-function next) nil) + (setf (process-%whostate next) nil) + (stack-group-resume (process-stack-group next))) + (t + ;; Timeout? + (let ((timeout (process-wait-timeout next))) + (when (and timeout + (> (the fixnum + (get-internal-real-time)) + timeout)) + ;; Flush the wait. + (setf (process-wait-return-value next) nil) + (setf (process-wait-timeout next) nil) + (setf (process-wait-function next) nil) + (setf (process-%whostate next) nil) + (stack-group-resume + (process-stack-group next))))))) + ;; Restore the *current-process*. + (setf *current-process* current-process))))))))) + + ;; May have just returned, or have cycled the queue. + (let ((next (first *remaining-processes*))) + ;; Tolerate :killed processes on the *remaining-processes* list + ;; saving their deletion from this list when killed; will be + ;; corrected when it cycle back to *all-processes*. + (when (and (process-alive-p next) + ;; Current process at the head of the queue? + (eq next *current-process*)) + ;; Run any pending interrupts. + (let ((interrupt (pop (process-interrupts next)))) + (declare (type (or null function) interrupt)) + (cond (interrupt + ;; Save and reset any wait reasons so that the + ;; interrupt can wait. + (let ((wait-function (process-wait-function next)) + (wait-timeout (process-wait-timeout next)) + (whostate (process-%whostate next))) + (setf (process-wait-function next) nil) + (setf (process-wait-timeout next) nil) + (setf (process-%whostate next) nil) + ;; Allow recursive scheduling during the interrupt + ;; processing. Only one interrupt is processed on + ;; each scheduler queue cycle. The process doesn't + ;; return until there are no interrupts. + (setf *inhibit-scheduling* nil) + (funcall interrupt) + (setf *inhibit-scheduling* t) + ;; Restore any wait reasons. + (setf (process-wait-function next) wait-function) + (setf (process-wait-timeout next) wait-timeout) + (setf (process-%whostate next) whostate))) + (t + ;; Check the wait function. + (let ((wait-fn (process-wait-function next))) + (cond + ((null wait-fn) + (return)) + (t + ;; Predicate true? + (let ((return-value (funcall wait-fn))) + (when return-value + ;; Flush the wait. + (setf (process-wait-return-value next) return-value) + (setf (process-wait-timeout next) nil) + (setf (process-wait-function next) nil) + (setf (process-%whostate next) nil) + (return))) + ;; Timeout? + (let ((timeout (process-wait-timeout next))) + (when (and timeout + (> (the fixnum (get-internal-real-time)) + timeout)) + ;; Flush the wait. + (setf (process-wait-return-value next) nil) + (setf (process-wait-timeout next) nil) + (setf (process-wait-function next) nil) + (setf (process-%whostate next) nil) + (return)))))))))))) + (setf *inhibit-scheduling* nil))) + +;;; Start a regular interrupt to switch processes. This may not be a +;;; good idea yet on the X86 port which isn't too interrupt safe. +(defun start-sigalrm-yield (&optional (sec 0) (usec 500000)) + (declare (fixnum sec usec)) + ;; Disable the gencgc pointer filter to improve interrupt safety. + #+gencgc + (setf (alien:extern-alien "enable_pointer_filter" alien:unsigned) 0) + (flet ((sigalrm-handler (signal code scp) + (declare (ignore signal code scp)) + (process-yield))) + (sys:enable-interrupt :sigalrm #'sigalrm-handler) + (unix:unix-setitimer :real sec usec 0 1) + (values))) + +;;; Initialise the initial process, must be called before use of the +;;; other multi-process function. +(defun init-processes () + (unless *initial-process* + (init-stack-groups) + (setf *initial-process* + (%make-process + :name "Initial" + :state :active + :stack-group *initial-stack-group*)) + (setf *current-process* *initial-process*) + (setf *all-processes* (list *initial-process*)) + (setf *remaining-processes* *all-processes*) + #+nil (start-sigalrm-yield) + (setf *inhibit-scheduling* nil)) + (values)) + +(pushnew 'init-processes ext:*after-save-initializations*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Simple Locking. + +(defstruct (lock + (:constructor make-lock (&optional name)) + (:print-function + (lambda (lock stream depth) + (declare (type lock lock) + (stream stream) + (ignore depth)) + (format stream "#<Lock ~a>" (lock-name lock))))) + (name nil) + (process nil :type (or null process))) + +;;; Try to seize a lock for the current process, installing the +;;; current process in the lock's process slot on success. +;;; +;;; This currently use without-interrupts but could be implement as a +;;; fast atomic VOP. +;;; +(defun seize-lock (lock) + (sys:without-interrupts + (when (null (lock-process lock)) + (setf (lock-process lock) *current-process*)) + (values))) + +;;; Only waits if it can't seize the lock. +(defmacro with-lock-held ((lock &optional (whostate "Waiting for lock")) + &body body) + `(unwind-protect + (progn + (seize-lock ,lock) + (unless (eq (lock-process ,lock) *current-process*) + (process-wait ,whostate + #'(lambda () + (if (or (eq (lock-process ,lock) *current-process*) + (null (lock-process ,lock))) + (setf (lock-process ,lock) *current-process*))))) + ,@body) + (when (eq (lock-process ,lock) *current-process*) + (setf (lock-process ,lock) nil))))