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


;;this file contains diagnostics for the dispatch operation.


(DEFUN READ-A-MEM-VIA-DISPATCH (&OPTIONAL
		 (DISPATCH-ADDRESS 0)
		 (BYTE-WIDTH 0)			;A WIDTH OF 0 IS USEFUL FOR DIAGNOSTICS 
		 (BITS-OVER 0)
		 (CONSTANT 0)
		 (PUSH-LPC 1))
  (LAM-EXECUTE (UINST-CLOCK)
	       LAM-IR-OP LAM-OP-DISPATCH
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-DISP-BYTL BYTE-WIDTH
	       LAM-IR-DISP-ADDR DISPATCH-ADDRESS
	       LAM-IR-DISP-LPC PUSH-LPC
	       LAM-IR-MROT (- 40 BITS-OVER)
	       LAM-IR-DISP-DISPATCH-CONSTANT CONSTANT)
  (READ-PC))

(DEFUN DISPATCH-STEPPING (&OPTIONAL
		 (DISPATCH-ADDRESS 0)
		 (BYTE-WIDTH 0)			;A WIDTH OF 0 IS USEFUL FOR DIAGNOSTICS 
		 (BITS-OVER 0)
		 (CONSTANT 0)
		 (PUSH-LPC 1))
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-DISPATCH
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-DISP-BYTL BYTE-WIDTH
	       LAM-IR-DISP-ADDR DISPATCH-ADDRESS
	       LAM-IR-DISP-LPC PUSH-LPC
	       LAM-IR-MROT (- 40 BITS-OVER)
	       LAM-IR-DISP-DISPATCH-CONSTANT CONSTANT)
  (SM-STEP-LOOP))

(defun read-a-mem-via-dispatch-ior (adr)
  (write-q-reg adr)
  (lam-execute (uinst-clock)
	       lam-ir-op lam-op-dispatch
	       lam-ir-m-src lam-m-src-q
	       lam-ir-disp-bytl 10
	       lam-ir-disp-addr 0
	       lam-ir-mrot 0)
  (read-pc))

