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


;;; this file contains the diagnostics for the jump logic, but not the micro-stack
;;; which is contained in the file MICRO-STACK

(DEFUN COND-JUMP-TEST ()
  (FORMAT LAMBDA-DIAG-STREAM " test of conditional jumps (COND-JUMP-TEST)")
  (let ((return-value
	  (*catch 'cond-jump-test-catch
	    (DO ((BIT 0 (1+ BIT))
		 (DAT))
		((= BIT 31.))
	      (SETQ DAT (ASH 1 BIT))
	      (format t "~&DATA BASED ON ~O (BIT ~D SET)" dat bit)
	      (WRITE-M-MEM 1 DAT)
	      (WRITE-M-MEM 2 (1- DAT))
	      (WRITE-M-MEM 3 (MINUS DAT))
	      (WRITE-M-MEM 4 (MINUS (1- DAT)))
	      (DO ((I 1 (1+ I)))
		  ((= I 4))
		(if (send terminal-io :tyi-no-hang)
		    (*throw 'cond-jump-test-catch 'aborting-test))
		(LAM-TEST-JUMP-INTERNAL I I LAM-JUMP-COND-M=A "M=A" T)
		(LAM-TEST-JUMP-INTERNAL I I LAM-JUMP-COND-M<A "M<A" NIL)
		(LAM-TEST-JUMP-INTERNAL I I LAM-JUMP-COND-M>A "M>A" NIL)
		(LAM-TEST-JUMP-INTERNAL I I LAM-JUMP-COND-M<=A "M<=A" T)
		(LAM-TEST-JUMP-INTERNAL I I LAM-JUMP-COND-M>=A "M>=A" T))
	      (LAM-TEST-JUMP-1 2 1)
	      (LAM-TEST-JUMP-1 3 4)))))
    (if (stringp return-value)
	(format lambda-diag-stream "......ABORTING TEST"))
    RETURN-VALUE))

(defun cond-jump-test-2 ()
  (do ((m-2 10000000000 (ash m-2 -1)))
      ((= m-2 1))
    (write-m-mem 2 m-2)
    (do ((m-1 (ash m-2 -1) (ash m-1 -1))
	 (C 0 (1+ C)))
	((OR (zerop m-1)
	     (> C 6)))		;idea is to mainly test A=M output local to one ALU chip.
      (write-m-mem 1 m-1)
      ;(lam-test-jump-1 1 2)
      (LAM-TEST-JUMP-INTERNAL 1 2 LAM-JUMP-COND-M<A "M<A" T)
      )))

(DEFUN LAM-TEST-JUMP-1 (LESS MORE)
  (LAM-TEST-JUMP-INTERNAL LESS MORE LAM-JUMP-COND-M<A "M<A" T)
  (LAM-TEST-JUMP-INTERNAL MORE LESS LAM-JUMP-COND-M<A "M<A" NIL)
  (LAM-TEST-JUMP-INTERNAL LESS MORE LAM-JUMP-COND-M>A "M>A" NIL)
  (LAM-TEST-JUMP-INTERNAL MORE LESS LAM-JUMP-COND-M>A "M>A" T))

;(DEFUN FOO-TEST ()
;  (LAM-TEST-JUMP-INTERNAL 33 452 LAM-JUMP-COND-M>A "M>A" NIL))

