+++ /dev/null
-;;;; stack-group and multi-process support for CMU CL x86
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!MP")
-
-(file-comment
- "$Header$")
-\f
-;;;; 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 (sb!kernel:binding-stack-pointer-sap))
- (binding-stack
- (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
- sb!alien:unsigned)))
- (size (sb!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
- (sb!kernel:make-lisp-obj
- (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
- (symbol
- (sb!kernel:make-lisp-obj
- (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
- (+ binding 4))))))
- (cond ((symbolp symbol)
- (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
- symbol)))
- #+nil
- (format t "undoing: ~S ~S <-> ~S~%" symbol value symbol-value)
- (sb!kernel:%set-symbol-value symbol value)
- (setf (sb!sys:sap-ref-sap binding-stack binding)
- (sb!sys:int-sap (sb!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 (sb!kernel:binding-stack-pointer-sap))
- (binding-stack
- (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
- sb!alien:unsigned)))
- (size (sb!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
- (sb!kernel:make-lisp-obj
- (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
- (symbol
- (sb!kernel:make-lisp-obj
- (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
- (+ binding 4))))))
- (cond ((symbolp symbol)
- (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
- symbol)))
- #+nil
- (format t "rebinding: ~S ~S <-> ~S~%"
- symbol value symbol-value)
- (sb!kernel:%set-symbol-value symbol value)
- (setf (sb!sys:sap-ref-sap binding-stack binding)
- (sb!sys:int-sap (sb!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 (sb!kernel:binding-stack-pointer-sap))
- (binding-stack
- (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
- sb!alien:unsigned)))
- (size (sb!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)
- (sb!kernel:make-lisp-obj
- (sb!sys:sap-int (sb!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 (sb!alien:extern-alien "binding_stack"
- sb!alien:unsigned)))
- (declare (type (unsigned-byte 32) binding-stack-size binding-stack))
- (setf (sb!kernel:binding-stack-pointer-sap)
- (sb!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 (sb!sys:sap-ref-sap (sb!sys:int-sap binding-stack) binding)
- (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
- (aref new-binding-stack index))))))
- (values))
-\f
-;;;; 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 (sb!kernel:get-lisp-obj-address sb!vm::*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)
- (sb!sys:sap-ref-32 (sb!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 sb!vm::*alien-stack* (sb!kernel:make-lisp-obj alien-stack))
- (do ((index 0 (1+ index)))
- ((>= index size))
- (declare (type (unsigned-byte 29) index))
- (setf (sb!sys:sap-ref-32 (sb!sys:int-sap *alien-stack-top*)
- (* 4 (- (1+ index))))
- (aref save-stack index)))
- (values))
-\f
-;;;; 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 sb!impl::*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))))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array sb!alien:unsigned nil) :extern))
- (dotimes (index size)
- (setf (aref save-vector index)
- (sb!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 sb!impl::*free-interrupt-context-index*))
- (declare (type (unsigned-byte 29) size))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array sb!alien:unsigned nil) :extern))
- (dotimes (index size)
- (setf (sb!alien:deref lisp-interrupt-contexts index)
- (aref save-vector index)))))
- (values))
-\f
-;;; 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) (*)))
- (*)) sb!vm::*control-stacks*))
-(defvar sb!vm::*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-object
- (lambda (stack-group stream)
- (declare (type stack-group stack-group)
- (stream stream))
- (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 sb!int: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)
-
-;;; 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*
- (sb!sys:sap-ref-32
- (sb!sys:int-sap (sb!alien:extern-alien "control_stack_end"
- sb!alien:unsigned))
- -4))
- ;; Initialise the *control-stacks* vector.
- (setq sb!vm::*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 sb!vm::*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 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 sb!vm::*control-stacks* cs-id))
- (setf (aref sb!vm::*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 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) sb!impl::*eval-stack*)
- ;; Ensure that the stack-top is valid.
- (setf (stack-group-eval-stack-top stack-group) sb!impl::*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 sb!int:index i))
- (setf (svref eval-stack i) nil))))))
-
-;;; 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 'sb!unix::*interrupts-enabled*
- t 'sb!impl::*gc-inhibit*))
-
-;;; 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 sb!vm::*control-stacks*))
- ;; Find the required stack size.
- (control-stack-end
- (sb!alien:extern-alien "control_stack_end"
- sb!alien:unsigned))
- (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
- (control-stack-size
- (- control-stack-end
- (sb!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 sb!vm::*control-stacks*))
- (setq sb!vm::*control-stacks*
- (adjust-array sb!vm::*control-stacks*
- (* 2 (length sb!vm::*control-stacks*))
- :element-type '(or null (unsigned-byte 32))
- :initial-element nil)))
- (setf (aref sb!vm::*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 (sb!unix:unix-sigblock
- (sb!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)
- (sb!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
- sb!kernel:*eval-stack*))
- :eval-stack-top sb!kernel:*eval-stack-top*
- ;; Misc stacks.
- :current-catch-block sb!impl::*current-catch-block*
- :current-unwind-protect-block
- sb!impl::*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 ((sb!unix::*interrupts-enabled* nil)
- (sb!impl::*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 (sb!vm: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 sb!unix::*interrupts-enabled* t)
- (setf sb!impl::*gc-inhibit* nil)
- (when sb!unix::*interrupt-pending*
- (sb!unix::do-pending-interrupt))
- (when sb!impl::*need-to-collect-garbage*
- (sb!impl::maybe-gc))
- (funcall initial-function))
- (let ((resumer (stack-group-resumer child-stack-group)))
- ;; Disable interrupts and GC.
- (setf sb!unix::*interrupts-enabled* nil)
- (setf sb!impl::*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 sb!kernel:*eval-stack*
- (stack-group-eval-stack resumer))
- (setf sb!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 (sb!unix:unix-sigblock
- (sb!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)
- (sb!unix:unix-sigsetmask old-sigs))
- ;; Misc stacks.
- (setf sb!impl::*current-catch-block*
- (stack-group-current-catch-block resumer))
- (setf sb!impl::*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 sb!vm::*control-stacks*
- (stack-group-control-stack-id resumer))))
- (declare (type (simple-array (unsigned-byte 32) (*))
- new-control-stack))
- (sb!vm:control-stack-return new-control-stack)))))))
- (when (and sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)
- (sb!unix::do-pending-interrupt))
- (when (and sb!impl::*need-to-collect-garbage*
- (not sb!impl::*gc-inhibit*))
- (sb!impl::maybe-gc))
- child-stack-group)))
-
-;;; 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 ((sb!unix::*interrupts-enabled* nil)
- (sb!impl::*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
- (sb!alien:extern-alien "control_stack_end" sb!alien:unsigned))
- (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
- (control-stack-size (- control-stack-end
- (sb!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 sb!vm::*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 sb!vm::*control-stacks*
- (stack-group-control-stack-id stack-group))
- control-stack))
-
- ;; eval-stack
- (setf (stack-group-eval-stack stack-group) sb!kernel:*eval-stack*)
- (setf (stack-group-eval-stack-top stack-group)
- sb!kernel:*eval-stack-top*)
- (setf sb!kernel:*eval-stack* (stack-group-eval-stack new-stack-group))
- (setf sb!kernel:*eval-stack-top*
- (stack-group-eval-stack-top new-stack-group))
-
- ;; misc stacks
- (setf (stack-group-current-catch-block stack-group)
- sb!impl::*current-catch-block*)
- (setf (stack-group-current-unwind-protect-block stack-group)
- sb!impl::*current-unwind-protect-block*)
- (setf sb!impl::*current-catch-block*
- (stack-group-current-catch-block new-stack-group))
- (setf sb!impl::*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 (sb!unix:unix-sigblock (sb!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)
- (sb!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 sb!vm::*control-stacks*
- (stack-group-control-stack-id new-stack-group))))
- (declare (type (simple-array (unsigned-byte 32) (*))
- new-control-stack))
- (sb!vm: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 sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)
- (sb!unix::do-pending-interrupt))
- (when (and sb!impl::*need-to-collect-garbage*
- (not sb!impl::*gc-inhibit*))
- (sb!impl::maybe-gc))
- (values))
-\f
-;;;; DOUBLE-FLOAT timing functions for use by the scheduler
-
-;;; These timer functions use double-floats for accuracy. In most
-;;; cases consing is avoided.
-
-#!-sb-fluid (declaim (inline get-real-time))
-(defun get-real-time ()
- #!+sb-doc
- "Return the real time in seconds."
- (declare (optimize (speed 3) (safety 0)))
- (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
- (declare (ignore ignore)
- (type (unsigned-byte 32) seconds useconds))
- (+ (coerce seconds 'double-float)
- (* (coerce useconds 'double-float) 1d-6))))
-
-#!-sb-fluid (declaim (inline get-run-time))
-(defun get-run-time ()
- #!+sb-doc
- "Return the run time in seconds"
- (declare (optimize (speed 3) (safety 0)))
- (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
- (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
- (declare (ignore ignore)
- (type (unsigned-byte 31) utime-sec stime-sec)
- ;; (Classic CMU CL had these (MOD 1000000) instead, but
- ;; at least in Linux 2.2.12, the type doesn't seem to be
- ;; documented anywhere and the observed behavior is to
- ;; sometimes return 1000000 exactly.)
- (type (integer 0 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))))
-\f
-;;;; 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-object
- (lambda (process stream)
- (print-unreadable-object (process stream :identity t :type t)
- (write-string (process-name process) stream)))))
- (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))
- ;; 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))
-
-(defun process-whostate (process)
- #!+sb-doc
- "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")))
-
-#!-sb-fluid (declaim (inline process-active-p))
-(defun process-active-p (process)
- (eq (process-state process) :active))
-
-#!-sb-fluid (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)
-
-#!-sb-fluid (declaim (inline current-process))
-(defun current-process ()
- #!+sb-doc
- "Returns the current process."
- *current-process*)
-
-(declaim (list *all-processes*))
-(defvar *all-processes* nil
- #!+sb-doc
- "A list of all alive processes.")
-
-#!-sb-fluid (declaim (inline all-processes))
-(defun all-processes ()
- #!+sb-doc
- "Return a list of all the live processes."
- *all-processes*)
-
-(declaim (type (or null process) *intial-process*))
-(defvar *initial-process* nil)
-
-;;; 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)
- #!+sb-doc
- "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))
- #!+sb-doc
- "Increments the reference by delta in a single atomic operation"
- `(without-scheduling
- (incf ,reference ,delta)))
-
-(defmacro atomic-decf (reference &optional (delta 1))
- #!+sb-doc
- "Decrements the reference by delta in a single atomic operation"
- `(without-scheduling
- (decf ,reference ,delta)))
-
-(defmacro atomic-push (obj place)
- #!+sb-doc
- "Atomically push object onto place."
- `(without-scheduling
- (push ,obj ,place)))
-
-(defmacro atomic-pop (place)
- #!+sb-doc
- "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 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 make-process (function &key (name "Anonymous"))
- #!+sb-doc
- "Make a process which will run function when it starts up. The process
- may be given an optional name which defaults to Anonymous. The new
- process has a fresh set of special bindings, with *PACKAGE* set to be
- the COMMON-LISP-USER package."
- (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))
- (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
- (catch '%end-of-the-process
- ;; Catch throws to the %END-OF-THE-WORLD.
- (setf *quitting-lisp*
- (catch 'sb!impl::%end-of-the-world
- (with-simple-restart
- (destroy "Destroy the process")
- (setf *inhibit-scheduling* nil)
- (funcall function))
- ;; Normal exit.
- (throw '%end-of-the-process nil))))
- (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)
- (update-process-timers *current-process*
- *initial-process*)
- (setf *current-process* *initial-process*)))
- *initial-stack-group* nil))))
- (atomic-push process *all-processes*)
- process))))
-
-(defun process-interrupt (process function)
- #!+sb-doc
- "Interrupt process and 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)
- #!+sb-doc
- "Destroy a process. The process is sent a interrupt which throws to
- the end of the process allowing it to unwind gracefully."
- (declare (type process process))
- (assert (not (eq process *current-process*)))
- (without-scheduling
- (unless (eq (process-state process) :killed)
- ;; Place 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.
- (push #'(lambda ()
- (throw '%end-of-the-process nil))
- (process-interrupts process))
- ;; Ensure that the process is active so that it can accept this
- ;; interrupt.
- (setf (process-state process) :active)))
- ;; Should we wait until it's dead?
- (process-yield))
-
-(defun restart-process (process)
- #!+sb-doc
- "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)))
- ;; No more processes if about to quit lisp.
- (when *quitting-lisp*
- (process-wait "Quitting Lisp" #'(lambda () nil)))
- ;; Create a new stack-group.
- (without-scheduling
- (setf (process-stack-group process)
- (make-stack-group
- (process-name process)
- #'(lambda ()
- (unwind-protect
- (catch '%end-of-the-process
- ;; Catch throws to the %END-OF-THE-WORLD.
- (setf *quitting-lisp*
- (catch 'sb!impl::%end-of-the-world
- (with-simple-restart
- (destroy "Destroy the process")
- (setf *inhibit-scheduling* nil)
- (apply (process-initial-function process)
- (process-initial-args process)))
- ;; Normal exit.
- (throw '%end-of-the-process nil))))
- (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)
- (update-process-timers *current-process* *initial-process*)
- (setf *current-process* *initial-process*)))
- *initial-stack-group* nil))
- (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)
- #!+sb-doc
- "Restart process, unwinding it to its initial state and calls
- function with args."
- (setf (process-initial-function process) function)
- (setf (process-initial-args process) args)
- (restart-process process))
-
-(defun disable-process (process)
- #!+sb-doc
- "Disable process from being runnable until enabled."
- (without-scheduling
- (assert (not (eq (process-state process) :killed)))
- (setf (process-state process) :inactive)))
-
-(defun enable-process (process)
- #!+sb-doc
- "Allow process to become runnable again after it has been disabled."
- (without-scheduling
- (assert (not (eq (process-state process) :killed)))
- (setf (process-state process) :active)))
-
-(defun process-wait (whostate predicate)
- #!+sb-doc
- "Causes the process to wait until predicate returns True. Processes
- can only call process-wait when scheduling is enabled, and the predicate
- can not call process-wait. Since the predicate may be evaluated may
- times by the scheduler it should be relative fast native compiled code.
- The single True predicate value is returned."
- (assert (not *inhibit-scheduling*))
- (assert (not (process-wait-function *current-process*)))
- ;; Don't need the disable scheduling here because the scheduler
- ;; doesn't mess with the whostate or timeout until the function is
- ;; setup, unless the process is interrupted in which case the
- ;; scheduler restores the state when execution resumers here.
- (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 (or fixnum float) timeout))
- #!+sb-doc
- "Causes the process to wait until predicate returns True, or the
- number of seconds specified by timeout has elapsed. The timeout may
- be a fixnum or a float in seconds. The single True predicate value is
- returned, or NIL if the timeout was reached."
- (assert (not *inhibit-scheduling*))
- (assert (not (process-wait-function *current-process*)))
- ;; Don't need the disable scheduling here because the scheduler
- ;; doesn't mess with the whostate or timeout until the function is
- ;; setup, unless the process is interrupted in which case the
- ;; scheduler restores the state when execution resumers here.
- (setf (process-%whostate *current-process*) whostate)
- (let ((timeout (etypecase timeout
- (fixnum
- (coerce timeout 'double-float))
- (single-float
- (coerce timeout 'double-float))
- (double-float
- (coerce timeout 'double-float)))))
- (declare (double-float timeout))
- (setf (process-wait-timeout *current-process*)
- (+ timeout (get-real-time)))
- (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)
-
-;;; The idle process will only run when there are no other runnable
-;;; processes.
-(defvar *idle-process* nil)
-
-;;; Decide when to allow the idle process to run.
-(defun run-idle-process-p ()
- ;; Check whether there are any other runnable processes.
- (dolist (process *all-processes* t)
- (when (and (not (eq process *idle-process*))
- (process-active-p process)
- (not (process-wait-function process)))
- (return nil))))
-
-(defun shutdown-multi-processing ()
- #!+sb-doc
- "Try to gracefully destroy all the processes giving them some
- chance to unwind, before shutting down multi-processing. This is
- currently necessary before a purify and is performed before a save-lisp.
- Multi-processing can be restarted by calling init-multi-processing."
- (assert (eq *current-process* *initial-process*) ()
- "Only the *initial-process* can shutdown multi-processing")
-
- (let ((destroyed-processes nil))
- (do ((cnt 0 (1+ cnt)))
- ((> cnt 10))
- (declare (type sb!int:index cnt))
- (dolist (process *all-processes*)
- (when (and (not (eq process *current-process*))
- (process-active-p process)
- (not (member process destroyed-processes)))
- (destroy-process process)
- (push process destroyed-processes)))
- (unless (rest *all-processes*)
- (return))
- (format t "destroyed ~D process~:P; remaining ~D~%"
- (length destroyed-processes) (length *all-processes*))
- (process-yield)))
-
- (start-sigalrm-yield 0 0) ; Off with the interrupts.
- ;; Reset the multi-processing state.
- (setf *inhibit-scheduling* t)
- (setf *initial-process* nil)
- (setf *idle-process* nil)
- (setf *current-process* nil)
- (setf *all-processes* nil)
- (setf *remaining-processes* nil)
- ;; Clean up the stack groups.
- (setf sb!vm::*control-stacks*
- (make-array 0 :element-type '(or null (unsigned-byte 32))
- :initial-element nil))
- (setf *current-stack-group* nil)
- (setf *initial-stack-group* nil))
-
-;;; A useful idle process loop, waiting on events using the select
-;;; based event server, which is assumed to be setup to call
-;;; process-yielding periodically.
-(declaim (double-float *idle-loop-timeout*))
-(defvar *idle-loop-timeout* 0.1d0)
-(defun idle-process-loop ()
- #!+sb-doc
- "An idle loop to be run by the initial process. The select based event
- server is called with a timeout calculated from the minimum of the
- *idle-loop-timeout* and the time to the next process wait timeout.
- To avoid this delay when there are runnable processes the *idle-process*
- should be setup to the *initial-process*. If one of the processes quits
- by throwing to %end-of-the-world then *quitting-lisp* will have been
- set to the exit value which is noted by the idle loop which tries to
- exit gracefully destroying all the processes and giving them a chance
- to unwind."
- (declare (optimize (speed 3)))
- (assert (eq *current-process* *initial-process*) ()
- "Only the *initial-process* is intended to run the idle loop")
- ;; Ensure the *idle-process* is setup.
- (unless *idle-process*
- (setf *idle-process* *current-process*))
- ;; Adjust the process name.
- (setf (process-name *current-process*) "Idle Loop")
- (do ()
- (*quitting-lisp*)
- ;; Calculate the wait period.
- (let ((real-time (get-real-time))
- (timeout *idle-loop-timeout*))
- (declare (double-float timeout))
- (dolist (process *all-processes*)
- (when (process-active-p process)
- (let ((wait-timeout (process-wait-timeout process)))
- (when wait-timeout
- (let ((delta (- wait-timeout real-time)))
- (when (< delta timeout)
- (sb!vm::double-float-reg-bias timeout)
- (setf timeout delta)))))))
- (when (> timeout 1d-5)
- (sb!sys:serve-all-events timeout))
- (process-yield)))
- (shutdown-multi-processing)
- (throw 'sb!impl::%end-of-the-world *quitting-lisp*))
-
-;;; the scheduler
-(defun process-yield ()
- (declare (optimize (speed 3)))
- #!+sb-doc
- "Allow other processes to run."
- (unless *inhibit-scheduling*
- ;; Catch any FP exceptions before entering the scheduler.
- (sb!kernel:float-wait)
- ;; Inhibit recursive entry of the scheduler.
- (setf *inhibit-scheduling* t)
- (assert (eq (first *remaining-processes*) *current-process*))
- (assert (eq *current-stack-group* (process-stack-group *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))
-
- (cond
- ;; New process at the head of the queue?
- ((eq next *current-process*))
- ;; Ignore inactive processes.
- ((not (process-active-p next)))
- ;; If the next process has pending interrupts then return to
- ;; it to execute these.
- ((process-interrupts next)
- (update-process-timers *current-process* 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)
- ;; Skip the idle process if there are other runnable
- ;; processes.
- (when (or (not (eq next *idle-process*))
- (run-idle-process-p))
- (update-process-timers *current-process* next)
- (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)
- (update-process-timers current-process next)
- (stack-group-resume (process-stack-group next)))
- (t
- ;; Timeout?
- (let ((timeout (process-wait-timeout next)))
- (when (and timeout (> (get-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)
- (update-process-timers current-process next)
- (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 cycles back to *all-processes*.
- (when (and (process-active-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. The return-value is also
- ;; saved and restored in case a process is
- ;; interrupted before it is read.
- (let ((wait-function (process-wait-function next))
- (wait-timeout (process-wait-timeout next))
- (whostate (process-%whostate next))
- (wait-return-value (process-wait-return-value next)))
- (setf (process-wait-function next) nil)
- (setf (process-wait-timeout next) nil)
- (setf (process-%whostate next) nil)
- (setf (process-wait-return-value 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)
- (setf (process-wait-return-value next) wait-return-value)))
- (t
- ;; Check the wait function.
- (let ((wait-fn (process-wait-function next)))
- (cond
- ((null wait-fn)
- (when (or (not (eq next *idle-process*))
- (run-idle-process-p))
- (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 (> (get-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)))
-
-;;; Return the real time in seconds accrued while the process was scheduled.
-(defun process-real-time (process)
- #!+sb-doc
- "Return the accrued real time elapsed while the given process was
- scheduled. The returned time is a double-float in seconds."
- (declare (type process process))
- (if (eq process *current-process*)
- (without-scheduling
- (let ((real-time (get-real-time)))
- (+ (process-%real-time process)
- (- real-time (process-scheduled-real-time process)))))
- (process-%real-time process)))
-
-;;; The run time in seconds accrued while the process was scheduled.
-(defun process-run-time (process)
- #!+sb-doc
- "Return the accrued run time elapsed for the given process. The returned
- time is a double-float in seconds."
- (declare (type process process))
- (if (eq process *current-process*)
- (without-scheduling
- (let ((run-time (get-run-time)))
- (+ (process-%run-time process)
- (- run-time (process-scheduled-run-time process)))))
- (process-%run-time process)))
-
-;;; Return the real time in seconds elapsed since the process was last
-;;; de-scheduled.
-(defun process-idle-time (process)
- #!+sb-doc
- "Return the real time elapsed since the given process was last
- descheduled. The returned time is a double-float in seconds."
- (declare (type process process))
- (if (eq process *current-process*)
- 0
- (without-scheduling
- (let ((real-time (get-real-time)))
- (- real-time (process-scheduled-real-time process))))))
-
-;;; Start a regular interrupt to switch processes. This may not be a
-;;; good idea yet as the SBCL code is not too interrupt safe.
-(defun start-sigalrm-yield (&optional (sec 0) (usec 500000))
- #!+sb-doc
- "Start a regular SIGALRM interrupt which calls process-yield. An optional
- time in seconds and micro seconds may be provided. Note that SBCL code
- base is not too interrupt safe so this may cause problems."
- (declare (fixnum sec usec))
- ;; Disable the gencgc pointer filter to improve interrupt safety.
- #!+(and gencgc nil)
- (setf (sb!alien:extern-alien "enable_pointer_filter" sb!alien:unsigned) 0)
- (flet ((sigalrm-handler (signal info context)
- (declare (ignore signal info context))
- (cond ((<= sb!impl::*free-interrupt-context-index* 1)
- #+nil (format t ".~%")
- (process-yield))
- (t
- #+nil (format t "-~%")))))
- (sb!sys:enable-interrupt :sigalrm #'sigalrm-handler))
- (sb!unix:unix-setitimer :real sec usec 0 1)
- (values))
-
-;;; Startup multi-processing, initializing the initial process. This
-;;; must be called before use of the other multi-process functions.
-(defun init-multi-processing ()
- (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)))
-
-(pushnew 'init-multi-processing sb!int:*after-save-initializations*)
-
-;;; Scrub the stored stacks of all the processes.
-(defun scrub-all-processes-stacks ()
- (sb!sys:without-interrupts
- (dolist (process *all-processes*)
- (let ((stack-group (process-stack-group process)))
- (when stack-group
- (scrub-stack-group-stacks stack-group))))))
-(pushnew 'scrub-all-processes-stacks sb!ext:*before-gc-hooks*)
-
-;;; Wait until FD is usable for DIRECTION.
-(defun process-wait-until-fd-usable (fd direction &optional timeout)
- #!+sb-doc
- "Wait until FD is usable for DIRECTION and return True. DIRECTION should be
- either :INPUT or :OUTPUT. TIMEOUT, if supplied, is the number of seconds to
- wait before giving up and returning NIL."
- (declare (type sb!int:index fd)
- (type (or real null) timeout)
- (optimize (speed 3)))
- (if (or (eq *current-process* *initial-process*)
- ;; Can't call process-wait if the scheduling is inhibited.
- *inhibit-scheduling*)
- ;; The initial-process calls the event server to block.
- (sb!sys:wait-until-fd-usable fd direction timeout)
- ;; Other processes use process-wait.
- (flet ((fd-usable-for-input ()
- (declare (optimize (speed 3) (safety 1)))
- (not (eql (sb!alien:with-alien ((read-fds
- (sb!alien:struct sb!unix:fd-set)))
- (sb!unix:fd-zero read-fds)
- (sb!unix:fd-set fd read-fds)
- (sb!unix:unix-fast-select
- (1+ fd) (sb!alien:addr read-fds) nil nil 0 0))
- 0)))
- (fd-usable-for-output ()
- (declare (optimize (speed 3) (safety 1)))
- (not (eql (sb!alien:with-alien ((write-fds
- (sb!alien:struct sb!unix:fd-set)))
- (sb!unix:fd-zero write-fds)
- (sb!unix:fd-set fd write-fds)
- (sb!unix:unix-fast-select
- (1+ fd) nil (sb!alien:addr write-fds) nil 0 0))
- 0))))
-
- (ecase direction
- (:input
- (unless (fd-usable-for-input)
- ;; Wait until input possible.
- (sb!sys:with-fd-handler (fd :input
- #'(lambda (fd)
- (declare (ignore fd)
- (optimize (speed 3)
- (safety 0)))
- (sb!mp:process-yield)))
- (if timeout
- (sb!mp:process-wait-with-timeout "Input Wait"
- timeout
- #'fd-usable-for-input)
- (sb!mp:process-wait "Input Wait" #'fd-usable-for-input)))))
- (:output
- (unless (fd-usable-for-output)
- ;; Wait until output possible.
- (sb!sys:with-fd-handler (fd :output
- #'(lambda (fd)
- (declare (ignore fd)
- (optimize (speed 3)
- (safety 0)))
- (sb!mp:process-yield)))
- (if timeout
- (sb!mp:process-wait-with-timeout "Output Wait"
- timeout
- #'fd-usable-for-output)
- (sb!mp:process-wait "Output Wait"
- #'fd-usable-for-output)))))))))
-
-;;; Redefine the sleep function to call process-wait-with-timeout,
-;;; rather than blocking.
-(defun sleep (n)
- #!+sb-doc
- "This function causes execution to be suspended for N seconds. N may
- be any non-negative, non-complex number."
- (when (or (not (realp n))
- (minusp n))
- (error "Invalid argument to SLEEP: ~S.~%~
- Must be a non-negative, non-complex number."
- n))
- (cond ((or (eq *current-process* *initial-process*)
- ;; Can't call process-wait if the scheduling is inhibited.
- *inhibit-scheduling*)
- ;; The initial-process may block.
- (multiple-value-bind (sec usec)
- (if (integerp n)
- (values n 0)
- (multiple-value-bind (sec frac) (truncate n)
- (values sec (truncate frac 1e-6))))
- (sb!unix:unix-select 0 0 0 0 sec usec))
- nil)
- (t
- (process-wait-with-timeout "Sleep" n (constantly nil)))))
-
-(defun show-processes (&optional verbose)
- #!+sb-doc
- "Show the all the processes, their whostate, and state. If the optional
- verbose argument is true then the run, real, and idle times are also
- shown."
- (fresh-line)
- (dolist (process *all-processes*)
- (when (eq process *current-process*)
- (format t "* "))
- (format t "~S ~S ~A~%" process (process-whostate process)
- (process-state process))
- (when verbose
- (format t "~4TRun time: ~,3f; Real time: ~,3f; Idle time: ~,3f~%"
- (process-run-time process)
- (process-real-time process)
- (process-idle-time process)))))
-
-(defun top-level ()
- #!+sb-doc
- "Top-level READ-EVAL-PRINT loop for processes."
- (let ((* nil) (** nil) (*** nil)
- (- nil) (+ nil) (++ nil) (+++ nil)
- (/// nil) (// nil) (/ nil)
- (magic-eof-cookie (cons :eof nil)))
- (loop
- (with-simple-restart (abort "Return to Top-Level.")
- (catch 'sb!impl::top-level-catcher
- (sb!unix:unix-sigsetmask 0)
- (let ((sb!impl::*in-top-level-catcher* t))
- (loop
- (sb!sys:scrub-control-stack)
- (fresh-line)
- (princ (if (functionp sb!int:*prompt*)
- (funcall sb!int:*prompt*)
- sb!int:*prompt*))
- (force-output)
- (let ((form (read *standard-input* nil magic-eof-cookie)))
- (cond ((not (eq form magic-eof-cookie))
- (let ((results
- (multiple-value-list
- (sb!int:interactive-eval form))))
- (dolist (result results)
- (fresh-line)
- (prin1 result))))
- (t
- (throw '%end-of-the-process nil)))))))))))
-
-(defun startup-idle-and-top-level-loops ()
- #!+sb-doc
- "Enter the idle loop, starting a new process to run the top level loop.
- The awaking of sleeping processes is timed better with the idle loop process
- running, and starting a new process for the top level loop supports a
- simultaneous interactive session. Such an initialization will likely be the
- default when there is better MP debug support etc."
- (assert (eq *current-process* *initial-process*) ()
- "Only the *initial-process* is intended to run the idle loop")
- (init-multi-processing) ; Initialise in case MP had been shutdown.
- ;; Start a new Top Level loop.
- (make-process #'top-level :name "top level loop")
- ;; Enter the idle loop.
- (idle-process-loop))
-\f
-;;;; simple locking
-
-(defstruct (lock (:constructor make-lock (&optional name)))
- (name nil :type (or null simple-base-string))
- (process nil :type (or null process)))
-(def!method print-object ((lock lock) stream)
- (print-unreadable-object (lock stream :identity t)
- (write-string "Lock" stream)
- (let ((name (lock-name lock)))
- (when name
- (format stream " ~A" name)))
- (let ((process (lock-process lock)))
- (cond (process
- (format stream ", held by ~S" process))
- (t
- (write-string ", free" stream))))))
-
-;;; Wait for the lock to be free and acquire it for the *current-process*.
-(defun lock-wait (lock whostate)
- (declare (type lock lock))
- (process-wait whostate
- #'(lambda ()
- (declare (optimize (speed 3)))
- #!-mp-i486
- (unless (lock-process lock)
- (setf (lock-process lock) *current-process*))
- #!+mp-i486
- (null (sb!kernel:%instance-set-conditional
- lock 2 nil *current-process*)))))
-
-;;; Wait with a timeout for the lock to be free and acquire it for the
-;;; *current-process*.
-(defun lock-wait-with-timeout (lock whostate timeout)
- (declare (type lock lock))
- (process-wait-with-timeout
- whostate timeout
- #'(lambda ()
- (declare (optimize (speed 3)))
- #!-mp-i486
- (unless (lock-process lock)
- (setf (lock-process lock) *current-process*))
- #!+mp-i486
- (null (sb!kernel:%instance-set-conditional
- lock 2 nil *current-process*)))))
-
-;;; Atomically seize a lock if it's free.
-#!-mp-i486
-(defun seize-lock (lock)
- (declare (type lock lock)
- (optimize (speed 3)))
- (sb!sys:without-interrupts
- (unless (lock-process lock)
- (setf (lock-process lock) *current-process*))))
-
-(defmacro with-lock-held ((lock &optional (whostate "Lock Wait") &key timeout)
- &body body)
-
- #!+sb-doc
- "Execute the body with the lock held. If the lock is held by another
- process then the current process waits until the lock is released or a
- optional timeout is reached - recursive locks are allowed. The
- optional wait timeout is a time in seconds acceptable to
- process-wait-with-timeout. The results of the body are return upon
- success and NIL is return if the timeout is reached."
- (let ((have-lock (gensym)))
- `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
- (unwind-protect
- ,(if timeout
- `(when (cond (,have-lock)
- #!+mp-i486 ((null (sb!kernel:%instance-set-conditional
- ,lock 2 nil *current-process*)))
- #!-mp-i486 ((seize-lock ,lock))
- ((null ,timeout)
- (lock-wait ,lock ,whostate))
- ((lock-wait-with-timeout
- ,lock ,whostate ,timeout)))
- ,@body)
- `(progn
- (unless (or ,have-lock
- #!+mp-i486 (null (sb!kernel:%instance-set-conditional
- ,lock 2 nil *current-process*))
- #!-mp-i486 (seize-lock ,lock))
- (lock-wait ,lock ,whostate))
- ,@body))
- (unless ,have-lock
- #!+mp-i486 (sb!kernel:%instance-set-conditional
- ,lock 2 *current-process* nil)
- #!-mp-i486 (when (eq (lock-process ,lock) *current-process*)
- (setf (lock-process ,lock) nil)))))))
projects / sbcl.git / commitdiff