;;; -*- Mode:LISP; Package:USER; Base:10; Fonts:(CPTFONTB) -*-

#|| 
   this isnt a fatal bug, but it shows an important
   performance limitation. 8-Feb-86 11:27:39 -gjc

A standard way to do a multi-threaded device (MTD) or network driver is as follows:

(defun User-Read/Write-function (data)
  (using-resource (s device-structure)
    (with-lock (device-lock)
      (device-transmit s data))
    (device-reply-wait s)))

The device-transmit function may actually write the device, allowed because of the 
1device-lock*, however a background process must wait on device replies so
as to demultiplex different responses and update the cooresponding device-structure.
Another process could also take responsibility for retransmission,
although the device-reply-wait could check for that too. 
The overhead involved is in the code for allocating the resource, getting
the lock, and the process switches involved.

 [USER] ==> [SCHEDULER] ==> [BACKGROUND] ==> [SCHEDULER] ==> [USER]

4 Stack-Group switches and two runs of the scheduler.

A single threaded (STD) implementation would require:

 [USER] ==> [SCHEDULER] ==> [USER]

Although if the device responds quickly enough the process-wait it uses
may return the first time before the 2 stack-group switches are needed.

The lisp-level 3COM ethernet driver falls into the MTD class.
The addition of microcode support put the threading and demultiplexing
responsibility on the microcode.

Another way to optimize the MTD case is to do a quick-check,

 [USER] ==> [SCHEDULER] ==> [BACKGROUND] ==> [SCHEDULER] ==> [USER]
   $                                                            ^
   $                                                            ^
   [quick-check, device ready and for me?]----------------------^

The trick to pulling this off is organizing the device driver so
that the cases in the background are available to the forground.
e.g.

(defun background-process ()
  (do-forever
    (process-wait "device" #'device-wants-to-say-something)
    (handle-message (get-device-message))))

(defun handle-message (message)
  (dolist (request outstanding-requests)
    (if (message-for-request message request)
        (enact-request message request))))

(defun device-wants-to-say-something ()
  (or (actual-device-wants-to-say-something)
      *leftover-message*))

(defun get-device-message ()
  (if *leftover-message*
      (prog1 *leftover-message* (setq *leftover-message* nil))
    (get-actual-device-message)))


The quick-check could then be:

(defun quick-check (request)
  (actual-device-wants-to-say-something)
  (let ((message (get-actual-device-message)))
    (cond ((message-for-request message request)
           (enact-request message request))
	  ('else
	   (setq *leftover-message* message)))))


The purpose of the MTD-TEST is to get a base-line figure for the
overhead of the processe and stack group switches, so you can determine
if your application might be performance limited by that. If so
you might rewrite it only the lines suggested above.

||#


(defvar *mtd-lock* nil)
(defvar *mtd-outstanding* nil)

(defstruct (mtd-structure conc-name named)
  message
  reply)

(defresource mtd-structure ()
  :constructor (make-mtd-structure)
  :deinitializer (progn (setf (mtd-structure-message object) nil)
			(setf (mtd-structure-reply object) nil)))

(defun mtd-test (&optional (loops 100))
  (enable-mtd-background)
  (time-loop-report "MTD" loops
		    #'(lambda ()
			(using-resource (x mtd-structure)
			  (with-lock (*mtd-lock*)
			    (mtd-transmit x))
			  (mtd-wait x)))))


(defun mtd-test-control (&optional (loops 1000))
  (time-loop-report "MTD control" loops
		    #'(lambda ()
			(using-resource (x mtd-structure)
			  (with-lock (*mtd-lock*)
			    (without-interrupts
			      (mtd-transmit x)
			      (mtd-receive)))))))

(defvar *buff1* (make-array 2048 :type 'art-8b))
(defvar *buff2* (make-array 2048 :type 'art-8b))

(defun mtd-test-buff (&optional (loops 100))
  "Test of transmit with 2048 byte buffer"
  (enable-mtd-background)
  (time-loop-report "MTD" loops
		    #'(lambda ()
			(using-resource (x mtd-structure)
			  (with-lock (*mtd-lock*)
			    (copy-array-portion *buff1*
						0
						(length *buff1*)
						*buff2*
						0
						(length *buff2*))
			    (mtd-transmit x))
			  (mtd-wait x)))))

(defun mtd-transmit (x)
  (without-interrupts
    (push x *mtd-outstanding*)))

(defun mtd-wait (x)
  (process-wait "mtd wait"
		#'(lambda (y)
		    (mtd-structure-reply y))
		x))

     
(defvar *mtd-background* nil)

(defun enable-mtd-background ()
  (or *mtd-background*
      (setq *mtd-background* (make-process "mtd background")))
  (send *mtd-background* :preset 'mtd-background)
  (process-reset-and-enable *mtd-background*))

(defun mtd-background ()
  (do-forever
    (mtd-device-wait)
    (mtd-receive)))

(defun mtd-receive ()
  (dolist (r *mtd-outstanding*)
    (when (mtd-request-p r)
      (without-interrupts
	(setq *mtd-outstanding* (delq r *mtd-outstanding*)))
      (return (mtd-enact r)))))
  

(defun mtd-request-p (r)
  r
  t)

(defun mtd-device-wait ()
  ;; this being fake, we just want for an outstanding request.
  (process-wait "mtd interrupt" #'(lambda ()
				    *mtd-outstanding*)))

(defun mtd-enact (r)
  (setf (mtd-structure-reply r) t))


(defun time-loop-report (name loops function)
  (let ((time (time)))
    (dotimes (j loops)
      (funcall function))
    (setq time (quotient (time-difference (time) time) 60.0))
    (format t "~&~A of ~D loops took ~$ seconds, ~$ loops per second~%"
	    name
	    loops time
	    (quotient loops time))))