;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-


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


;defflavor for regint-lambda moved to diag-system

(defmethod (regint-lambda :reset) ()
  (WRITE-CON-REG 1)	;WRITES 1 TO THE INIT-BIT.  This is necessary
  nil)		;to reset parity errors on the new boards.  This also resets
		;sm-clock-enable and nu-master, which should be OK since machine
		;is stopped anyway..

(defmethod (regint-lambda :read-mfo) ()
  lam-saved-mfobus)

;also works to give adr with func-src indicator
(defmethod (regint-lambda :read-m-mem) (adr)
  (read-m-mem adr))

(defmethod (regint-lambda :write-m-mem) (adr data)
  (write-m-mem adr data))

(defmethod (regint-lambda :read-a-mem) (adr)
  (read-a-mem adr))

(defmethod (regint-lambda :read-d-mem) (adr)
  (read-a-mem adr))

(defmethod (regint-lambda :write-a-mem) (adr data)
  (write-a-mem adr data))

(defmethod (regint-lambda :write-d-mem) (adr data)
  (write-a-mem adr data))

(defmethod (regint-lambda :read-c-mem) (adr)
  (let ((page (send self :read-cam (ash adr -4))))
    (cond ((= page micro-fault-page)
	   (let ((paging-base (qf-initial-area-origin 'MICRO-CODE-PAGING-AREA)))
	     (+ (ash (qf-mem-read (+ paging-base (* adr 2) 1)) 32.)
		(qf-mem-read (+ paging-base (* adr 2))))))
	  (t
	   (read-cram adr)))))

(defmethod (regint-lambda :write-c-mem) (adr data)
  (let ((page (send self :read-cam (ash adr -4))))
    (cond ((= page micro-fault-page)
	   (let ((paging-base (qf-initial-area-origin 'MICRO-CODE-PAGING-AREA)))
	     (qf-mem-write (+ paging-base (* adr 2))
				   (logand #o37777777777 data))
	     (qf-mem-write (+ paging-base (* adr 2) 1)
				   (logand #o37777777777 (ash data -32.)))))
	  (t
	   (write-cram adr data)))))

(defmethod (regint-lambda :read-q-reg) ()
  (read-q-reg))

(defmethod (regint-lambda :write-q-reg) (data)
  (write-q-reg data))

(defmethod (regint-lambda :read-md) ()
  lam-saved-md)

(defmethod (regint-lambda :read-md-from-hardware) ()
  (read-md))

(defmethod (regint-lambda :write-md) (data)
  (setq lam-saved-md data))

(defmethod (regint-lambda :write-md-to-hardware) (data)
  (write-md data))

(defmethod (regint-lambda :read-vma) ()
  lam-saved-vma)

(defmethod (regint-lambda :read-vma-from-hardware) ()
  (read-vma))

(defmethod (regint-lambda :write-vma) (data)
  (setq lam-saved-vma data))

(defmethod (regint-lambda :write-vma-to-hardware) (data)
  (write-vma data))

(defmethod (regint-lambda :read-pdl-buffer) (adr)
  (lam-save-pdl-buffer-index)
  (write-pi-and-read-c-pi adr))

(defmethod (regint-lambda :write-pdl-buffer) (adr data)
  (if (null lam-saved-pdl-buffer-index)
      (lam-save-pdl-buffer-index))
  (write-pi-and-write-c-pi adr data))

(defmethod (regint-lambda :read-pi) ()
  (or lam-saved-pdl-buffer-index
      (setq lam-saved-pdl-buffer-index (read-pi))))

(defmethod (regint-lambda :read-pi-from-hardware) ()
  (read-pi))

(defmethod (regint-lambda :write-pi) (data)
  (setq lam-saved-pdl-buffer-index data))

(defmethod (regint-lambda :write-pi-to-hardware) (data)
  (write-pi data))

(defmethod (regint-lambda :read-pp) ()
  (read-pp))

(defmethod (regint-lambda :write-pp) (data)
  (write-pp data))

(defmethod (regint-lambda :read-pc-from-hardware) ()
  (read-pc))

(defmethod (regint-lambda :read-pc) ()
  lam-saved-pc)

(defmethod (regint-lambda :write-pc) (adr &optional (n-bit 1))
  (setq lam-saved-pc adr)
  (if (zerop n-bit)
      (setq lam-noop-flag nil)
    (setq lam-noop-flag t)))

(defmethod (regint-lambda :write-pc-to-hardware) (adr &optional (n-bit 1))
  (write-pc adr n-bit))

(defmethod (regint-lambda :save-l1-map-0) ()
  (unless lam-saved-level-1-map-loc-0
    (setq lam-saved-level-1-map-loc-0 (read-level-1-map 0))))

(defmethod (regint-lambda :read-l1-map) (adr)
  (cond ((and lam-saved-level-1-map-loc-0
	      (zerop adr))
	 lam-saved-level-1-map-loc-0)
	(t
	 (read-level-1-map adr))))

(defmethod (regint-lambda :write-l1-map) (adr data)
  (lam-save-level-1-map-loc-0)
  (cond ((zerop adr)
	 (setq lam-saved-level-1-map-loc-0 data))
	(t
	 (write-level-1-map adr data))))

(defmethod (regint-lambda :read-l2-map-control) (adr)
  (lam-save-level-1-map-loc-0)
  (read-level-2-map-control adr))

(defmethod (regint-lambda :write-l2-map-control) (adr data)
  (lam-save-level-1-map-loc-0)
  (write-level-2-map-control adr data))

(defmethod (regint-lambda :read-l2-map-physical-page) (adr)
  (lam-save-level-1-map-loc-0)
  (read-level-2-map-physical-page adr))

(defmethod (regint-lambda :write-l2-map-physical-page) (adr data)
  (lam-save-level-1-map-loc-0)
  (write-level-2-map-physical-page adr data))

(defmethod (regint-lambda :read-usp) ()
  (or lam-saved-micro-stack-ptr
      (setq lam-saved-micro-stack-ptr
	    (read-usp))))

(defmethod (regint-lambda :write-usp) (data)
  (setq lam-saved-micro-stack-ptr data))

(defmethod (regint-lambda :write-usp-to-hardware) (data)
  (write-usp data))

(defmethod (regint-lambda :read-us) (adr)
  (LAM-SAVE-MICRO-STACK-PTR)
  (read-us Adr))

(defmethod (regint-lambda :write-us) (adr data)
  (LAM-SAVE-MICRO-STACK-PTR)
  (write-us adr data))

(defmethod (regint-lambda :read-lc) ()
  (read-lc))

(defmethod (regint-lambda :write-lc) (data)
  (write-lc data))

(defmethod (regint-lambda :read-macro-ir) ()
  (let ((lc (read-lc)))
    (prog1 (read-full-macro-ir)
	   (write-lc lc))))

(defmethod (regint-lambda :write-macro-ir) (data)
  (write-macro-ir data))

(defmethod (regint-lambda :read-stat-counter) ()
  (read-stat-counter))

(defmethod (regint-lambda :write-stat-counter) (data)
  (write-stat-counter data))

(defmethod (regint-lambda :read-aux-stat-counter) ()
  (read-aux-stat-counter))

(defmethod (regint-lambda :write-aux-stat-counter) (data)
  (write-aux-stat-counter data))

(defmethod (regint-lambda :read-dc) ()
  (read-dispatch-constant))

(defmethod (regint-lambda :write-dc) (data)
  (let ((a-mem-1 (read-a-mem 1)))
    (write-a-mem 1 0)
    (write-dispatch-constant data)
    (write-a-mem 1 a-mem-1)))

(defmethod (regint-lambda :read-mid) (adr)
  (let ((lc (read-lc))
	(macro-ir (read-full-macro-ir)))
    (prog1 (read-mid-full adr)
	   (write-macro-ir macro-ir)
	   (write-lc lc))))

(defmethod (regint-lambda :write-mid) (adr data)
  (let ((lc (read-lc))
	(macro-ir (read-full-macro-ir)))
    (prog1 (write-mid-full adr data)
	   (write-macro-ir macro-ir)
	   (write-lc lc))))

(defmethod (regint-lambda :read-cam) (adr)
  (read-cram-adr-map adr))

(defmethod (regint-lambda :write-cam) (adr data)
  (write-cam-with-good-parity adr data))

(defmethod (regint-lambda :read-ireg) ()
  lam-saved-ir)

(defmethod (regint-lambda :read-ireg-from-hardware) ()
  (read-ireg))

(defmethod (regint-lambda :write-ireg) (data)
  (setq lam-saved-ir data))

(defmethod (regint-lambda :write-ireg-to-hardware) (data)
  (write-ireg-with-good-parity data))

(defmethod (regint-lambda :write-func-dest) (adr data)
  (WRITE-SPY-REG-AND-CHECK DATA)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-FUNC-DEST ADR))
;---


(defmethod (regint-lambda :stop-mach) ()
  (if (eq lam-running t)
      (setq lam-running-check-parity check-parity))
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':tyo #\space)
	 (cond ((eq lam-running t)
		(setq lam-running 'trying-to-stop)
		(funcall *proc* ':read-32 0))))
	(t
	 (let ((con-reg (read-con-reg)))
	   (cond ((zerop (ldb any-parity-error-synced-l-bit con-reg))
		  (format t "~%!!Stopped by parity error!!")
		  (print-regs)
		  (print-parity)
		  (break "PARITY-ERROR, will do reset on continue")
		  (send self :reset)
		  (format t "~%SETQing CHECK-PARITY to NIL")
		  (setq check-parity nil)
		  )))))

  (SET-SINGLE-STEP-MODE)			;DOING THIS FIRST AVOIDS POSSIBILITY
						; OF STOPPING CSM IN MIDDLE OF
						; A MEMORY CYCLE AND HANGING NUBUS.		
  (DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP)

  (cond ((t-hold-p)
	 (let ((tem (read-csm-adr)))
	   (format t "~&T-HOLD is stuck on: csmadr: ~o  ~s"
		   TEM (CSM-SYMBOLIC-LOCATION (LOGAND 3777 TEM))))
	 (format t "~2&type resume to do")
	 (format t "~2&     (reset-mi)")
	 (format t "~&     (lam-reset-cache)")
	 (break "GET-THOLD-UNSTUCK")
	 (reset-mi)
	 (lam-reset-cache)
	 (if (t-hold-p)
	     (ferror nil "t-hold still on after (reset-mi) and (lam-reset-cache)"))))
		  
  (SETQ LAM-RUNNING 'SM-STEP))


(defmethod (regint-lambda :start-mach) ()
  (lam-full-restore)		;RESTORE MACHINE IF TRYING TO RUN
  (cond ((and lam-running-check-parity
	      (null check-parity))
	 (format t "~%Turning on CHECK-PARITY")
	 (setq check-parity lam-running-check-parity)))
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':string-out "1R")
	 (funcall *proc* ':read-32)
	 (FUNCALL *PROC* ':STRING-OUT "0h"))
	(T
	 (ENABLE-LAMBDA-AND-NU-MASTER)))
  (SETQ LAM-RUNNING T))

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

(defmethod (regint-lambda :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))
	)))

;SAVE THINGS WHICH CAN BE SAVED WITHOUT MODIFYING THE STATE OF THE MACHINE
(defmethod (regint-lambda :passive-save) ()
  (cond ((not lam-passive-save-valid)
	 (setq lam-saved-pdl-buffer-index nil)		;FIRST OF ALL, CLEAR FLAGS
	 (setq lam-saved-micro-stack-ptr nil)		; WHICH MARK AUXILIARY PORTIONS
					 		; OF THE MACHINE NEED RESTORATION
	 (setq lam-saved-level-1-map-loc-0 nil)
	 (setq lam-vma-changed-flag nil)	;MRD ALMOST ALWAYS CHANGED, ALWAYS RESTORE IT
	 (setq lam-saved-opcs-valid nil)

	 (setq lam-saved-hptr (read-hptr 0))	;THIS MUST HAPPEN BEFORE THE FIRST
						; UINST CLOCK				
						;dont compare this in replay mode.
	 (setq lam-saved-parity-enables (ldb parity-enable-field (read-pmr)))
	 (setq lam-saved-parity-vector (read-parity))
	 (setq lam-saved-mfobus (read-mfo))
	 (setq lam-saved-pc (read-pc))
	 (setq lam-saved-ir (read-ireg))
	 (setq lam-noop-flag (noop-p))

	 (setq lam-passive-save-valid t))))



(defmethod (regint-lambda :full-save) ()
  (cond ((not lam-full-save-valid)
	 (lam-stop-mach)	;This winds up doing a DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP,
	 (lam-passive-save)	; which sets parity mode for internal operations.
         (write-ireg izero-good-parity)	;single step two noops to avoid hanging
	 (lam-single-step)	;  CSM if LC fetch about to happen
	 (write-ireg izero-good-parity)
	 (lam-single-step)
	 (write-pc 0)		;TRY TO AVOID CLOBBERAGE OF MACRO-IR
	 (ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
	 (lam-save-mem-status)
	 (setq lam-saved-macro-ir (lam-read-macro-ir))
	 (setq lam-full-save-valid t))))

(defmethod (regint-lambda :dummy-full-save) ()
  (cond ((not lam-full-save-valid)
	 (setq lam-running 'sm-step)	;NOT RUNNING NOW
	 (lam-dummy-passive-save)
	 (write-pc 0)		;TRY TO AVOID CLOBBERAGE OF MACRO-IR
	 (assure-noop-cleared-and-no-carryover)
	 (lam-dummy-save-mem-status)
	 (setq lam-saved-macro-ir 0)
	 (SETQ LAM-FULL-SAVE-VALID T))))


(defmethod (regint-lambda :full-restore) ()
  (cond (lam-full-save-valid
	 (when lam-saved-micro-stack-ptr
	   (send self :write-usp-to-hardware lam-saved-micro-stack-ptr)
	   (setq lam-saved-micro-stack-ptr nil))
	 (if lam-saved-pdl-buffer-index
	     (write-pi lam-saved-pdl-buffer-index))
	 (setq lam-saved-pdl-buffer-index nil)
	 (lam-write-macro-ir lam-saved-macro-ir)
	 (lam-restore-mem-status)
	 (setq lam-full-save-valid nil)))
  (cond (lam-passive-save-valid
	 (write-pc (ldb (byte 16. 0) (1- lam-saved-pc)))  ;an approximation. winds up
						;in LPC register.
	 (write-pc lam-saved-pc (if lam-noop-flag 1 0))
	 (write-ireg-with-good-parity lam-saved-ir)
	 (force-tram-to-redo-source-cycle)   ;in case single step set
	 (if (uinst-clock-low-p)
	     (spy-write 13 lam-saved-hptr)	;write-hptr
	   (format t "~&couldn't restore hptr in lam-full-restore"))))
  (setq lam-passive-save-valid nil)
  )


(defmethod (regint-lambda :save-opcs) (&optional count)
  (if (null count)
      (setq count (cond ((access-path-lmi-serial-protocol *proc*) 20)
			(t  LAM-NUMBER-OF-SAVED-OPCS))))
  (setq count (min count (array-length lam-saved-opcs)))
  (dotimes (i (- raopce raopco))
    (aset 0 lam-saved-opcs i))
  (copy-hram-to-array lam-saved-opcs 0 count (1- lam-saved-hptr))
  (setq lam-saved-opcs-valid t))


(defmethod (regint-lambda :save-mem-status) ()
  (SETQ LAM-SAVED-VMA (READ-VMA 0))
  (SETQ LAM-SAVED-MD (READ-MD 0))
  )

(defmethod (regint-lambda :RESTORE-MEM-STATUS) ()
  (IF LAM-SAVED-LEVEL-1-MAP-LOC-0
      (WRITE-LEVEL-1-MAP 0 LAM-SAVED-LEVEL-1-MAP-LOC-0))
  (SETQ LAM-SAVED-LEVEL-1-MAP-LOC-0 NIL)
  (IF LAM-VMA-CHANGED-FLAG
      (WRITE-VMA LAM-SAVED-VMA))
  (SETQ LAM-VMA-CHANGED-FLAG NIL)
  (WRITE-MD LAM-SAVED-MD)
  ;If we haven't executed any memory cycles via the processor, the page fault
  ;status bits will still be good.  If we have, tough noogies.  Attempting to
  ;restore them will bash the MD register and probably isn't needed anyway.
)


(defmethod (regint-lambda :read-opc) (adr)
  (COND ((NULL LAM-SAVED-OPCS-VALID)
	 (LAM-SAVE-OPCS)))
  (AREF LAM-SAVED-OPCS adr))

(defmethod (regint-lambda :release-halt) ()
  (IF (LDB-TEST LAM-IR-HALT LAM-SAVED-IR)
      (SETQ LAM-SAVED-IR
	    (COMPUTE-PARITY-64 (DPB 0 LAM-IR-HALT LAM-SAVED-IR)))))