;;; -*- Mode:LISP; Package:ETHERNET; Base:10; Readtable:CL -*-

#|

  Copyright LISP Machine, Inc. 1987
   See filename "Copyright.Text" for
  licensing and release information.

|#

(export '( setup-3com
	   *3com-ethernet-interface*
	   *3com-owner*))

(defstream 3com-interface
	   (network-interface)
	   "3COM-"
  (microcode-enabled nil)			; t if use lambda microcode
  (transmit-time-outs 0)
  (buffer-not-available 0)
  (jam-count 0)
  (fcs-errors 0)
  )

(defop (3com-interface :peek-special-fields) (ni)
  (list (tv:scroll-parse-item
	  `(:mouse-item
	     (nil :buttons
		  ,(make-list 3 :initial-element
			      `(nil :eval (let ((enabled (3com-microcode-enabled ni)))
					    (funcall ni :disable)
					    (funcall ni :enable :microcode (not enabled)))
				    :bindings ((ni ',ni))))
		  :DOCUMENTATION
		  "Click to toggle usage of microcode"
		  :BINDINGS
		  ((ni ',ni)))
	     :function 3com-microcode-enabled (,ni) NIL ("Microcode enabled: ~A"))
	  `(:function 3com-transmit-time-outs (,ni) NIL (" time outs ~D"))
	  `(:function 3com-buffer-not-available (,ni) NIL (" no buffer ~D"))
	  `(:function 3com-jam-count (,ni) NIL (" jam count ~D"))
	  `(:function 3com-fcs-errors (,ni) NIL (" fcs error ~D")))))

(defvar *3com-ethernet-interface* nil "The Lambda 3com Ethernet interface")
(defsubst i-own-3com ()
  (eq *3com-owner* si:*my-op*))

;;; This file contains routines pertaining specifically to the 3Com Ethernet interface

(defparameter 3com-mebase #x30000 "address of 3com ethernet controller")
(defparameter 3com-mecsr 3com-mebase "control/status register for 3com interface")
(defparameter 3com-meback (+ 2 3com-mecsr) "jam backoff counter for 3com interface")
(defparameter 3com-address-rom (+ 3com-mebase #x400) "3com ethernet address ROM")
(defparameter 3com-address-ram (+ 3com-mebase #x600) "3com ethernet address RAM")
(defparameter 3com-transmit-buffer (+ 3com-mebase #x800) "3com transmit buffer")
(defparameter 3com-buffer-a (+ 3com-mebase #x1000) "3com receive buffer A")
(defparameter 3com-buffer-b (+ 3com-mebase #x1800) "3com receive buffer B")
(defparameter 3com-me-buffer-size 2048. "number of bytes in a buffer")

;Note: this code operates with the byte-ordering switch ON on the 3-COM board.
;  This sets "low byte first" mode, like the 8086 and unlike the 68000.
;  Setting it this way means data CAN be read from packet buffers with 32 bit transfers.
;  This is NOT the way the board was shipped by 3-COM.
;  This means the pictures in the manual are byte reversed!
;  In particular, the byte offset words in the buffer headers are byte reversed!!!

(defconstant reset (byte 1 0))			;reset the controller.
;;; bit 1 not used
(defconstant rbba (byte 1 2))			;A/B receive buffer ordering.
(defconstant amsw (byte 1 3))			;address in RAM is valid
(defconstant jam (byte 1 4))			;writing 1 clears jam.
(defconstant tbsw (byte 1 5))			;set if transmit buffer belongs to ether.
 (defconstant tbsw+jam (byte 2 4))
(defconstant absw (byte 1 6))			;set if buffer A belongs to ether.
(defconstant bbsw (byte 1 7))			;set if buffer B belongs to ether.
 (defconstant a+b-bsw (byte 2 6))		; both of the above.
(defconstant pa (byte 4 8))			;which frame addresses to accept
(defconstant jinten (byte 1 12))		;enable interrupts on jam.
(defconstant tinten (byte 1 13))		;enable interrupts on transmit buffer.
(defconstant ainten (byte 1 14))		;enable interrupts on buffer A.
(defconstant binten (byte 1 15))		;enable interrupts on buffer B.

;;;packet class codes
(defconstant pcc-all 0)				;receive all packets
(defconstant pcc-all-errors 1)			;receive all packets except runts, frame, fcs errors
(defconstant pcc-all-fcs-frame 2)		;receive all packets except frame & fcs errors
(defconstant pcc-mine+multi 3)			;receive this station + multicast packets
(defconstant pcc-mine+multi-errors 4)		;receive this station + multicast except errors
(defconstant pcc-mine+multi-fcs-frame 5)	;receive this station + multicast except frame and fcs errors
(defconstant pcc-mine+broad 6)			;receive this station + broadcast packets
(defconstant pcc-mine+broad-errors 7)		;receive this station + broadcast except errors
(defconstant pcc-mine+broad-fcs-frame 8)	;receive this station + broadcast except frame and fcs errors

(defconstant 3com-csr-background-bits (logior (dpb pcc-mine+broad-errors pa 0) (dpb 1 amsw 0)))

(defun write-3com-csr (new-csr)
  (when (i-own-3com)
    (sys:%nubus-write si:sdu-quad-slot 3com-mecsr new-csr)
    ;; This also writes the jam-backoff counter, which I guess doesn't hurt.
    ;; Writing it in two pieces also has potential lossage.
    ))

(defun read-3com-csr ()
  (if (i-own-3com)
      (ldb (byte 16 0) (sys:%nubus-read si:sdu-quad-slot 3com-mecsr))
    0))

;interface to LAMBDA ethernet microcode

(defun enable-lambda-ucode ()
  (sys:%processor-switches (dpb 1 (byte 1 22.) (sys:%processor-switches nil))))

(defun disable-lambda-ucode ()
  (sys:%processor-switches (dpb 0 (byte 1 22.) (sys:%processor-switches nil))))
  
(defsubst lambda-ucode-enabled-p ()
  (ldb-test (byte 1 22.) (sys:%processor-switches nil)))

(defun assure-good-int-list-pointer (pointer-to-list)
  (or (eq pointer-to-list net:int-free-list-pointer)
      (eq pointer-to-list net:int-receive-list-pointer)
      (eq pointer-to-list net:int-transmit-list-pointer)))

(defun int-pkt-list-put (int-pkt pointer-to-list)
  (net:assure-safe-int-pkt int-pkt)
  (assure-good-int-list-pointer pointer-to-list)
  (zl:loop for old = (sys:%p-contents-offset pointer-to-list 0)
	   do (setf (net:int-pkt-thread int-pkt) old)
	   until (sys:%store-conditional pointer-to-list old int-pkt)))

(defun int-pkt-list-get (pointer-to-list)
  (assure-good-int-list-pointer pointer-to-list)
  (zl:loop for old = (sys:%p-contents-offset pointer-to-list 0)
	   if (null old) do (return nil)
	   until (sys:%store-conditional-double pointer-to-list old
						(locf (net:int-pkt-thread old))
						(net:int-pkt-thread old))
	   finally (setf (net:int-pkt-thread old) nil)
	   (return old)))

(defun 3com-reset (stream)
  (when (i-own-3com)
    (without-interrupts
      (disable-lambda-ucode)
      (write-3com-csr (dpb 1 reset 0))	;don't used background bits here
      (setf (3com-address stream) 0)
      (dotimes (i 6)
	(let ((next-byte (sys:%multibus-read-8 (+ 3com-address-rom i))))
	  (sys:%multibus-write-8 (+ 3com-address-ram i) next-byte)
	  (setf (3com-address stream)
		(dpb next-byte (byte 8 0) (ash (3com-address stream) 8.)))))
      ;;set up normal csr - address RAM valid, receive MINE + Broadcast packets
      (write-3com-csr 3com-csr-background-bits))
    t))

(defun 3com-disable (stream)
  (when (3com-microcode-enabled stream)
    (disable-lambda-ucode)
    (setf (3com-microcode-enabled stream) nil)
    (without-interrupts	    ;free all packets on receive list
      (do ((int-pkt (int-pkt-list-get net:int-receive-list-pointer)
		    (int-pkt-list-get net:int-receive-list-pointer)))
	  ((null int-pkt))
	(setf (net:int-pkt-thread int-pkt) nil)
	(free-packet int-pkt)))))

(defun 3com-enable (stream &optional &key (microcode t))
  (when (i-own-3com)
    (setf (3com-microcode-enabled stream) microcode)
    (cond (microcode
	   (enable-lambda-ucode))
	  (t
	   (arm-3com-receive-buffer ABSW)
	   (arm-3com-receive-buffer BBSW)))
    t))

(defun reset-jam ()
  (write-3com-csr (dpb 1 reset 0))
  (write-3com-csr 3com-csr-background-bits)
  (incf (3com-jam-count *3com-ethernet-interface*)))

(defun arm-3com-receive-buffer (byte-ptr)
  (tagbody
   l  (when (ldb-test tbsw (read-3com-csr))
	(when (ldb-test jam (read-3com-csr))
	  (reset-jam))
	(go l))
      (without-interrupts
	(when (ldb-test tbsw (read-3com-csr))
	  (go l))
	(write-3com-csr (dpb 1 byte-ptr 3com-csr-background-bits)))))

(defun write-lambda-3com-frame-header (buffer-base offset source destination type)
  (when (i-own-3com)
    (decf offset 14.)

    (sys:%multibus-write-8 (1+ buffer-base) (ldb (byte 8 0) offset))	;offset reg is reversed!!!
    (sys:%multibus-write-8  buffer-base (ldb (byte 8 8) offset))

    (dotimes (i 6)
      (let ((next-byte (ldb (byte 8 (* i 8)) destination)))
	(sys:%multibus-write-8 (- (+ buffer-base offset 5) i) next-byte)))
    
    (dotimes (i 6)
      (let ((next-byte (ldb (byte 8 (* i 8)) source)))
	(sys:%multibus-write-8 (- (+ buffer-base offset 11) i) next-byte)))
    
    (sys:%multibus-write-8 (+ buffer-base offset 12) (ldb (byte 8 8) type))
    (sys:%multibus-write-8 (+ buffer-base offset 13) (ldb (byte 8 0) type))))

;;; LAMBDA's 3com receive buffer contains
;;; buffer-base:    meahdr (note byte reversed!!)
;;;          +2:    destination
;;;          +8:    source
;;;         +14:    type
;;;         +16:    data

(defconstant %%3com-buffer-header-nbytes (byte 11 0))
(defconstant %%3com-buffer-header-framing-error (byte 1 11))
(defconstant %%3com-buffer-header-address-match (byte 1 12))
(defconstant %%3com-buffer-header-range-error (byte 1 13))
(defconstant %%3com-buffer-header-broadcast (byte 1 14))
(defconstant %%3com-buffer-header-fcs-error (byte 1 15))
(defconstant %%3com-buffer-header-error #o124000)	;framing error + range error + fcs error

(defun read-3com-buffer-header (buffer-base)
  (dpb (sys:%multibus-read-8 buffer-base)
       (byte 8 8)
       (sys:%multibus-read-8 (1+ buffer-base))))

(defun read-frame-header-destination (buffer-base &aux (result 0))
  "returns the destination address of the packet in the hardware buffer"
  (dotimes (i 6)
    (let ((next-byte (sys:%multibus-read-8 (+ buffer-base 2 i))))
      (setf result (dpb next-byte (byte 8 0) (ash result 8.)))))
  result)

(defun read-frame-header-source (buffer-base &aux (result 0))
  "returns the source address of the packet in the hardware buffer"
  (dotimes (i 6)
    (let ((next-byte (sys:%multibus-read-8 (+ buffer-base 8 i))))
      (setf result (dpb next-byte (byte 8 0) (ash result 8.)))))
  result)

(defun read-frame-header-type (buffer-base)
  "returns the type of the packet in the hardware buffer"
  (dpb (sys:%multibus-read-8 (+ buffer-base 14.))
       (byte 8 8)
       (sys:%multibus-read-8 (+ buffer-base 15.))))

(defun 3com-send-int-pkt (int-pkt e-source e-dest e-type n-16-bit-words)
  (net:assure-safe-int-pkt int-pkt)

  (cond ((lambda-ucode-enabled-p)
	 (setf (fill-pointer int-pkt) (max (fill-pointer int-pkt) 30.))
	 ;the microcode stores the address "right", we should fix the 
	 ;macrocode conventions someday
	 (setf (array-leader int-pkt sys:%chaos-leader-csr-1)
	       (+ (ash (ldb (byte 8 24.) e-dest) 16.)
		  (ash (ldb (byte 8 32.) e-dest)  8.)
		  (ldb (byte 8 40.) e-dest)))
	 (setf (array-leader int-pkt sys:%chaos-leader-csr-2)
	       (+ (ash (ldb (byte 8  0.) e-dest) 16.)
		  (ash (ldb (byte 8  8.) e-dest)  8.)
		  (ldb (byte 8 16.) e-dest)))
	 (setf (array-leader int-pkt sys:%chaos-leader-bit-count) (swap-two-bytes e-type))
	 (int-pkt-list-put int-pkt net:int-transmit-list-pointer)
	 (sys:%chaos-wakeup)
	 t)
	(t
	 (3com-send-int-pkt-via-multibus int-pkt e-source e-dest e-type n-16-bit-words))))

(defun 3com-send-int-pkt-via-multibus (int-pkt e-source e-dest e-type n-16-bit-words
				       &aux csr start-time)
  (declare (fixnum csr))
  (unwind-protect
      (let* ((physical-size (max (* n-16-bit-words 2) 60.))	;don't send runts
	     (offset (the fixnum (- 3com-me-buffer-size physical-size)))
	     (beginning-address (the fixnum (+ 3com-transmit-buffer offset))))
	(tagbody
	    (setq start-time (sys:%fixnum-microsecond-time))
	 l  (setq csr (read-3com-csr))
	    (cond ((ldb-test jam csr)
		   (reset-jam)
		   (go l))
		  ((ldb-test tbsw csr)
		   (cond ((> (time-difference (sys:%fixnum-microsecond-time)
					      start-time)
			     100000.)
			  (incf (3com-transmit-time-outs *3com-ethernet-interface*))
			  (return-from 3com-send-int-pkt-via-multibus nil))	;give up.
			 (t (go l))))))
	(without-interrupts
	  (cond ((ldb-test tbsw csr)
		 (incf (3com-buffer-not-available *3com-ethernet-interface*)))
		(t
		 (do ((adr beginning-address (the fixnum (+ adr 2)))
		      (from-index 0 (the fixnum (1+ from-index)))
		      (n n-16-bit-words (the fixnum (1- n))))
		     ((zerop n))
		   (declare (fixnum adr from-index n))
		   (let ((data (aref int-pkt from-index)))
		     (declare (fixnum data))
		     (sys:%multibus-write-8 adr (ldb (byte 8 0) data))
		     (sys:%multibus-write-8 (the fixnum (1+ adr)) (ldb (byte 8 8) data))))
		 (write-lambda-3com-frame-header 3com-transmit-buffer
						 offset
						 e-source
						 e-dest
						 e-type)
		 (write-3com-csr (dpb 1 tbsw 3com-csr-background-bits)))))
	t)
    (free-packet int-pkt)))

(defun 3com-packet-ready ()
  (and (i-own-3com)
       (if (lambda-ucode-enabled-p)
	   (net:int-receive-list)
	 (not (= 3 (ldb a+b-bsw (the fixnum (read-3com-csr))))))))

(defun 3com-get-next-packet ()
  (declare (values packet type source destination broadcast-p))
  (and (i-own-3com)
       (if (lambda-ucode-enabled-p)
	   (3com-get-next-pkt-via-ucode)
	 (3com-get-next-pkt-via-multibus))))

(defun 3com-get-next-pkt-via-ucode (&aux int-pkt byte-count)
  (declare (values packet type source destination broadcast-p))
  (when (setq int-pkt (int-pkt-list-get net:int-receive-list-pointer))
    (setf (net:int-pkt-thread int-pkt) nil)
    (let* (;;The int-pkt-csr2 is a fixnum that has the buffer-header as the low 16 bits, and the first
	   ;;9 bits of the destination address above them.  The first address bit is the multicast bit.
	   (int-csr2 (net:int-pkt-csr-2 int-pkt))
	   (csr2 (swap-two-bytes int-csr2))
	   (type (swap-two-bytes (net:int-pkt-bit-count int-pkt)))
	   (multicast-p (ldb-test (byte 1 16) int-csr2)))
      (unless (zerop (logand %%3com-buffer-header-error csr2))
	(incf (3com-fcs-errors *3com-ethernet-interface*))
	(return-from 3com-get-next-pkt-via-ucode nil))
      (setf (net:int-pkt-csr-2 int-pkt) csr2)
      (setf (net:int-pkt-bit-count int-pkt) type)
      (setq byte-count (ldb %%3com-buffer-header-nbytes csr2))
      (setf (fill-pointer int-pkt) (ceiling byte-count 2))
      (values int-pkt				; the packet
	      (net:int-pkt-bit-count int-pkt)	; the type code
	      0					; the sender
	      0					; the receiver
	      multicast-p			; only multicast address we're enabled on is broadcast address
	      ))))

(defun 3com-get-next-pkt-via-multibus (&aux (csr (read-3com-csr)))
  (declare (values packet type source destination broadcast-p))
  (multiple-value-bind (buffer BSW)
      (if (ldb-test rbba csr)
	  (cond ((zerop (ldb absw csr))
		 (values 3com-buffer-a ABSW))
		((zerop (ldb bbsw csr))
		 (values 3com-buffer-b BBSW))
		(t (return-from 3com-get-next-pkt-via-multibus nil)))
	(cond ((zerop (ldb bbsw csr))
	       (values 3com-buffer-b BBSW))
	      ((zerop (ldb absw csr))
	       (values 3com-buffer-a ABSW))
	      (t (return-from 3com-get-next-pkt-via-multibus nil))))
    (multiple-value-bind (int-pkt type source dest broadcast-p)
	(multibus-ethernet-receive-buffer buffer)
      (arm-3com-receive-buffer BSW)
      (values int-pkt
	      type
	      source
	      dest
	      broadcast-p
	      ))))

(defun multibus-ethernet-receive-buffer (buffer-base &aux int-pkt)
  (declare (values packet type source destination broadcast-p))
  (let* ((buffer-header (read-3com-buffer-header buffer-base))
	 ;;Header: 2 bytes buffer header 14 bytes ethernet header.  Trailer: 4 bytes FCS
	 (nbytes (- (ldb %%3com-buffer-header-nbytes buffer-header) 20.))
	 (type (read-frame-header-type buffer-base))
	 (source (read-frame-header-source buffer-base))
	 (dest (read-frame-header-destination buffer-base)))
    (unless (zerop (logand %%3com-buffer-header-error buffer-header))
      (incf (3com-fcs-errors *3com-ethernet-interface*))
      (return-from multibus-ethernet-receive-buffer nil))
    (when (setq int-pkt (allocate-packet-for-receive *3com-ethernet-interface*))
      (do ((adr (the fixnum (+ buffer-base 16.))
		(the fixnum (+ adr 2)))
	   (nwords (ceiling nbytes 2))
	   (wd-count 0 (the fixnum (1+ wd-count))))
	  ((>= wd-count nwords))
	(declare (fixnum adr wd-count))
	(setf (aref int-pkt wd-count) (dpb (sys:%multibus-read-8 (the fixnum (+ adr 1)))
					   (byte 8 8)
					   (sys:%multibus-read-8 adr))))
      (setf (fill-pointer int-pkt) (ceiling nbytes 2))
      (values int-pkt
	      type
	      source
	      dest
	      ;;The following SHOULD work, but the 3com board is broken...
	      ;;   (ldb-test %%3com-buffer-header-broadcast buffer-header)
	      (= dest *ethernet-broadcast-address*)
	      ))))

(defun setup-3com (tag &aux alist)
  (when (and (eq si:processor-type-code si:lambda-type-code)
	     (i-own-3com))
    
    (when *3com-ethernet-interface*
      (setq alist (3com-protocol-alist *3com-ethernet-interface*))
      (funcall *3com-ethernet-interface* :close))
    
    (setq *3com-ethernet-interface*
	  (make-3com-interface :tag tag
			       :interface :3com
			       :keyword :ethernet
			       :hardware-type net:arp-ethernet-hardware
			       :address-length 6
			       :address 0
			       :broadcast-address *ethernet-broadcast-address*
			       :minimum-data-length 46.
			       :maximum-data-length 1500.
			       :sent-header-length 0
			       :rcvd-header-length 0
			       :sent-trailer-length 0
			       :rcvd-trailer-length 0
			       :loopback t
			       :protocol-alist alist
			       :reset-function '3com-reset
			       :enable-function '3com-enable
			       :disable-function '3com-disable
			       :packet-ready-function '3com-packet-ready
			       :get-next-packet-function '3com-get-next-packet
			       :send-function  '3com-send-int-pkt
			       :gauge-name "3Com"
			       ))
    
    (funcall *3com-ethernet-interface* :open)
    (funcall *3com-ethernet-interface* :enable)))

(defun print-3com-csr ()
  (let ((csr (read-3com-csr)))
    (format t "~%Buf B belongs to ether: ~40t~d" (ldb bbsw csr))
    (format t "~%Buf A belongs to ether: ~40t~d" (ldb absw csr))
    (format t "~%Transmit buf belongs to ether: ~40t~d" (ldb tbsw csr))
    (format t "~%Jam: ~40t~d" (ldb jam csr))
    (format t "~%RAM valid: ~40t~d" (ldb amsw csr))
    (format t "~%A/B buffer ordering: ~40t~d" (ldb rbba csr))
    (format t "~%reset: ~40t~d" (ldb reset csr))	;probably write only
    (format t "~%Enable interrupts on B buffer: ~40t~d" (ldb binten csr))
    (format t "~%Enable interrupts on A buffer: ~40t~d" (ldb ainten csr))
    (format t "~%Enable interrupts on transmit buffer: ~40t~d" (ldb tinten csr))
    (format t "~%Enable interrupts on JAM: ~40t~d" (ldb jinten csr))
    (format t "~%pa: ~40t~d" (ldb pa csr))))

(defun print-3com-address-ram ()
  (unless (i-own-3com)
    (error "no ethernet present"))
  (dotimes (i 6)
    (format t "~16r " (sys:%multibus-read-8 (+ 3com-address-ram i)))))

(defun print-3com-address-rom ()
  (unless (i-own-3com)
    (error "no ethernet present"))
  (dotimes (i 6)
    (format t "~16r " (sys:%multibus-read-8 (+ 3com-address-rom i)))))

(defun print-rcv-buffer (buf)
  (let ((buf-base (case buf
		    ((a 0) 3com-buffer-a)
		    ((b 1) 3com-buffer-b))))
    (dotimes (i 24)
      (format t "~16r " (sys:%multibus-read-8 (+ buf-base i))))))

(defun print-xmit-buffer ()
  (let ((offset (dpb (sys:%multibus-read-8  3com-transmit-buffer)
		     (byte 8 8)
		     (sys:%multibus-read-8 (1+ 3com-transmit-buffer)))))
    (format t "offset = ~s ~:* #x~16r; " offset)
    (dotimes (i 24)
      (format t "~16r " (sys:%multibus-read-8 (+ 3com-transmit-buffer offset i))))))