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


;;this file contains diagnostics for the microstack (us, usp)


;;first the basic read/write functions usp 8 bits, us 20 bits


(defun read-usp ()				;notice that you can read us and usp together
  (LAM-EXECUTE (READ)				;this isnt used at the moment, but might be
	       LAM-IR-OP LAM-OP-ALU		;useful later
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK
	       LAM-IR-ALUF LAM-ALU-SETM)
  (ash (READ-MFO) -24.))


(defun us-push (&OPTIONAL (DATA 0))
  (WRITE-SPY-REG-AND-CHECK (LOGAND DATA 3777777))
  (LAM-EXECUTE (uinst-clock)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-PUSH
	       LAM-IR-ALUF LAM-ALU-SETM))


;;; THE FOLLOWING TWO FUNCTIONS ARE OLD, AND ARE KEPT AROUND FOR HISTERICAL PURPOSES

;Bad idea to do pushes, clobbers contents of stack.
(comment (defun write-usp (data)		;we do pops until we get there
  (do* ((start (read-usp))
	(required-pops (cond ((> data start)(- 256. (- data start)))
			     ((< data start)(- start data))
			     (t 0)))
	(pop-count 0 (1+ pop-count)))
       (( pop-count required-pops)
	(cond ((not (= (read-usp) (logand 377 data)))
	       (ferror nil "unable to load usp. was ~s" START))))
    (us-pop))))

(COMMENT (defun write-usp-and-check-each-time (data)		;we do pops until we get there
  (do* ((start (read-usp))
	(required-pops (cond ((> data start)(- 256. (- data start)))
			     ((< data start)(- start data))
			     (t 0)))
	(pop-count 0 (1+ pop-count))
	(prev-usp (logand 377 (read-usp)))
	(tem))
       (( pop-count required-pops)
	(cond ((not (= (read-usp) (logand 377 data)))
	       (ferror nil "unable to load usp. was ~s" START))))
    (us-pop)
    (cond ((not (= (logand 377 (1- prev-usp)) (setq tem (logand 377 (read-usp)))))
	   (format t "~%USP FAILED TO POP CORRECTLY, BEFORE ~S AFTER ~S" prev-usp tem)))
    (setq prev-usp tem)
    )))
  

(defun write-usp (DATA)				;COMPLICATED. DO NOT mod unless you
  (WRITE-A-MEM 0 (LOGAND DATA 377))  		;know what you are doing
  (LAM-EXECUTE (uinst-clock)		
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-A-SRC 0
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-POINTER-IF-POP
	       LAM-IR-ALUF LAM-ALU-SETA))

(defun write-usp-stepping (DATA)		;COMPLICATED. DO NOT mod unless you
  (WRITE-M-MEM 1 (LOGAND DATA 377))		;know what you are doing
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)		
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-A-SRC 1
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-POINTER-IF-POP
	       LAM-IR-ALUF LAM-ALU-SETA)
  (SM-STEP-LOOP ':ZERO-IREG-AFTER-UINST-CLOCK T))

(defun write-usp-and-check (data)
  (setq data (logand 377 data))
  (write-usp data)
  (let ((new-value (read-usp)))
    (cond ((not (equal data new-value))
	   (ferror NIL "ERROR WRITING USP -- wrote ~O, read ~O" data new-value))
	  (T data))))

(defun write-and-decrement-usp (data)
  (write-usp data)
  (us-pop))

(DEFUN WRITE-AND-INCREMENT-USP (DATA)
  (WRITE-USP DATA)
  (US-PUSH))

(DEFUN INCREMENT-USP-AND-WRITE-US (DATA)
  (WRITE-SPY-REG-AND-CHECK (LOGAND DATA 3777777))
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-PUSH
	       LAM-IR-ALUF LAM-ALU-SETM))


(DEFUN WRITE-US (ADDRESS DATA)
  (WRITE-USP (1- ADDRESS))
  (INCREMENT-USP-AND-WRITE-US DATA))

(DEFUN READ-TOP-OF-US ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-micro-stack
	       LAM-IR-ALUF LAM-ALU-SETM)
  (logand (READ-MFO) 3777777))

(defun read-us (address)
  (write-usp address)
  (READ-TOP-OF-US))

(DEFUN POP-US-THEN-READ ()
  (LAM-EXECUTE (UINST-CLOCK)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-TOP-OF-US))

