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