Skip to content
Snippets Groups Projects
Forked from cmucl / cmucl
7300 commits behind the upstream repository.
multi-proc.lisp 34.42 KiB
;;;
;;; **********************************************************************
;;; 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.3 1997/09/29 05:08:28 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)
	     (:predicate processp)
	     (: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)))

#-pentium
(defun seize-lock (lock)
  (declare (type lock lock))
  (sys:without-interrupts
   (unless (lock-process lock)
     (setf (lock-process lock) *current-process*))))
#-pentium
(defmacro with-lock-held ((lock &optional (whostate "Waiting for lock"))
			  &body body)
  (let ((orig-process (gensym)))
    `(let ((,orig-process (lock-process ,lock)))
      (unwind-protect
	   (progn
	     (unless (or (eq ,orig-process *current-process*)
			 (seize-lock ,lock))
	       (process-wait ,whostate
		     #'(lambda ()
			 (unless (lock-process ,lock)
			   (setf (lock-process ,lock) *current-process*)))))
	     ,@body)
	(unless (or (eq ,orig-process *current-process*)
		    (not (eq (lock-process ,lock) *current-process*)))
	  (setf (lock-process ,lock) nil))))))

;;; Fast locking for the Pentium.
#+pentium
(defmacro with-lock-held ((lock &optional (whostate "Waiting for lock"))
			  &body body)
  (let ((orig-process (gensym)))
    `(let ((,orig-process (lock-process ,lock)))
      (unwind-protect
	   (progn
	     (unless (or (eq ,orig-process *current-process*)
			 (null (kernel:%instance-set-conditional
				,lock 2 nil *current-process*)))
	       (process-wait ,whostate
			     #'(lambda ()
				 (null (kernel:%instance-set-conditional
					,lock 2 nil *current-process*)))))
	     ,@body)
	(unless (eq ,orig-process *current-process*)
	  (kernel:%instance-set-conditional ,lock 2 *current-process* nil))))))