(defun jump-on-bit-test ()
  (dotimes (bit-number 32.)
    (if (send terminal-io :tyi-no-hang) (*throw 'cond-jump-test-catch "aborting-test"))
    (write-m-mem 1 (dpb 1 (byte 1 bit-number) 0))
    (lam-test-jump-internal 1 0 lam-jump-if-bit-set "BIT-SET" t bit-number)
    (lam-test-jump-internal 1 0 lam-jump-if-bit-clear "BIT-CLEAR" nil bit-number)
    (write-m-mem 1 (dpb 0 (byte 1 bit-number) -1))
    (lam-test-jump-internal 1 0 lam-jump-if-bit-set "BIT-SET" nil bit-number)
    (lam-test-jump-internal 1 0 lam-jump-if-bit-clear "BIT-CLEAR" t bit-number)
    )
  t)

(defun simple-jump-if-bit-set ()
  (write-m-mem 1 0)
  (write-pc 0 0)
  (lam-execute (uinst-clock)
	       lam-ir-op lam-op-jump
	       lam-ir-m-src 1
	       lam-ir-mrot (- 40 1)
	       lam-ir-bit-test lam-jump-if-bit-set
	       lam-ir-jump-addr 777)
  (select (read-pc)
    (777 'fail)
    (1 'win)))

(defun bit-test-jump-loop ()
  (disable-lambda)
  (write-m-mem 1 0)
  (uload ()
   0
	 (lam-ir-op lam-op-jump
	  lam-ir-m-src 1
	  lam-ir-mrot 37
	  lam-ir-bit-test lam-jump-if-bit-set
	  lam-ir-n 1
	  lam-ir-jump-addr 0)
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-jump
	  lam-ir-jump-cond lam-jump-cond-unc
	  lam-ir-n 1))
  (setup-machine-to-start-at 0))

(defun fake-mtest-loop (&optional setup-everything &aux (memory-data 17777777777))
  (let ((m-loop-count 1)
	(m-correct-data 2)
	(m-memory-loc 3)
	(m-win-count 4)
	(m-zero 5)
	)
    (write-m-mem m-loop-count 0)
    (write-m-mem m-correct-data memory-data)
    (write-m-mem m-memory-loc 3162)
    (write-m-mem m-win-count 0)
    (write-m-mem m-zero 0)
    (uload (m-loop-count m-correct-data m-memory-loc m-win-count m-zero m-save)
     0
	   ;((m-loop-count) add m-loop-count a-zero alu-carry-in-one)
	   (lam-ir-op lam-op-alu
	    lam-ir-ob lam-ob-alu
	    lam-ir-aluf lam-alu-add
	    lam-ir-m-src m-loop-count
	    lam-ir-a-src m-zero
	    lam-ir-m-mem-dest m-loop-count
	    lam-ir-carry 1)
	   ;((vma-start-read) m-memory-loc)
	   (lam-ir-op lam-op-alu
	    lam-ir-ob lam-ob-alu
	    lam-ir-aluf lam-alu-setm
	    lam-ir-m-src m-memory-loc
	    lam-ir-func-dest lam-func-dest-vma-start-read
	    lam-ir-slow-dest 1)
	   ;(jump-if-page-fault bad-page-fault)
	   (lam-ir-op lam-op-jump
	    lam-ir-jump-cond lam-jump-cond-page-fault
	    lam-ir-jump-addr bad-page-fault
	    lam-ir-n 1)
;	   ;((m-save) md)
;	   (lam-ir-op lam-op-alu
;	    lam-ir-ob lam-ob-alu
;	    lam-ir-aluf lam-alu-setm
;	    lam-ir-m-src lam-m-src-md
;	    lam-ir-m-mem-dest m-save)
	   ;(call-not-equal md m-correct-data not-equal)
	   (lam-ir-op lam-op-jump
	    lam-ir-m-src lam-m-src-md
	    lam-ir-a-src m-correct-data
	    lam-ir-p 1
	    lam-ir-n 1
	    lam-ir-jump-cond lam-jump-cond-m-neq-a
	    lam-ir-jump-addr not-equal)
	   ;((m-win-count) add m-win-count a-zero alu-carry-in-one)
	   (lam-ir-op lam-op-alu
	    lam-ir-ob lam-ob-alu
	    lam-ir-aluf lam-alu-add
	    lam-ir-m-src m-win-count
	    lam-ir-a-src m-zero
	    lam-ir-m-mem-dest m-win-count
	    lam-ir-carry 1
	    lam-ir-spare-bit 1)
	   ;(jump 0)
	   (lam-ir-op lam-op-jump
	    lam-ir-jump-cond lam-jump-cond-unc
	    lam-ir-n 1
	    lam-ir-jump-addr 0)
	   ;(setz)
	   (lam-ir-op lam-op-alu)
     not-equal
	   ;(jump 0 spare-bit-58)
	   (lam-ir-op lam-op-jump
	    lam-ir-jump-cond lam-jump-cond-unc
	    lam-ir-n 1
	    lam-ir-jump-addr 0
	    )
	   ;(setz)
	   (lam-ir-op lam-op-alu)
     bad-page-fault
	   ;(halt)
	   (lam-ir-op lam-op-alu
	    lam-ir-halt 1))
    )
  (cond (setup-everything
	 (write-level-1-map 0 0)
	 (write-level-1-map 1 0)
	 (let ((page (dpb (SEND *PROC* :MEM-SLOT) 1604 17000000)))
	   (dotimes (i 64.)
	     (write-level-2-map-control i 1400)
	     (write-level-2-map-physical-page i page)))
	 (dotimes (i 1000)
	   (send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) i memory-data))))
)

(defun jump-equal-loop ()
  (write-md 17777777777)
  (write-m-mem 1 17777777777)
  (uload ()
   0
	 (lam-ir-op lam-op-jump
	  lam-ir-m-src lam-m-src-md
	  lam-ir-a-src 1
	  lam-ir-n 1
	  lam-ir-jump-cond lam-jump-cond-m=a
	  lam-ir-jump-addr 0
	  lam-ir-spare-bit 1)
	 (lam-ir-op lam-op-jump
	  lam-ir-jump-cond lam-jump-cond-unc
	  lam-ir-n 1
	  lam-ir-jump-addr 0)
	 (lam-ir-op lam-op-alu)))

(defun jump-loop (&OPTIONAL (data 40) (PRINT-ERRORS T))
  (write-m-mem 1 data)
  (do ((num-win 0)
       TEM)
      (())
    (write-pc 0 0)
    (LAM-EXECUTE (uinst-CLOCK) 
     LAM-IR-OP LAM-OP-JUMP
     LAM-IR-M-SRC 1
     LAM-IR-A-SRC 1
     LAM-IR-JUMP-COND lam-JUMP-COND-m=a
     LAM-IR-JUMP-ADDR 777)
    (COND (PRINT-ERRORS
	   (cond (( (SETQ TEM (read-pc)) 777)
		  (format t "~%FAILED TO JUMP PC = ~O ON ~D TRY"
			  TEM (1+ num-win))
		  (setq num-win 0))
		 (t (setq num-win (1+ num-win))))))))


(defun a-loop (data)
  (write-a-mem 1 data)
  (do ((num-win 0)
       (tem 0))(())
    (cond (( (setq tem (read-a-mem 1)) data)
	   (format t "~%FAILED = ~O ON ~D TRY"
		   tem(1+ num-win))
	   (setq num-win 0))
	  (t (setq num-win (1+ num-win))))))
  

(DEFUN LAM-TEST-JUMP-INTERNAL (M-ADR A-ADR JUMP-COND STRING SHOULD-JUMP &optional bit-pos)
  (let ((bit-test-p (or (= jump-cond lam-jump-if-bit-set)
			(= jump-cond lam-jump-if-bit-clear))))
    (cond ((and bit-test-p
		(null bit-pos))
	   (ferror nil "specified a bit test operation, but no bit position"))
	  ((and (null bit-test-p)
		bit-pos)
	   (ferror nil "specified a normal jump condition, and a bit position")))
		    
    ;(format t "~%M=~o, A=~o" (read-m-mem m-adr) (read-a-mem a-adr))
    (WRITE-PC 0 0)
    (LET ((*EXECUTE-SINGLE-UINST-MODE* T))
      (cond ((null bit-test-p)
	     (lam-execute (uinst-clock)
			  lam-ir-op lam-op-jump
			  lam-ir-m-src m-adr
			  lam-ir-a-src a-adr
			  lam-ir-jump-cond jump-cond
			  lam-ir-jump-addr 777))
	    (t
	     (lam-execute (uinst-clock)
			  lam-ir-op lam-op-jump
			  lam-ir-m-src m-adr
			  lam-ir-mrot (- 40 bit-pos)
			  lam-ir-bit-test jump-cond
			  lam-ir-jump-addr 777))))

    (LET ((NPC (READ-PC))
	  (expected-npc (COND (SHOULD-JUMP 777)
			      (T 1))))
  ;      (format t "~%~12O: " (read-m-mem m-adr))
  ;      (cond ((and should-jump (= npc 777))
  ;	     (format t "~%jump won. M=~O, A=~O, COND ~A, NPC=~O"
  ;		     (READ-M-MEM M-ADR)
  ;		     (READ-A-MEM A-ADR)
  ;		     STRING
  ;		     NPC)))
      (cond ((= expected-npc 777)
	     (COND ((NOT (= NPC 777))
		    (FORMAT T "~%FAILED TO JUMP!  M=~O, A=~O, COND ~A, NPC=~O"
			    (READ-M-MEM M-ADR)
			    (READ-A-MEM A-ADR)
			    STRING
			    NPC)
		    (if bit-test-p
			(format t ", BIT POS=~O (MROT=~O)" bit-pos (- 40 bit-pos))))))
	    (t
	     (COND ((NOT (= NPC 1))
		    (FORMAT T "~%SPURIOUS JUMP!   M=~O, A=~O, COND ~A, NPC=~O"
			    (READ-M-MEM M-ADR)
			    (READ-A-MEM A-ADR)
			    STRING
			    NPC)
		    (if bit-test-p
			(format t ", BIT POS=~O (MROT=~O)" bit-pos (- 40 bit-pos))))))))))



(DEFUN jump-stepping (M A &optional &key JUMP-COND (dest-pc 777) )
  (if (null jump-cond)
      (setq jump-cond (eval (tv:menu-choose '(LAM-JUMP-COND-M<A
					 LAM-JUMP-COND-M<=A
					 LAM-JUMP-COND-M=A
					 LAM-JUMP-COND-UNC
					 LAM-JUMP-COND-M>=A
					 LAM-JUMP-COND-M>A 
					 LAM-JUMP-COND-M-NEQ-A
					 LAM-JUMP-COND-DATA-TYPE-NOT-EQUAL
					 LAM-JUMP-COND-DATA-TYPE-EQUAL
					 )
				      "Possible values for LAM-IR-JUMP-COND"))))
  
  (WRITE-PC 0)
  (write-m-mem 1 m)
  (write-m-mem 2 a)
  (lam-execute (executor lam-execute-noclocks)
	       lam-ir-op lam-op-jump
	       lam-ir-m-src 1
	       lam-ir-a-src 2
	       lam-ir-jump-cond jump-cond
	       lam-ir-jump-addr dest-pc)
  (sm-step-loop ':zero-ireg-after-uinst-clock t))

(DEFUN simple-jump-stepping ()
  (assure-noop-cleared)
  (lam-execute (executor lam-execute-noclocks)
	       lam-ir-op lam-op-jump
	       lam-ir-jump-cond lam-jump-cond-unc
	       lam-ir-n 1
	       lam-ir-jump-addr 0)
  (sm-step-loop ':zero-ireg-after-uinst-clock t))

 

(DEFUN UINST-JUMP-EQUAL-LOOP  (&OPTIONAL (a-and-m-value 40) (jump-dest 777) &AUX TEM)
  (DISABLE-LAMBDA)
  (wipe-m-mem)
  (write-m-mem 1 a-and-m-value)
  (write-m-mem 5 0)
  (write-m-mem 6 0)
  (COND ((NOT (= A-AND-M-VALUE (SETQ TEM (READ-A-MEM 1))))
	 (FERROR NIL "A mem failed to write, is ~s should be ~s" TEM A-AND-M-VALUE))
	((NOT (= A-AND-M-VALUE (SETQ TEM (READ-M-MEM 1))))
	 (FERROR NIL "M mem failed to write, is ~s should be ~s" TEM A-AND-M-VALUE)))
  (ULOAD (jump-dest)
	 0	      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR 0
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	 LOOP	      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR jump-dest
		       lam-ir-m-src 1
		       lam-ir-a-src 1
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND lam-jump-cond-m=a)
		      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu			;DUMMY
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 5
		       lam-ir-m-mem-dest 5 )
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
		      (LAM-IR-OP 0)
	   jump-dest  (LAM-IR-OP LAM-OP-JUMP			;JUMP BACK TO loop
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 0
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
		      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu			;DUMMY
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 6
		       lam-ir-m-mem-dest 6
		       LAM-IR-SPARE-BIT 1))
  (SETUP-MACHINE-TO-START-AT 1))

;count losses in 1, wins in 2
(DEFUN UINST-COMPARE-LOOP  (&OPTIONAL (M-LOC 5) (jump-dest 777) (data 0))
  (DISABLE-LAMBDA)
  (wipe-m-mem)
  (write-m-mem M-LOC data)
  (ULOAD (M-LOC jump-dest)
	 0	      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR 0
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	 LOOP 	      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src M-LOC
		       lam-ir-m-mem-dest M-LOC
		       LAM-IR-SPARE-BIT 1)
		      (LAM-IR-OP LAM-OP-ALU)  ;noop to clear passaround path
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR jump-dest
		       lam-ir-m-src M-LOC
		       lam-ir-a-src M-LOC
		       LAM-IR-STAT-BIT 1
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND lam-jump-cond-m=a)
		      (lam-ir-op lam-op-alu  ;lost if this path taken
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 1
		       lam-ir-m-mem-dest 1 )
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
		      (LAM-IR-OP 0)
	   jump-dest  (LAM-IR-OP LAM-OP-JUMP			;JUMP BACK TO loop
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 0
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
		      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 2
		       lam-ir-m-mem-dest 2))
  (SETUP-MACHINE-TO-START-AT 1))

;count losses in 1, wins in 2.  same as above, except compare happens via passaround on both
; M and A.
(DEFUN UINST-COMPARE-PASSAROUND-LOOP  (&OPTIONAL (M-LOC 5) (jump-dest 777))
  (DISABLE-LAMBDA)
  (wipe-m-mem)
  (write-m-mem M-LOC 0)
  (ULOAD (M-LOC jump-dest)
	 0	      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR 0
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	 LOOP 	      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src M-LOC
		       lam-ir-m-mem-dest M-LOC
		       LAM-IR-SPARE-BIT 1)
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR jump-dest
		       lam-ir-m-src M-LOC
		       lam-ir-a-src M-LOC
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND lam-jump-cond-m=a)
		      (lam-ir-op lam-op-alu  ;lost if this path taken
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 1
		       lam-ir-m-mem-dest 1 )
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
		      (LAM-IR-OP 0)
	   jump-dest  (LAM-IR-OP LAM-OP-JUMP			;JUMP BACK TO loop
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 0
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
		      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu			;DUMMY
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 2
		       lam-ir-m-mem-dest 2))
  (SETUP-MACHINE-TO-START-AT 1))