;;;
;;; **********************************************************************
;;; This code was written by Douglas T. Crosher and has been placed in
;;; the Public domain, and is provided 'as is'.
;;;
;;; $Id: mp-test.lisp,v 1.12 1999/12/03 21:11:35 dtc Exp $
;;;
;;; **********************************************************************
;;;
;;; Stack-group and multi-process support for CMUCL x86.
;;;
;;; Test code and examples.
;;;

(in-package "MP")

;;;; Bindings stack

;;; Show the current binding stack.
(defun show-binding-stack ()
  (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))))))
	(format t "~s ~s~%" symbol value)))))

(defun tst-binding ()
  (show-binding-stack)
  (unbind-binding-stack)
  (multiple-value-bind (stack size)
      (save-binding-stack #())
    (restore-binding-stack stack size))
  (rebind-binding-stack)
  (show-binding-stack))

;;;; Alien stack

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

;;;; Control stack

(defun show-control-stack (control-stack-id)
  (declare (type lisp::index control-stack-id))
  (let ((stack (aref x86::*control-stacks* control-stack-id)))
    (declare (type (or null (simple-array (unsigned-byte 32) (*))) stack))
    (when stack
      (format t "Saved control stack ~d~%" control-stack-id)
      ;; First element has the stack-pointer.
      (let ((stack-pointer (aref stack 0))
	    (length (length stack)))
	(do ((addr (- (alien:extern-alien "control_stack_end" alien:unsigned)
		      4)
		   (- addr 4))
	     (index 1 (1+ index)))
	    ((or (< addr stack-pointer)
		 (>= index length)))
	  (declare (type (unsigned-byte 32) addr)
		   (type (unsigned-byte 29) index))
	  (format t "0x~8x : 0x~8x~%" addr (aref stack index)))
	(format t "Stack pointer: 0x~x~%" (aref stack 0))
	(format t "Return address: 0x~x~%" (aref stack (- length 2)))
	(format t "Frame pointer: 0x~x~%" (aref stack (- length 1)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Multi-process example.

;;; All the processes are going to write to the standsard output. Use
;;; an output lock to prevent conflict; also provides a good test.
(defvar *output-lock* nil)

;;; Results stack.
(defvar *results* nil)

;;; Do some time consuming work. Occasionally write out some results,
;;; and when done place the result the the *results* stack.
(defun work (itter msg)
  (declare (fixnum itter))
  (let ((sum 1d0))
    (declare (double-float sum))
    (do ((i 0  (1+ i)))
	((> i itter))
      (declare (fixnum i))
      (dotimes (i 1000000)
	(declare (fixnum i))
	(incf sum 1d-6)
	(incf sum 1d-6))
      (with-lock-held (*output-lock* "Waiting for output lock")
	(format t "~a ~d ~s~%" msg i sum)
	(finish-output))
      ;; May want to yield occasionally if an interrupt isn't going to
      ;; force a yield.
      #+nil (process-yield))
    (push sum *results*)))


;;;;
;;; Test catch, unwind, throw.
(declaim (double-float *work2-sum*))
(defvar *work2-sum* 0d0)

(defun work2 (itter msg)
  (declare (fixnum itter))
  (let ((*work2-sum* 0d0))
    (do ((i 0  (1+ i)))
	((> i itter))
      (declare (fixnum i))
      (dotimes (i 100000)
	(declare (fixnum i))
	(incf *work2-sum* (catch 'work2-sum
			    (work2b))))
      (with-lock-held (*output-lock* "Waiting for output lock")
	(format t "~a ~d ~s~%" msg i *work2-sum*)
	(finish-output))
      ;; May want to yield occasionally if an interrupt isn't going to
      ;; force a yield.
      #+nil (process-yield))
    (push *work2-sum* *results*)))

(defun work2b ()
  (unwind-protect
       (work2c)
    (incf *work2-sum* 1d-6)))

(defun work2c ()
  (unwind-protect
       (work2d)
    (incf *work2-sum* 1d-6)))

(defun work2d ()
  (unwind-protect
       (throw 'work2-sum 1d-6)
    (incf *work2-sum* 1d-6)))
;;;;

;;; Some process will require a lock to do any work.
(defvar *work-lock* nil)


(declaim (fixnum *int-count*))
(defvar *int-count* 0)

(declaim (fixnum *count* *local-count*))
(defvar *count* 0)
(defvar *local-count* 0)

;;;
(defun tst (&key (scale 1) (workers 150) (workers-locked 150))
  (init-multi-processing)
  ;; Start the yield interrupt - for the brave.
  (start-sigalrm-yield 0 5000)
  ;;
  (setf *output-lock* (make-lock "Output lock"))

  ;; Process to periodically show the processes.
  (let ((show-processes-process
	 (make-process
	  #'(lambda ()
	      (unwind-protect ; Test process unwinding when destroyed.
		   (loop
		    (process-wait-with-timeout "Sleeping" 20 #'(lambda () nil))
		    (with-lock-held (*output-lock* "Waiting for output lock")
		      (format t "-=-=-=-=-=-~%")
		      (format t "All processes:~%")
		      (show-processes t)
		      (format t "-=-=-=-=-=-~%")
		      (finish-output)))
		(with-lock-held (*output-lock* "Waiting for output lock")
		  (format t "Process ~s unwinding~%" *current-process*)
		  (finish-output))))
	  :name "Show processes")))
    
    (setf *results* nil)
    ;; Process to check and print and results pushed onto the
    ;; *results* stack. Will timeout if there have been no result for
    ;; 300 seconds, and kill the show-processes-process.
    (make-process
     #'(lambda ()
	 (loop
	  (let ((results
		 (process-wait-with-timeout "Waiting for results" (* 300 scale)
					      #'(lambda () *results*))))
	    (when (null results)
		(with-lock-held (*output-lock* "Waiting for output lock")
		  (format t "~s Timeout~%" *current-process*)
		  (finish-output))
		(destroy-process show-processes-process)	      
		(return))
	    (with-lock-held (*output-lock* "Waiting for output lock")
	      (format t "Results: ~s~%" results)
	      (finish-output))
	    (setf *results* nil))))
     :name "Show results"))
  
  (dotimes (worker workers)
    (let* ((name (format nil "Worker ~D" worker))
	   (output (format nil "~A: working" name)))
      ;; Results generating processes, running in parallel.
      (make-process #'(lambda () (work (* 5 scale) output)) :name name)))

  ;; Processes competing over a lock to work.
  (setf *work-lock* (make-lock "Work lock"))
  (dotimes (worker workers-locked)
    (let* ((name (format nil "Worker (locked) ~D" worker))
	   (output (format nil "~A: working" name)))
      (make-process
       #'(lambda ()
	   (dotimes (i (* 5 scale))
	     (with-lock-held (*work-lock* "Waiting for work lock")
	       (work (* 1 scale) output))
	     (process-yield)))
       :name name)))
  
  ;; Local special counter.
  (setq *count* 0)
  (setq *local-count* 0)
  ;; New processes do not inherit local special bindings and will thus
  ;; see the global value of *local-count* even though the parent
  ;; process makes a local binding.
  (let ((*local-count* 20))
    (make-process
     #'(lambda ()
	 (dotimes (i (* 10 scale))
	   (with-lock-held (*output-lock* "Waiting for output lock")
	     (incf *count*)
	     (incf *local-count*)
	     (format t "~s ~d ~d ~d~%"
		     *current-process* i *local-count* *count*))
	   (process-wait-with-timeout "Sleeping" 2 #'(lambda () nil))))
     :name "Counter 2"))
  ;; This process makes a local binding of *local-count*.
  (make-process
   #'(lambda ()
       (let ((*local-count* 0))
	 (dotimes (i (* 10 scale))
	   (with-lock-held (*output-lock* "Waiting for output lock")
	     (incf *count*)
	     (incf *local-count*)
	     (format t "~s ~d ~d ~d~%"
		     *current-process* i *local-count* *count*)
	     (finish-output))
	   (process-wait-with-timeout "Sleeping" 2 #'(lambda () nil)))))
   :name "Counter 1")
  
  ;; Recursively interrupted processes.
  (let (;; Setup three sleepers that will be interrupted.
	(ps1 (make-process
	      #'(lambda ()
		  (process-wait-with-timeout "Sleeping" (* 20 scale)
					     #'(lambda () nil)))
	      :name "Sleeper 1"))
	(ps2 (make-process
	      #'(lambda ()
		  (process-wait-with-timeout "Sleeping" (* 20 scale)
					     #'(lambda () nil)))
	      :name "Sleeper 2"))
	(ps3 (make-process
	      #'(lambda ()
		  (process-wait-with-timeout "Sleeping" (* 20 scale)
					     #'(lambda () nil)))
	      :name "Sleeper 3"))
	interrupt)
    (setq *int-count* 0)
    (setq interrupt
	  #'(lambda ()
	      (with-lock-held (*output-lock* "Waiting for output lock")
		(format t "Process ~s interrupted ~d~%"
			*current-process* *int-count*)
		(finish-output))
	      (incf *int-count*)
	      (process-wait-with-timeout "Sleeping" 1 #'(lambda () nil))
	      (cond ((eq *current-process* ps1)
		     (process-interrupt ps2 interrupt))
		    ((eq *current-process* ps2)
		     (process-interrupt ps3 interrupt))
		    ((eq *current-process* ps3)
		     (process-interrupt ps1 interrupt)))))
    ;; Start the ball rolling.
    (process-interrupt ps1 interrupt))
  
  ;; Have the initial process do some work also.
  (work (* 10 scale) "Init. working"))

(defun tst-comp ()
  (start-sigalrm-yield 0 50000)
  ;; Try compiling two files simultaneously.
  (make-process
   #'(lambda ()
       (compile-file "irrat" :error-output t :byte-compile nil
		     :trace-file t))
   :name "Compile irrat")
  (make-process
   #'(lambda ()
       (compile-file "numbers" :error-output t :byte-compile nil
		     :trace-file t))
   :name "Compile numbers"))

(defvar *tst-lock* (make-lock "Test lock"))

(defun tst-lock ()
  (declare (optimize (speed 3) (safety 0)))
  (let ((sum 0))
    (declare (fixnum sum))
    (dotimes (i 10000000)
      (declare (fixnum i))
      (with-lock-held (*tst-lock* "Waiting for test lock")
	(incf sum)))
    sum))

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

(defun tst-alien-stack-save ()
  (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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Test the stack-group switching speed.

(defun tst-sg-speed ()
  (init-stack-groups)
  (let* ((num-switch 0)
	 t1 t2)
    (declare (fixnum num-switch)
	     (type (or stack-group null) t1 t2))
    (setq t1 (make-stack-group "T1"
			       #'(lambda ()
				   (dotimes (i 100000)
				     (declare (fixnum i))
				     (incf num-switch)
				     (stack-group-resume t2)))))
    (setq t2 (make-stack-group "T2"
			       #'(lambda ()
				   (dotimes (i 100000)
				     (declare (fixnum i))
				     (incf num-switch)
				     (stack-group-resume t1)))))
    (stack-group-resume t1)
    (inactivate-stack-group t1)
    (inactivate-stack-group t2)
    num-switch))