;;; -*- Mode: Lisp; Package: Multiprocessing -*-

;;;
;;; **********************************************************************
;;; This code was written by Douglas T. Crosher and has been placed in
;;; the Public domain, and is provided 'as is'.
;;;

(ext:file-comment

  "$Header: src/code/multi-proc.lisp $")

;;;
;;; **********************************************************************
;;;
;;; Stack-group and multi-process support for CMUCL x86.
;;;

(in-package "MULTIPROCESSING")

(intl:textdomain "cmucl-mp")

(sys:register-lisp-runtime-feature :mp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 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))))))
	(cond ((symbolp symbol)
	       (let ((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)))))
	      (t
	       #+nil
	       (format t "Ignoring undoing: ~s ~s~%" 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))))))
	(cond ((symbolp symbol)
	       (let ((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)))))
	      (t
	       #+nil
	       (format t "Ignoring rebinding: ~s ~s~%" 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))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Interrupt contexts.

;;; Save the interrupt contexts.
(defun save-interrupt-contexts (save-vector)
  (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
	   (optimize (speed 3) (safety 0)))
  (let* ((size lisp::*free-interrupt-context-index*))
    (declare (type (unsigned-byte 29) size))
    ;; Grow save-stack if necessary.
    (when (< (length save-vector) size)
      (setq save-vector
	    (adjust-array save-vector size :element-type '(unsigned-byte 32))))
    (alien:with-alien
	((lisp-interrupt-contexts (array alien:unsigned nil) :extern))
      (dotimes (index size)
	(setf (aref save-vector index)
	      (alien:deref lisp-interrupt-contexts index))))
    save-vector))

;;; Restore the interrupt contexts.
(defun restore-interrupt-contexts (save-vector)
  (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
	   (optimize (speed 3) (safety 0)))
  (let* ((size lisp::*free-interrupt-context-index*))
    (declare (type (unsigned-byte 29) size))
    (alien:with-alien
	((lisp-interrupt-contexts (array alien:unsigned nil) :extern))
      (dotimes (index size)
	(setf (alien:deref lisp-interrupt-contexts index)
	      (aref save-vector index)))))
  (values))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;

;;; The control stacks need special handling on the x86 as they

;;; contain conservative roots. 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 structure.

(defstruct (stack-group
	     (:constructor %make-stack-group)
	     (:print-function
	      (lambda (stack-group stream depth)
		(declare (type stack-group stack-group)
			 (stream stream)
			 (ignore depth))

		(print-unreadable-object (stack-group stream :identity t)
		 (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 kernel: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)

  ;;
  ;; Interrupt contexts
  (interrupt-contexts nil :type (or (simple-array (unsigned-byte 32) (*))
				    null))

  ;; 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)

;;; Process defstruct is up here because stack group functions refer
;;; to process slots in assertions, but are also compiled at high
;;; optimization... so if the process structure changes, all hell
;;; could break loose.

(defstruct (process
	     (:constructor %make-process)
	     (:predicate processp)
	     (:print-function
	      (lambda (process stream depth)
		(declare (type process process) (stream stream) (ignore depth))
		(print-unreadable-object (process stream :identity t)
		 (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-function-args nil :type list)
  (%run-reasons nil :type list)
  (%arrest-reasons nil :type list)
  ;; The real time after which the wait will timeout.
  (wait-timeout nil :type (or null double-float))
  (wait-return-value nil :type t)
  (interrupts '() :type list)
  (stack-group nil :type (or null stack-group))
  ;;
  ;; The real and run times when the current process was last
  ;; scheduled or yielded.
  (scheduled-real-time (get-real-time) :type double-float)
  (scheduled-run-time (get-run-time) :type double-float)
  ;;
  ;; Accrued real and run times in seconds.
  (%real-time 0d0 :type double-float)
  (%run-time 0d0 :type double-float)
  (property-list nil :type list)
  (initial-bindings nil :type list))

;;; 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))

	 :interrupt-contexts (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))

;;; Scrub-Stack-Group-Stacks -- Internal
;;;
;;; Scrub the binding and eval stack of the give stack-group.
;;;
(defun scrub-stack-group-stacks (stack-group)
  (declare (type stack-group stack-group)
	   (optimize (speed 3) (safety 0)))
  ;; Binding stack.
  (let ((binding-save-stack (stack-group-binding-stack stack-group)))
    (when binding-save-stack

      (let ((size
	     ;; The stored binding stack for the current stack group
	     ;; can be completely scrubbed.
	     (if (eq stack-group *current-stack-group*)
		 0
		 (stack-group-binding-stack-size stack-group)))

	    (len (length binding-save-stack)))
	;; Scrub the remainder of the binding stack.
	(do ((index size (+ index 1)))
	    ((>= index len))
	  (declare (type (unsigned-byte 29) index))
	  (setf (aref binding-save-stack index) 0)))))

  ;; If this is the current stack group then update the stored
  ;; eval-stack and eval-stack-top before scrubbing.
  (when (eq stack-group *current-stack-group*)
    ;; Updare the stored vector, flushing an old vector if a new one
    ;; has been allocated.
    (setf (stack-group-eval-stack stack-group) lisp::*eval-stack*)
    ;; Ensure that the stack-top is valid.
    (setf (stack-group-eval-stack-top stack-group) lisp::*eval-stack-top*))

  ;; Scrub the eval stack.
  (let ((eval-stack (stack-group-eval-stack stack-group)))
    (when eval-stack
      (let ((eval-stack-top (stack-group-eval-stack-top stack-group))
	    (len (length eval-stack)))
	(do ((i eval-stack-top (1+ i)))
	    ((= i len))
	  (declare (type kernel:index i))
	  (setf (svref eval-stack i) nil))))))

;;; Initial-binding-stack  --  Internal
;;;
;;; Generate the initial bindings for a newly created stack-group.
;;; This function may be redefined to return a vector with other bindings
;;; but *interrupts-enabled* and *gc-inhibit* must be the last two.
;;;
(defun initial-binding-stack ()
  (vector
   (find-package "COMMON-LISP-USER") '*package*
   ;; Other bindings may be added here.
   nil 'unix::*interrupts-enabled*
   t 'lisp::*gc-inhibit*))

;;; 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 stack-group-resume
;;; and it executes the initial-function.

;;;
(defun make-stack-group (name initial-function &optional

			      (resumer *current-stack-group*)
			      (inherit t))

  (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 a stack group inheriting stacks and bindings from
	 ;; the current stack group.

	 (allocate-child-stack-group (control-stack-id)

	   ;; Save the interrupt-contexts while the size is still
	   ;; bound.
	   (let ((interrupt-contexts
		  (save-interrupt-contexts
		   (make-array 0 :element-type '(unsigned-byte 32)))))

	     ;; Save the binding stack.  Note that
	     ;; *interrutps-enabled* could be briefly set during the
	     ;; unbinding and re-binding process so signals are
	     ;; blocked.
	     (let ((old-sigs (unix:unix-sigblock
			      (unix:sigmask :sigint :sigalrm))))
	       (declare (type (unsigned-byte 32) old-sigs))
	       (unbind-binding-stack)
	       (multiple-value-bind (binding-stack binding-stack-size)
		   (save-binding-stack #())
		 (rebind-binding-stack)
		 (unix:unix-sigsetmask old-sigs)
		 ;; 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-vector

					       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
		    ;; Interrupt contexts
		    :interrupt-contexts interrupt-contexts
		    ;; Binding stack.
		    :binding-stack binding-stack
		    :binding-stack-size binding-stack-size
		    ;; Resumer
		    :resumer resumer))))))
	 ;; Allocate a new stack group with fresh stacks and bindings.
	 (allocate-new-stack-group (control-stack-id)

	   (let ((binding-stack (initial-binding-stack)))
	     ;; Allocate a stack-group structure.
	     (%make-stack-group
	      :name name
	      :state :active
	      :control-stack-id control-stack-id
	      ;; Eval stack. Needs at least one element be because
	      ;; push doubles the size when full.
	      :eval-stack (make-array 32)
	      :eval-stack-top 0
	      ;; Misc stacks.
	      :current-catch-block 0
	      :current-unwind-protect-block 0
	      ;; Alien stack.
	      :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
	      :alien-stack-size 0
	      :alien-stack-pointer *alien-stack-top*
	      ;; Interrupt contexts
	      :interrupt-contexts (make-array 0 :element-type
					      '(unsigned-byte 32))
	      ;; Binding stack - some initial bindings.
	      :binding-stack binding-stack
	      :binding-stack-size (length binding-stack)
	      ;; Resumer
	      :resumer resumer))))

    (let ((child-stack-group nil))
      (let ((unix::*interrupts-enabled* nil)
	    (lisp::*gc-inhibit* t))
	(multiple-value-bind (control-stack control-stack-id)
	    (allocate-control-stack)
	  (setq child-stack-group

		(if inherit
		    (allocate-child-stack-group control-stack-id)
		    (allocate-new-stack-group control-stack-id)))

	  ;; Fork the control-stack

	  (if (x86:control-stack-fork control-stack inherit)

	      ;; Current-stack-group returns the child-stack-group.
	      child-stack-group
	      ;; Child starts.
	      (unwind-protect
		   (progn
		     (setq *current-stack-group* child-stack-group)

		     (assert (eq *current-stack-group*
				 (process-stack-group *current-process*)))

		     ;; Enable interrupts and GC.
		     (setf unix::*interrupts-enabled* t)
		     (setf lisp::*gc-inhibit* nil)
		     (when unix::*interrupt-pending*
		       (unix::do-pending-interrupt))
		     (when lisp::*need-to-collect-garbage*
		       (lisp::maybe-gc))
		     (funcall initial-function))

		(let ((resumer (stack-group-resumer child-stack-group)))

		  ;; Disable interrupts and GC.
		  (setf unix::*interrupts-enabled* nil)
		  (setf lisp::*gc-inhibit* t)

		  (inactivate-stack-group child-stack-group)
		  ;; Verify the resumer.
		  (unless (and resumer
			       (eq (stack-group-state resumer) :active))

		    (format t "*Resuming stack-group ~s instead of ~s~%"
			    *initial-stack-group* resumer)

		    (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.  Note that
		  ;; *interrutps-enabled* could be briefly set during
		  ;; the unbinding and re-binding process so signals
		  ;; are blocked.
		  (let ((old-sigs (unix:unix-sigblock
				   (unix:sigmask :sigint :sigalrm))))
		    (declare (type (unsigned-byte 32) old-sigs))
		    (unbind-binding-stack)
		    (restore-binding-stack
		     (stack-group-binding-stack resumer)
		     (stack-group-binding-stack-size resumer))
		    (rebind-binding-stack)
		    (unix:unix-sigsetmask old-sigs))

		  ;; 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))

		  ;; Interrupt-contexts.
		  (restore-interrupt-contexts
		   (stack-group-interrupt-contexts 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)))))))
      (when (and unix::*interrupts-enabled* unix::*interrupt-pending*)
	(unix::do-pending-interrupt))
      (when (and lisp::*need-to-collect-garbage* (not lisp::*gc-inhibit*))
	(lisp::maybe-gc))
      child-stack-group)))

;;; 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)
	   (optimize (speed 3)))

  (assert (and (eq (stack-group-state new-stack-group) :active)
	       (not (eq new-stack-group *current-stack-group*))))

  (assert (eq new-stack-group (process-stack-group *current-process*)))

  (let ((unix::*interrupts-enabled* nil)
	(lisp::*gc-inhibit* t))
    (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))
      

      ;; Save the interrupt-contexts.
      (setf (stack-group-interrupt-contexts stack-group)
	    (save-interrupt-contexts
	     (stack-group-interrupt-contexts stack-group)))

      ;; The binding stack.  Note that *interrutps-enabled* could be
      ;; briefly set during the unbinding and re-binding process so
      ;; signals are blocked.
      (let ((old-sigs (unix:unix-sigblock (unix:sigmask :sigint :sigalrm))))
	(declare (type (unsigned-byte 32) old-sigs))
	(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)
	(unix:unix-sigsetmask old-sigs))

      ;; Restore the interrupt-contexts.
      (restore-interrupt-contexts
       (stack-group-interrupt-contexts new-stack-group))

      ;; 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)))

  (assert (eq *current-stack-group* (process-stack-group *current-process*)))

  (when (and unix::*interrupts-enabled* unix::*interrupt-pending*)
    (unix::do-pending-interrupt))
  (when (and lisp::*need-to-collect-garbage* (not lisp::*gc-inhibit*))
    (lisp::maybe-gc))
  (values))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Double-float timing functions for use by the scheduler.

;;; These timer functions use double-floats for accuracy. In most

;;; cases consing is avoided.

;;; Get-Real-Time
;;;
(declaim (inline get-real-time))
;;;
(defun get-real-time ()

  "Return the real time in seconds."

  (declare (optimize (speed 3) (safety 0)))
  (multiple-value-bind (ignore seconds useconds)
      (unix:unix-gettimeofday)
    (declare (ignore ignore)
	     (type (unsigned-byte 32) seconds useconds))
    (+ (coerce seconds 'double-float)
       (* (coerce useconds 'double-float) 1d-6))))

;;; Get-Run-Time
;;;
(declaim (inline get-run-time))
;;;
(defun get-run-time ()

  "Return the run time in seconds"

  (declare (optimize (speed 3) (safety 0)))
  (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
      (unix:unix-fast-getrusage unix:rusage_self)
    (declare (ignore ignore)
	     (type (unsigned-byte 31) utime-sec stime-sec)
	     (type (mod 1000000) utime-usec stime-usec))
    (+ (coerce utime-sec 'double-float) (coerce stime-sec 'double-float)
       (* (+ (coerce utime-usec 'double-float)
	     (coerce stime-usec 'double-float))
	  1d-6))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Multi-process support. The interface is based roughly on the
;;;; CLIM-SYS spec. and support needed for cl-http.

(defvar *multi-processing* t)

;;; Process-Whostate  --  Public
;;;

(defun process-whostate (process)

  "Return the process state which is either Run, Killed, or a wait reason."

  (cond ((eq (process-state process) :killed)
	 "Killed")
	((process-wait-function process)
	 (or (process-%whostate process) "Run"))
	(t
	 "Run")))

;;; Process-Active-P  --  Public
;;;

(declaim (inline process-active-p))
(defun process-active-p (process)

  (and (eq (process-state process) :active)
       (process-%run-reasons process)
       (not (process-%arrest-reasons process))))

;;; Process-Alive-P  --  Public
;;;

(declaim (inline process-alive-p))
(defun process-alive-p (process)
  (let ((state (process-state process)))
    (or (eq state :active) (eq state :inactive))))

;;; A dummy initial process is defined so that locks will work before
;;; multi-processing has been started.
(declaim (type process *current-process*))
(defvar *current-process*
  (%make-process :name "Startup" :state :inactive :stack-group nil))

;;; Current-Process  --  Public
;;;

(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.")

;;; All-Processes  --  Public
;;;

(declaim (inline all-processes))
(defun all-processes ()

  "Return a list of all the live processes."

  *all-processes*)

(declaim (type (or null process) *initial-process*))

(defvar *initial-process* nil)

;;; Without-scheduling  --  Public
;;;
;;; Disable scheduling while the body is executed. Scheduling is
;;; typically inhibited when process state is being modified.
;;;

(defvar *inhibit-scheduling* t)

;;;

(defmacro without-scheduling (&body body)

  "Execute the body the scheduling disabled."

  `(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)

  "Atomically push object onto place."

  `(without-scheduling
    (push ,obj ,place)))

(defmacro atomic-pop (place)

  "Atomically pop place."

  `(without-scheduling
    (pop ,place)))

;;; If a process other than the initial process throws to the
;;; %end-of-the-world then *quitting-lisp* is set to the exit value,
;;; after which further process creation blocks. If the initial
;;; process is running the idle loop then it will perform the exit
;;; when it runs.
;;;
(defvar *quitting-lisp* nil)

;;; Update-Process-Timers -- Internal
;;;
;;; Update the processes times for the current and new process before
;;; a process switch.
;;;
(defun update-process-timers (current-process new-process)
  (declare (type process current-process new-process)
	   (optimize (speed 3) (safety 0)))
  (let ((real-time (get-real-time)))
    (incf (process-%real-time current-process)
	  (- real-time (process-scheduled-real-time current-process)))
    (setf (process-scheduled-real-time current-process) real-time)
    (setf (process-scheduled-real-time new-process) real-time))
  (let ((run-time (get-run-time)))
    (incf (process-%run-time current-process)
	  (- run-time (process-scheduled-run-time current-process)))
    (setf (process-scheduled-run-time current-process) run-time)
    (setf (process-scheduled-run-time new-process) run-time))
  (values))

(defun apply-with-bindings (function args bindings)
  (if bindings
      (progv
	  (mapcar #'car bindings)
	  (mapcar #'(lambda (binding)

		      (eval (cdr binding)))
		  bindings)

	(apply function args))
      (apply function args)))

;;; Make-Process -- Public

;;;

(defun make-process (function &key
		     (name "Anonymous")
		     (run-reasons (list :enable))
		     (arrest-reasons nil)
		     (initial-bindings nil))

  "Make a process which will run FUNCTION when it starts up.  By

  default the process is created in a runnable (active) state.
  If FUNCTION is NIL, the process is started in a killed state; it may
  be restarted later with process-preset.

  :NAME
	A name for the process displayed in process listings.

  :RUN-REASONS
	Initial value for process-run-reasons; defaults to (:ENABLE).  A
	process needs a at least one run reason to be runnable.  Together with
	arrest reasons, run reasons provide an alternative to process-wait for
	controling whether or not a process is runnable.  To get the default
	behavior of MAKE-PROCESS in Allegro Common Lisp, which is to create a
	process which is active but not runnable, initialize RUN-REASONS to
	NIL.

  :ARREST-REASONS
	Initial value for process-arrest-reasons; defaults to NIL.  A
	process must have no arrest reasons in order to be runnable.

  :INITIAL-BINDINGS
	An alist of initial special bindings for the process.  At
	startup the new process has a fresh set of special bindings
	with a default binding of *package* setup to the CL-USER
	package.  INITIAL-BINDINGS specifies additional bindings for
	the process.  The cdr of each alist element is evaluated in
	the fresh dynamic environment and then bound to the car of the
	element."

  (declare (type (or null function) function))

  (cond (*quitting-lisp*
	 ;; No more processes if about to quit lisp.
	 (process-wait "Quitting Lisp" #'(lambda () nil)))
	((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
			:%run-reasons run-reasons
			:%arrest-reasons arrest-reasons
			:initial-bindings initial-bindings))

	(t
	 ;; Create a stack-group.
	 (let ((process
		(%make-process
		 :name name

		 :state :active 

		 :initial-function function

		 :%run-reasons run-reasons
		 :%arrest-reasons arrest-reasons
		 :initial-bindings initial-bindings

		 :stack-group
		 (make-stack-group
		  name 
		  #'(lambda ()
		      (unwind-protect