;;;;;-*- 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-MA "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-MA "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-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))