(defun read-a-mem-via-dispatch-ior-stepping (adr)
  (write-q-reg adr)
  (lam-execute (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       lam-ir-op lam-op-dispatch
	       lam-ir-m-src lam-m-src-q
	       lam-ir-disp-bytl 10
	       lam-ir-disp-addr 0
	       lam-ir-mrot 0)
  (sm-step-loop))



;;DATA PATH TEST OF THE DISPATCH MEMORY, READ VIA THE DBUS TO THE PC
;;USES LOCATION 1 OF A/DISPATCH MEMORY

(DEFSELECT (DISPATCH-ACTOR)			;WRITE DIRECTLY,READ BY DISPATCHING AND
  (:READ (ADDRESS) address				;THEN READING THE PC
    (READ-A-MEM-VIA-DISPATCH 1))
  (:WRITE (ADDRESS DATA) address				
    (WRITE-A-MEM 1 DATA)))

(DEFUN TEST-DISPATCH-DATA-PATH ()
  (TEST-DATA-PATH "DISPATCH" 'DISPATCH-ACTOR 16.))

;this one tests dispatch-base register
(DEFUN FAST-ADDRESS-TEST-DISPATCH NIL
  (LET ((OFFSET 0)
	(N-DATA-BITS 16.)
	(N-ADDRESS-BITS 12.)
	(READ-FCTN 'READ-A-MEM-VIA-DISPATCH)
	(WRITE-FCTN 'WRITE-A-MEM)
	(MESSAGE "FAST-ADDRESS-TEST of Dispatch-memory"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)))

(defun fast-address-test-dispatch-ior (&optional zero-all)
  (cond (zero-all
	 (format t "~%Zeroing 256 locations of A mem")
	 (dotimes (a 400)
	   (write-a-mem a 0)))
	(T
	 (WRITE-A-MEM 0 0)
	 (dotimes (a 8)
	   (write-a-mem (LSH 1 A) 0))))
  (format t "~%Now beginning test")
  (let ((offset 0)
	(n-data-bits 16.)
	(n-address-bits 8.)
	(read-fctn 'read-a-mem-via-dispatch-ior)
	(write-fctn 'write-a-mem)
	(message "FAST-ADDRESS-TEST of Dispatch-memory via IOR"))
    (fast-address-test-kernal write-fctn read-fctn
			      offset n-data-bits n-address-bits message)))

;;DATA PATH TEST OF DISPATCH CONSTANT

;NOTE, THIS DOES A DISPATCH ON 1@A, WHICH BETTER HAVE SOMETHING REASONABLE.
(DEFUN WRITE-DISPATCH-CONSTANT (DATA)
  (READ-A-MEM-VIA-DISPATCH 1 0 0 DATA 0))

(DEFUN READ-DISPATCH-CONSTANT ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-DISP-CONST)
  (READ-MFO))

(DEFUN TEST-DISPATCH-CONSTANT-DATA-PATH ()
  (WRITE-A-MEM 1 0)		;AVOID RANDOMNESS WHEN ATTEMPTING TO LOAD DISPATCH CONSTANT.
  (TEST-DATA-PATH "DISPATCH CONSTANT" 'DISPATCH-CONSTANT-ACTOR 12.))

(DEFSELECT (DISPATCH-CONSTANT-ACTOR)
  (:READ (ADDRESS) ADDRESS
   (READ-DISPATCH-CONSTANT))
  (:WRITE (ADDRESS DATA) ADDRESS
   (WRITE-DISPATCH-CONSTANT DATA)))

(defun test-dispatch-write-vma-data-path ()
  (test-data-path "dispatch write vma" 'dispatch-write-vma-actor 32.))

(defselect (dispatch-write-vma-actor)
  (:read (address) address
    (read-vma))
  (:write (address data) address
    (write-vma-via-dispatch data)))

(defun write-vma-via-dispatch (data)
  (write-a-mem 1 0)
  (write-m-mem 2 data)
  (lam-execute (write)
	       lam-ir-op lam-op-dispatch
	       lam-ir-m-src 2
	       lam-ir-disp-bytl 0
	       lam-ir-disp-addr 1
	       lam-ir-disp-write-vma 1))

    
;;
(defun disp-loop (disp-loc)
  (write-a-mem 1 disp-loc)
  (do ()(())
    (read-a-mem-via-dispatch 1)))

(defun test-dispatch-push-returns nil
  (test-dispatch-push-return-data-path)
  (test-dispatch-push-return-with-xct-next-data-path)
  (test-dispatch-push-own-address-data-path)
  (test-dispatch-push-own-address-with-xct-next-data-path))

(defun test-dispatch-push-return-data-path ()
  (test-data-path "dispatch push return" 'dispatch-push-return-actor 16.))

(defselect (dispatch-push-return-actor)
  (:read (address) address
    (read-top-of-us))
  (:write (address data) address
    (write-us-via-dispatch data nil nil)))

(defun test-dispatch-push-return-with-xct-next-data-path ()
  (test-data-path "dispatch push return with xct next"
		  'dispatch-push-return-with-xct-next-actor
		  16))

(defselect (dispatch-push-return-with-xct-next-actor)
  (:read (address) address
    (low-16-bits (1- (read-top-of-us))))   ;thing pushed was incremented.
  (:write (address data) address
    (write-us-via-dispatch data t nil)))

(defun test-dispatch-push-own-address-data-path ()
  (test-data-path "dispatch push own address" 'dispatch-push-own-address-actor 16.))

(defselect (dispatch-push-own-address-actor)
  (:read (address) address
    (low-16-bits (1+ (read-top-of-us))))    ;thing pushed was decremented.
  (:write (address data) address
    (write-us-via-dispatch data nil t)))

(defun test-dispatch-push-own-address-with-xct-next-data-path ()
  (test-data-path "dispatch push own address with xct-next"
		  'dispatch-push-own-address-with-xct-next-actor 16.))

(defselect (dispatch-push-own-address-with-xct-next-actor)
  (:read (address) address
    (read-top-of-us))			;incremented and decremented cancel.
  (:write (address data) address
    (write-us-via-dispatch data t t)))

;Avoid leaving uinst clock high.  This works by forcing T.HOLD

(defun write-us-via-dispatch (pc-at-disp &optional using-xct-next own-address)
  (write-m-mem 1 (dpb 1 lam-disp-p-bit (dpb (if using-xct-next 0 1) lam-disp-n-bit 0)))
    ;decrement pc and clock machine so LPC gets a chance to be the right thing.
  (write-pc (low-16-bits (- pc-at-disp 1)))
  (lam-execute-uinst-clock-plus-uinst-clock-low 0 t)
  (cond ((not (= (low-16-bits pc-at-disp) (read-pc)))
	 (format t "~%PC was not right at dispatch, was ~s" (read-pc))))
  (lam-execute (write)
	       lam-ir-op lam-op-dispatch
	       lam-ir-disp-lpc (if own-address 1 0)
	       lam-ir-disp-addr 1))
  

(defun write-us-via-dispatch-stepping (pc-at-disp &optional using-xct-next
		 (DISPATCH-ADDRESS 0)
		 (BYTE-WIDTH 0)			;A WIDTH OF 0 IS USEFUL FOR DIAGNOSTICS 
		 (BITS-OVER 0)
		 (CONSTANT 0)
		 (PUSH-LPC 1))
  (write-m-mem 1 (dpb 1 lam-disp-p-bit (dpb (if using-xct-next 0 1) lam-disp-n-bit 0)))
    ;decrement pc and clock machine so LPC gets a chance to be the right thing.
  (write-pc (low-16-bits (- pc-at-disp 1)))
  (lam-execute-uinst-clock 0 t)
;;  (lam-execute-uinst-clock-plus-uinst-clock-low 0 t)
  (cond ((not (= (low-16-bits pc-at-disp) (read-pc)))
	 (format t "~%PC was not right at dispatch, was ~s" (read-pc))))
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-DISPATCH
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-DISP-BYTL BYTE-WIDTH
	       LAM-IR-DISP-ADDR DISPATCH-ADDRESS
	       LAM-IR-DISP-LPC PUSH-LPC
	       LAM-IR-MROT (- 40 BITS-OVER)
	       LAM-IR-DISP-DISPATCH-CONSTANT CONSTANT)
  (SM-STEP-LOOP))




(defun dispatch-push-own-address-stepping (pc-at-disp &optional using-xct-next own-address)
  (write-m-mem 1 (dpb 1 lam-disp-p-bit (dpb (if using-xct-next 0 1) lam-disp-n-bit 0)))
    ;decrement pc and clock machine so LPC gets a chance to be the right thing.
  (write-pc (low-16-bits (- pc-at-disp 1)))
  (lam-execute-uinst-clock-plus-uinst-clock-low 0 t)
  (cond ((not (= (low-16-bits pc-at-disp) (read-pc)))
	 (format t "~%PC was not right at dispatch, was ~s" (read-pc))))
  (lam-execute (executor lam-execute-noclocks)
	       lam-ir-op lam-op-dispatch
	       lam-ir-disp-lpc (if own-address 1 0)
	       lam-ir-disp-addr 1)
  (sm-step-loop))