(DEFUN READ-US-POP (&AUX VALUE)
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (SETQ VALUE (LOGAND (READ-MFO) 3777777))
  (ADVANCE-TO-UINST-BOUNDARY-PLUS-UINST-CLOCK-LOW)
  VALUE)

(DEFUN US-POP ()
  (LAM-EXECUTE (UINST-CLOCK)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-USP))

(DEFUN US-POP-THEN-READ-PC ()
  (LAM-EXECUTE (UINST-CLOCK)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-PC))

(DEFUN UINST-US-POP-LOOP ()
  (DISABLE-LAMBDA)
  (ULOAD ()
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-SRC LAM-M-SRC-MICRO-STACK-POP
	LAM-IR-ALUF LAM-ALU-SETM)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-SPARE-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

;zeros the usp (actually 377'ifies the way the main ucode does, by repeatedly pushing
;  until usp is 377.
(defun uinst-zero-usp ()
  (disable-lambda)
  (write-usp 0)
  (write-a-mem 1 37700000001)
  (uload ()
    0   (lam-ir-op lam-op-jump
	 lam-ir-jump-addr 0
	 lam-ir-n 1
	 lam-ir-p 1
	 lam-ir-jump-cond lam-jump-cond-m-neq-a
	 lam-ir-m-src lam-m-src-micro-stack
	 lam-ir-a-src 1)
    	(lam-ir-op lam-op-alu
	 lam-ir-halt 1)
	)
  (setup-machine-to-start-at 0))

(DEFUN UINST-CALL-LOOP  (&OPTIONAL (ONE-LOC 1000) (OTHER-LOC 100))
  (DISABLE-LAMBDA)
  (ULOAD (ONE-LOC OTHER-LOC)
    0	      (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    ONE-LOC   (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR OTHER-LOC
	       LAM-IR-P 1
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR ONE-LOC
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (0)
   OTHER-LOC  (LAM-IR-OP LAM-OP-JUMP
	       lam-ir-jump-addr one-loc
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
   	      (LAM-IR-SPARE-BIT 1))
  (SETUP-MACHINE-TO-START-AT ONE-LOC))


;;old test from cadr..previously cc-test-spc-pointer			     
(DEFUN TEST-USP () 
  (PROG (USP READ GOOD)
	(SETQ USP (READ-USP))
	(DOTIMES (C 256.)
	  (US-PUSH)
	  (SETQ READ (READ-USP))
	  (COND ((NOT (= (SETQ GOOD (LOGAND 377 (+ (1+ C) USP))) READ))
		 (FORMAT T "~%USP INCREMENT FAILED, WAS ~O, SHOULD BE ~O" READ GOOD))))
	(SETQ USP (READ-USP))
	(DOTIMES (C 256.)
	   (read-us-pop)
	   (SETQ READ (read-usp))
	   (COND ((NOT (= (SETQ GOOD (LOGAND 377 (- USP (1+ C)))) READ))
		  (FORMAT T "~%USP DECREMENT FAILED, WAS ~O, SHOULD BE ~O" READ GOOD))))
	))


;;now for the standard data path and fast address tests

(defun lam-test-micro-stack () "tests the USP and the four pathways  to the US
see uinst-call-loop for problems with the pushj data path"
  (test-usp-data-path)
  (test-us-data-path)
  (test-us-via-pushj-data-path)
  (test-us-via-pushj-n-data-path)
  (test-dispatch-push-own-address-data-path)
;  (test-us-via-pc-data-path)
  )

(DEFUN TEST-USP-DATA-PATH NIL (TEST-DATA-PATH "USP" 'USP-ACTOR 8.))

(DEFSELECT (USP-ACTOR)
  (:READ (ADDRESS) ADDRESS
   (READ-USP))
  (:WRITE (ADDRESS DATA) ADDRESS
   (WRITE-USP DATA)))

;;******* four tests, one for each data path for writes into the microstack********

;; write via dest-us-push, read via src-us

(DEFUN TEST-US-DATA-PATH NIL (TEST-DATA-PATH "US via dest us push" 'US-ACTOR 20.))

(DEFSELECT (US-ACTOR)
  (:READ (ADDRESS) ADDRESS
   (READ-US 0))	
  (:WRITE (ADDRESS DATA) ADDRESS
   (WRITE-US 0 DATA))) 


;; write via pushj, read via src-us

(DEFUN TEST-US-VIA-PUSHJ-DATA-PATH NIL
  "use uinst-call-loop to diagnose problems with this test"
  (TEST-DATA-PATH "US via pushj (pushes old IPC)"
					     'US-VIA-PUSHJ-ACTOR 16.))

(DEFSELECT (US-VIA-PUSHJ-ACTOR)
  (:READ (ADDRESS) ADDRESS
   (read-top-of-us))	
  (:WRITE (ADDRESS DATA) ADDRESS
   (WRITE-US-VIA-PUSHJ DATA)))

(DEFUN WRITE-US-VIA-PUSHJ (DATA)
  (WRITE-PC (logand 177777 (1- DATA)))			;DATA IN NPC,MOVES TO PC, OLD NPC
  (PUSHJ 0))

;; write via pushj-dont-ex-next, read via src-us

(DEFUN TEST-US-VIA-PUSHJ-N-DATA-PATH NIL (TEST-DATA-PATH
					   "US via pushj, dont execute next (pushes old PC)"
					     'US-VIA-PUSHJ-N-ACTOR 16.))

(DEFSELECT (US-VIA-PUSHJ-N-ACTOR)
  (:READ (ADDRESS) ADDRESS
   (read-top-of-us))	
  (:WRITE (ADDRESS DATA) ADDRESS
   (WRITE-US-VIA-PUSHJ-N DATA)))

(DEFUN WRITE-US-VIA-PUSHJ-N (DATA)
  (WRITE-PC (logand 177777 DATA))				;data winds up in old npc reg
  (PUSHJ-N 0))

;; write via dispatch-push-own-address, read via src-us

;;turns out this is already defined in the file lambda-diag;dispatch.lisp



;;;;**********************************************************************

(defun test-us-via-pc-data-path () (test-data-path "US via PC" 'us-via-pc-actor 16.))

(DEFSELECT (US-VIA-PC-ACTOR)
  (:READ (ADDRESS) ADDRESS
   (US-POP-THEN-READ-PC))	
  (:WRITE (ADDRESS DATA) ADDRESS
   (US-PUSH DATA))) 


(DEFUN FAST-ADDRESS-TEST-US ()
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 20.)	
	(READ-FCTN 'READ-US)
	(WRITE-FCTN 'WRITE-US)
	(N-ADDRESS-BITS 8.)
	(MESSAGE "FAST-ADDRESS-TEST of Micro-stack"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE 2)))

(DEFUN UINST-US-PUSH-LOOP ()
  (WRITE-SPY-REG-AND-CHECK 0)
  (DISABLE-LAMBDA)				
  (ULOAD (M-MEM-LOCN)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-PUSH
	LAM-IR-ALUF LAM-ALU-SETM)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-SPARE-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

(DEFUN US-UP ()
  (US-PUSH)
  (READ-USP))

(DEFUN US-DOWN ()
  (READ-US-POP)
  (READ-USP))

(DEFUN US-WAYUP ()
  (DOTIMES (I 10)
    (INCREMENT-USP-AND-WRITE-US 0)))


;;popj tests: particularly after the mod to the popj-after-next logic
;;
;;1. POPJ DURING PUSHJ: SET THE POPJ BIT IN AN UNCONDITIONAL PUSHJ AFTER
;;   FIRST PUSHING DATA ON THE STACK.  PC SHOULD BE DATA, NOT JUMP ADR

(DEFUN POPJ-IN-PUSHJ (LOC)
  (LAM-EXECUTE (UINST-CLOCK-PLUS-UINST-CLOCK-LOW)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR LOC
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	       LAM-IR-P 1
	       LAM-IR-POPJ-AFTER-NEXT 1))		;???

(DEFUN PUSHJ (LOC)				;PUSHES OLD VALUE OF IPC ON STACK
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR LOC
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	       LAM-IR-P 1))

(DEFUN fnork (data)				;PUSHES OLD VALUE OF IPC ON STACK
  (write-pc (1- data))
  (LAM-EXECUTE (uinst-clock-plus-uinst-clock-low)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	       LAM-IR-P 1))

(DEFUN PUSHJ-DONT-EX-NEXT (LOC)			;PUSHES OLD VALUE OF PC ON THE STACK
  (PUSHJ-N LOC))

(DEFUN PUSHJ-N (LOC)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR LOC
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	       LAM-IR-P 1
	       LAM-IR-N 1))