;;;-*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*- 
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;

;;;
;;;   Stuff for the new LMI DEBUG Card (Kent Hoult's debug board)
;;;

;;; this is already in the diag defs-file
;;;

(defflavor nubus-via-lmi-debug ()
	   (access-path))

(defconst debug-slot #xfa)
(defconst debug-addr (ash debug-slot 24.))
(defconst debug-mode-reg-offset #xfff7fc)
(defconst debug-prom-offset #xfff800)

(defsubst read-debug (addr)
  (%nubus-read debug-slot addr))

(defsubst write-debug (addr data)
  (%nubus-write debug-slot addr data))

(defsubst read-debug-byte (addr)
  (sys:%nubus-read-8 debug-slot addr))

(defsubst write-debug-byte (addr data)
  (sys:%nubus-write-8 debug-slot addr data))


(defsubst read-debug-mode ()
  (logand #xff (read-debug #xfff7fc)))

(defsubst write-debug-mode (data)
  (write-debug #xfff7fc data))

(defsubst write-debug-addr (addr)
  (write-debug #xfff7f8 addr))

(defsubst read-debug-addr()
  (read-debug #xfff7f8))

(defsubst write-debug-data (data)
  (write-debug #xfff7f4 data))

(defsubst read-debug-response-data ()
  (read-debug #xfff7f4))

(defsubst write-debug-control (ctl)
  (write-debug #xfff7f0 ctl))

(defsubst read-debug-response-control ()
  (logand #x3f (read-debug #xfff7f0)))

(defsubst write-debug-analyzer-pointer (data)
  (write-debug #xfff7ec data))

(defsubst read-debug-analyzer-pointer ()
  (logand #x8fff (read-debug #xfff7ec)))

(defsubst read-debug-analyzer-data ()
  (read-debug #xfff7e8))

(defsubst write-debug-analyzer-data (data)
  (write-debug #xfff7e8 data))

(defsubst read-debug-analyzer-control ()
  (logand #xff (read-debug #xfff7e4)))

(defsubst write-debug-analyzer-control (data)
  (write-debug #xfff7e4 data))

(defsubst write-debug-analyzer-function (data)
  (write-debug #xfff7e0 data))

(defsubst read-debug-explorer-ram ()
  (logand #xffff (read-debug #xfff7cc)))

(defsubst write-debug-explorer-ram (data)
  (write-debug #xfff7cc data))

(defsubst read-debug-explorer-pointer ()
  (logand #xfff (read-debug #xfff7c8)))

(defsubst write-debug-explorer-pointer (data)
  (write-debug #xfff7c8 data))

(defsubst read-debug-explorer-control ()
  (read-debug #xfff7c4))

(defsubst write-debug-explorer-control (data)
  (write-debug #xfff7c4 data))

(defsubst read-debug-explorer-status ()
  (read-debug #xfff7c0))


(defun wait-for-debug-xmit ()
  (dotimes (i 1000.)
    (if (equal 0 (logand #x40 (read-debug-mode)))
	(return t))))


(defvar *lmi-debug-internal* nil)

(defun delay-for-lmi-debug-board ()
  (dotimes (i 10000.)
    (when (equal #x80 (logand #x80 (read-debug-mode)))
      (return t))))

  				    
(defun lmi-debug-nd-bus-read (adr &optional ignore-bus-errors byte-mode
		       &aux loop-until-it-works (start-time (time)))
  ;ignore-bus-errors ->
  ;  NIL  dont ignore anything.
  ;  :IGNORE-TIMEOUT
  ;  :IGNORE-PARITY
  ;  :IGNORE-EXCESSIVE-TRY-AGAIN-LATERS
  ;  T    ignore all
  (prog ()
   retry
      (write-debug-addr adr)
      (if byte-mode
	  (write-debug-control #x05)
	(write-debug-control #x01))
      (or (delay-for-lmi-debug-board) (ferror nil "~%Debug board not responding"))
      (case (read-debug-response-control)
	(2 ;try again later
	 (cond ((and (null loop-until-it-works)
		     (time-lessp 30. (time-difference (time) start-time)))
		(cond ((memq ignore-bus-errors '(T :IGNORE-EXCESSIVE-TRY-AGAIN-LATERS))
		       (return -1))
		      (t
		       (signal-proceed-case
			 (() 'nubus-timeout
			     "nubus try-again-later too many times: adr #x~16r"
			     adr 'try-again-later)
			 (:retry-bus-cycle
			  (setq start-time (time))
			  (go retry))
			 (:loop-until-it-works
			  (setq loop-until-it-works t)
			  (go retry))
			 (:ignore-bus-error-read (return -1))
			 ))))
	       (t
		(go retry))))
	(6					;bus timeout
	 (cond ((not (null loop-until-it-works))
		(go retry))
	       ((memq ignore-bus-errors '(T :IGNORE-TIMEOUT))
		(return -1))
	       (check-for-nubus-timeouts
		(signal-proceed-case
		  (() 'nubus-timeout
		      "nubus timeout: adr = #x~16r" adr 'nubus-timeout)
		  (:retry-bus-cycle (go retry))
		  (:loop-until-it-works
		   (setq loop-until-it-works t)
		   (go retry))
		  (:ignore-bus-error-read (return -1))
		  ))
	       (t
		(return -1))))
	(#xa					;parity error
	 (cond ((not (null loop-until-it-works))
		(go retry))
	       ((memq ignore-bus-errors '(T :IGNORE-PARITY))
		(return -1))
	       (check-for-nubus-timeouts
		(signal-proceed-case
		  (() 'nubus-timeout
			       "parity or other nubus error: adr = #x~x" adr 'parity-error)
		  (:retry-bus-cycle (go retry))
		  (:loop-until-it-works
		   (setq loop-until-it-works t)
		   (go retry))
		  (:ignore-bus-error-read (return -1))
		  ))
	       (t
		(return -1))))
	(#xe					;normal
	 (return (read-debug-response-data)
		 ))))
  )

(defun lmi-debug-nd-bus-write (adr data &optional ignore-bus-errors byte-mode
			&aux loop-until-it-works (start-time (time)))
  ;ignore-bus-errors ->
  ;  NIL  dont ignore anything.
  ;  :IGNORE-TIMEOUT
  ;  :IGNORE-PARITY
  ;  :IGNORE-EXCESSIVE-TRY-AGAIN-LATERS
  ;  T    ignore all
  (prog ()
     retry
	(let ((internal-control (if byte-mode #x2d #x29))
	      (external-control (if byte-mode #x0d #x09))
	      )
	  (write-debug-addr data)
	  (write-debug-control 8)
	  (wait-for-debug-xmit)
	  (write-debug-addr adr)
	  (if *lmi-debug-internal*
	      (write-debug-control internal-control)
	    (write-debug-control external-control)))
	(or (delay-for-lmi-debug-board) (ferror nil "~%Debug board not responding"))
	(case (read-debug-response-control)
	  (2
	   (cond ((and (null loop-until-it-works)
		       (time-lessp 30. (time-difference (time) start-time)))
		  (cond ((memq ignore-bus-errors '(T :IGNORE-EXCESSIVE-TRY-AGAIN-LATERS))
			 (return -1))
			(t 
			 (signal-proceed-case
			   (() 'nubus-timeout
			       "try-again-later too many times: adr=#x~x)"
			       adr 'try-again-later)
			   (:retry-bus-cycle
			    (setq start-time (time))
			    (go retry))
			   (:loop-until-it-works
			    (setq loop-until-it-works t)
			    (go retry))
			   (:ignore-bus-error (return -1))
			   ))))
		 (t
		  (go retry))))
	  (6					; bus timeout
	   (cond ((not (null loop-until-it-works))
		  (go retry))
		 ((memq ignore-bus-errors '(T :IGNORE-TIMEOUT))
		  (return -1))
		 (check-for-nubus-timeouts
		  (signal-proceed-case
		    (() 'nubus-timeout
			"nubus timeout: adr = #x~x)"
			adr 'nubus-timeout)
		    (:retry-bus-cycle (go retry))
		    (:loop-until-it-works
		     (setq loop-until-it-works t)
		     (go retry))
		    (:ignore-bus-error (return nil))))
		 (t
		  (return nil))))
	  (#x0A					; other bus error - maybe parity
	   (cond ((not (null loop-until-it-works))
		  (go retry))
		 ((memq ignore-bus-errors '(T :IGNORE-PARITY))
		  (return -1))
		 (check-for-nubus-timeouts
		  (signal-proceed-case
		    (() 'nubus-timeout
			"other nubus error (parity?): adr = #x~x)"
			adr 'parity-error)
		    (:retry-bus-cycle (go retry))
		    (:loop-until-it-works
		     (setq loop-until-it-works t)
		     (go retry))
		    (:ignore-bus-error (return nil))))
		 (t
		  (return nil))))
	  (#x0E					; normal
	   (return nil)))))


(defmethod (nubus-via-lmi-debug :bus-read)
	   (byte-address &optional ignore-bus-errors byte-mode)
  byte-mode
  (lmi-debug-nd-bus-read byte-address ignore-bus-errors))

(defmethod (nubus-via-lmi-debug :bus-read-byte)
	   (byte-address &optional ignore-bus-errors)
  (let ((data (lmi-debug-nd-bus-read byte-address ignore-bus-errors t)))
    (ldb (byte 8 (* (ldb (byte 2 0) byte-address) 8)) data)))


(defmethod (nubus-via-lmi-debug :bus-slot-read)
	   (slot byte-address &optional ignore-bus-errors byte-mode)
  (lmi-debug-nd-bus-read (+ #xf0000000 (ash slot 24.) byte-address) ignore-bus-errors byte-mode))

(defmethod (nubus-via-lmi-debug :bus-slot-read-byte)
	   (slot byte-address &optional ignore-bus-errors)
  (let ((data (lmi-debug-nd-bus-read (+ #xf0000000
					(ash slot 24.)
					byte-address)
				     ignore-bus-errors t)))
    (ldb (byte 8 (* (ldb (byte 2 0) byte-address) 8)) data)))

(defmethod (nubus-via-lmi-debug :bus-quad-slot-read)
	   (quad-slot byte-address &optional ignore-bus-errors byte-mode)
  (lmi-debug-nd-bus-read (dpb quad-slot (byte 8 24.) byte-address) ignore-bus-errors byte-mode))

(defmethod (nubus-via-lmi-debug :bus-quad-slot-read-byte)
	   (quad-slot byte-address &optional ignore-bus-errors)
  (let ((data (lmi-debug-nd-bus-read (dpb quad-slot (byte 8 24.) byte-address)
				     ignore-bus-errors t)))
    (ldb (byte 8 (* (ldb (byte 2 0) byte-address) 8)) data)))    

(defmethod (nubus-via-lmi-debug :bus-write)
	   (byte-address data &optional ignore-bus-errors byte-mode)
  (lmi-debug-nd-bus-write byte-address data ignore-bus-errors byte-mode))

(defmethod (nubus-via-lmi-debug :bus-write-byte)
	   (byte-address data &optional ignore-bus-errors)
  (lmi-debug-nd-bus-write byte-address
			  (dpb data (byte 8 (* (ldb (byte 2 0) byte-address) 8)) 0)
			  ignore-bus-errors t))

(defmethod (nubus-via-lmi-debug :bus-slot-write)
	   (slot byte-address data &optional ignore-bus-errors byte-mode)
  ignore-bus-errors byte-mode
  (lmi-debug-nd-bus-write (+ #xf0000000 (ash slot 24.) byte-address) data))

(defmethod (nubus-via-lmi-debug :bus-slot-write-byte)
	   (slot byte-address data &optional ignore-bus-errors)
  (lmi-debug-nd-bus-write (+ #xf0000000 (ash slot 24.) byte-address)
			  (dpb data (byte 8 (* (ldb (byte 2 0) byte-address) 8)) 0)
			  ignore-bus-errors t))

(defmethod (nubus-via-lmi-debug :bus-quad-slot-write)
	   (quad-slot byte-address data &optional ignore-bus-errors byte-mode)
  ignore-bus-errors byte-mode
  (lmi-debug-nd-bus-write (dpb quad-slot (byte 8 24.) byte-address) data))

(defmethod (nubus-via-lmi-debug :bus-quad-slot-write-byte)
	   (quad-slot byte-address data &optional ignore-bus-errors)
  (lmi-debug-nd-bus-write (dpb quad-slot (byte 8 24.) byte-address)
			  (dpb data (byte 8 (* (ldb (byte 2 0) byte-address) 8)) 0)
			  ignore-bus-errors t))

(defmethod (nubus-via-lmi-debug :multibus-byte-read) (adr)
  (send self :bus-read-byte (+ adr #xff000000)))

(defmethod (nubus-via-lmi-debug :multibus-byte-write) (adr data)
  (send self :bus-write-byte (+ adr #xff000000) data))

;;;;;;
;;;;;;;; these are the new things now
;;;;;;
;;;;;;




;;; the next flavors are for the nu debug cards - already added to the diag-defs file.

(defflavor nubus-via-lmi-debug
	   ()
	   (access-path)
  )

(defflavor lambda-via-lmi-debug
	 (slot-number
	  (speed :fast)
	  (mode :remote))
	 (nubus-via-lmi-debug regint-hh)
  :settable-instance-variables
  )

(defmethod (lambda-via-lmi-debug :interface-reset) ()
  "Initializes the local and foreign debug cards. The speed defaults to :fast
and the mode to :remote"
  (init-debug-board slot-number speed mode)
  )

(defmethod (lambda-via-lmi-debug :single-step) ()
  (ENABLE-LAMBDA-SINGLE-STEPPING T)
  (ADVANCE-UINST)
  (DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP))

(defmethod (lambda-via-lmi-debug :halted-p) ()
  (let ((con-reg (read-con-reg)))
    (or (not (zerop (ldb halt-request-bit con-reg)))
	(zerop (ldb any-parity-error-synced-l-bit con-reg))
	)))

(defun set-speed-for-lmi-debug (speed)
  "Set the speed for the debug interface. Only two value :slow or :fast"
  (write-debug-mode
    (dpb (selectq speed
	 (:slow 0)
	 (:fast 1)
	 (otherwise (ferror nil "~%~S is not a know speed" speed)))
       (byte 1 4)
       (read-debug-mode)))
  )

(defun set-mode-for-lmi-debug (mode)
  "Set debug mode either :remote or :local for debug interface"
  (write-debug-mode
    (dpb (selectq mode
	   (:remote 0)
	   (:local 1)
	   (otherwise (ferror nil "~%~S is not a know mode" mode)))
	 (byte 1 3)
	 (read-debug-mode)))
  )

(defun read-remote-config-prom (slot &aux s)
  (setq s "LMI DEBUG BOARD")
  (if (symbolp (lmi-debug-nd-bus-read (dpb slot (byte 8. 24.) debug-prom-offset) t))
      (setq s nil)
    (dotimes (i 15.)
       (aset
	 (logand
	   #xff
	   (lmi-debug-nd-bus-read (dpb slot (byte 8. 24.) (+ debug-prom-offset (* i 4))) t))
	 s i)))
  s)

(defun init-debug-board (slot speed mode)
  "Initializes the debug hardware"
  (setq debug-slot (dpb #xf (byte 4 4) slot))	;
  (write-debug-mode 1)				; reset the board
  (write-debug-mode 2)
  (set-speed-for-lmi-debug speed)
  (set-mode-for-lmi-debug mode)
  (process-sleep 2)				; let it idle down
  (read-debug-response-control)
  (write-debug-analyzer-function 0)
  (read-debug-analyzer-data)
  (reset-remote-debug-board (read-debug-mode)))



(defun reset-remote-debug-board (new-mode &aux slot)
  "Finds and initializes all debug boards on foreign rack"
  (dotimes (i 16.)
    (setq slot (logior i #xf0))
;    (format t "~%Slot ~D ~A" i (read-remote-config-prom slot))
    (when (equal "LMI DEBUG BOARD" (read-remote-config-prom slot))
      (setq *lmi-debug-internal* t)
      (lmi-debug-nd-bus-write (dpb slot (byte 8. 24.) debug-mode-reg-offset) new-mode t)
      (setq *lmi-debug-internal* nil))
  ))