diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp index 0ddf9b7bf2fd94a91b2a275e07d1262951822616..2bc7d431e4085c6e4ab0eb84742109efed9ed877 100644 --- a/code/multi-proc.lisp +++ b/code/multi-proc.lisp @@ -3,7 +3,7 @@ ;;; 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.5 1997/11/21 12:14:27 dtc Exp $ +;;; $Id: multi-proc.lisp,v 1.6 1997/11/22 14:46:36 dtc Exp $ ;;; ;;; ********************************************************************** ;;; @@ -172,6 +172,39 @@ (restore-alien-stack save-stack size alien-stack)) (format t "~s~%" buf))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; 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)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -217,6 +250,10 @@ ;; 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))) @@ -254,6 +291,7 @@ :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*)) @@ -322,38 +360,45 @@ (setf (aref x86::*control-stacks* control-stack-id) control-stack) (values control-stack control-stack-id))) (allocate-child-stack-group (control-stack-id) - ;; 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))))) + ;; 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. + (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 + ;; Interrupt contexts + :interrupt-contexts interrupt-contexts + ;; Binding stack. + :binding-stack binding-stack + :binding-stack-size binding-stack-size + ;; Resumer + :resumer resumer)))))) (let ((child-stack-group nil)) (let ((unix::*interrupts-enabled* nil) (lisp::*gc-inhibit* t)) @@ -369,6 +414,8 @@ (unwind-protect (progn (setq *current-stack-group* child-stack-group) + (assert (eq *current-stack-group* + (process-stack-group *current-process*))) ;; Child start with interrupts and GC enabled. (let ((unix::*interrupts-enabled* t) (lisp::*gc-inhibit* nil)) @@ -382,6 +429,8 @@ ;; 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) @@ -405,6 +454,9 @@ (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* @@ -428,6 +480,7 @@ (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*)))) + (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. @@ -474,6 +527,11 @@ (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. (unbind-binding-stack) (multiple-value-bind (stack size) @@ -484,6 +542,10 @@ (stack-group-binding-stack-size new-stack-group)) (rebind-binding-stack) + ;; 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)) @@ -502,6 +564,7 @@ (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*)) @@ -764,6 +827,7 @@ ;; 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* @@ -890,8 +954,11 @@ (setf (alien:extern-alien "enable_pointer_filter" alien:unsigned) 0) (flet ((sigalrm-handler (signal code scp) (declare (ignore signal code scp)) - (when (<= lisp::*free-interrupt-context-index* 1) - (process-yield)))) + (cond ((<= lisp::*free-interrupt-context-index* 1) + #+nil (format t ".~%") + (process-yield)) + (t + #+nil (format t "-~%"))))) (sys:enable-interrupt :sigalrm #'sigalrm-handler)) (unix:unix-setitimer :real sec usec 0 1) (values))